git.iko.soy/Idris-dev
on 89c19be help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1372 lines 50 kB history raw
1{-# LANGUAGE PatternGuards #-}
2{-# LANGUAGE OverloadedStrings #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
5import IRTS.JavaScript.AST
7import Idris.AbsSyntax hiding (TypeCase)
8import IRTS.Bytecode
9import IRTS.Lang
10import IRTS.Simplified
11import IRTS.Defunctionalise
12import IRTS.CodegenCommon
13import Idris.Core.TT
14import IRTS.System
15import Util.System
17import Control.Arrow
18import Control.Monad (mapM)
19import Control.Applicative ((<$>), (<*>), pure)
20import Control.Monad.RWS hiding (mapM)
21import Control.Monad.State
22import Data.Char
23import Numeric
24import Data.List
25import Data.Maybe
26import Data.Word
27import Data.Traversable hiding (mapM)
28import System.IO
29import System.Directory
31import qualified Data.Map.Strict as M
32import qualified Data.Text as T
33import qualified Data.Text.IO as TIO
36data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
37 , compileInfoEvalCases :: [Int]
38 , compileInfoNeedsBigInt :: Bool
39 }
42initCompileInfo :: [(Name, [BC])] -> CompileInfo
43initCompileInfo bc =
44 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
45 where
46 lookupBigInt :: [(Name, [BC])] -> Bool
47 lookupBigInt = any (needsBigInt . snd)
48 where
49 needsBigInt :: [BC] -> Bool
50 needsBigInt bc = any testBCForBigInt bc
51 where
52 testBCForBigInt :: BC -> Bool
53 testBCForBigInt (ASSIGNCONST _ c) =
54 testConstForBigInt c
56 testBCForBigInt (CONSTCASE _ c d) =
57 maybe False needsBigInt d
58 || any (needsBigInt . snd) c
59 || any (testConstForBigInt . fst) c
61 testBCForBigInt (CASE _ _ c d) =
62 maybe False needsBigInt d
63 || any (needsBigInt . snd) c
65 testBCForBigInt _ = False
67 testConstForBigInt :: Const -> Bool
68 testConstForBigInt (BI _) = True
69 testConstForBigInt (B64 _) = True
70 testConstForBigInt _ = False
73 collectCases :: String -> [(Name, [BC])] -> [Int]
74 collectCases fun bc = getCases $ findFunction fun bc
76 findFunction :: String -> [(Name, [BC])] -> [BC]
77 findFunction f ((MN 0 fun, bc):_)
78 | fun == txt f = bc
79 findFunction f (_:bc) = findFunction f bc
81 getCases :: [BC] -> [Int]
82 getCases = concatMap analyze
83 where
84 analyze :: BC -> [Int]
85 analyze (CASE _ _ b _) = map fst b
86 analyze _ = []
89data JSTarget = Node | JavaScript deriving Eq
92codegenJavaScript :: CodeGenerator
93codegenJavaScript ci =
94 codegenJS_all JavaScript (simpleDecls ci)
95 (includes ci) [] (outputFile ci) (outputType ci)
97codegenNode :: CodeGenerator
98codegenNode ci =
99 codegenJS_all Node (simpleDecls ci)
100 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
102codegenJS_all
103 :: JSTarget
104 -> [(Name, SDecl)]
105 -> [FilePath]
106 -> [String]
107 -> FilePath
108 -> OutputType
109 -> IO ()
110codegenJS_all target definitions includes libs filename outputType = do
111 let bytecode = map toBC definitions
112 let info = initCompileInfo bytecode
113 let js = concatMap (translateDecl info) bytecode
114 let full = concatMap processFunction js
115 let code = deadCodeElim full
116 let (cons, opt) = optimizeConstructors code
117 let (header, rt) = case target of
118 Node -> ("#!/usr/bin/env node\n", "-node")
119 JavaScript -> ("", "-browser")
121 included <- concat <$> getIncludes includes
122 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
123 idrRuntime <- readFile $ path ++ "Runtime-common.js"
124 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
125 jsbn <- if compileInfoNeedsBigInt info
126 then readFile $ path ++ "jsbn/jsbn.js"
127 else return ""
128 let runtime = ( header
129 ++ includeLibs libs
130 ++ included
131 ++ jsbn
132 ++ idrRuntime
133 ++ tgtRuntime
134 )
135 TIO.writeFile filename ( T.pack runtime
136 `T.append` T.concat (map compileJS opt)
137 `T.append` T.concat (map compileJS cons)
138 `T.append` main
139 `T.append` invokeMain
140 )
141 setPermissions filename (emptyPermissions { readable = True
142 , executable = target == Node
143 , writable = True
144 })
145 where
146 deadCodeElim :: [JS] -> [JS]
147 deadCodeElim js = concatMap collectFunctions js
148 where
149 collectFunctions :: JS -> [JS]
150 collectFunctions fun@(JSAlloc name _)
151 | name == translateName (sMN 0 "runMain") = [fun]
153 collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =
154 let invokations = sum $ map (
155 \x -> execState (countInvokations name x) 0
156 ) js
157 in if invokations == 0
158 then []
159 else [fun]
161 countInvokations :: String -> JS -> State Int ()
162 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
163 countInvokations name body
165 countInvokations name (JSSeq seq) =
166 void $ traverse (countInvokations name) seq
168 countInvokations name (JSAssign _ rhs) =
169 countInvokations name rhs
171 countInvokations name (JSCond conds) =
172 void $ traverse (
173 runKleisli $ arr id *** Kleisli (countInvokations name)
174 ) conds
176 countInvokations name (JSSwitch _ conds def) =
177 void $ traverse (
178 runKleisli $ arr id *** Kleisli (countInvokations name)
179 ) conds >> traverse (countInvokations name) def
181 countInvokations name (JSApp lhs rhs) =
182 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
184 countInvokations name (JSNew _ args) =
185 void $ traverse (countInvokations name) args
187 countInvokations name (JSArray args) =
188 void $ traverse (countInvokations name) args
190 countInvokations name (JSIdent name')
191 | name == name' = get >>= put . (+1)
192 | otherwise = return ()
194 countInvokations _ _ = return ()
196 processFunction :: JS -> [JS]
197 processFunction =
198 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
200 includeLibs :: [String] -> String
201 includeLibs =
202 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
204 getIncludes :: [FilePath] -> IO [String]
205 getIncludes = mapM readFile
207 main :: T.Text
208 main =
209 compileJS $ JSAlloc "main" (Just $
210 JSFunction [] (
211 case target of
212 Node -> mainFun
213 JavaScript -> jsMain
214 )
215 )
217 jsMain :: JS
218 jsMain =
219 JSCond [ (exists document `jsAnd` isReady, mainFun)
220 , (exists window, windowMainFun)
221 , (JSTrue, mainFun)
222 ]
223 where
224 exists :: JS -> JS
225 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
227 window :: JS
228 window = JSIdent "window"
230 document :: JS
231 document = JSIdent "document"
233 windowMainFun :: JS
234 windowMainFun =
235 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
236 , JSFunction [] ( mainFun )
237 , JSFalse
238 ]
240 isReady :: JS
241 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
243 readyState :: JS
244 readyState = JSProj (JSIdent "document") "readyState"
246 mainFun :: JS
247 mainFun =
248 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
249 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
250 , JSApp (
251 JSIdent (translateName (sMN 0 "runMain"))
252 ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
253 , JSWhile (JSProj jsCALLSTACK "length") (
254 JSSeq [ JSAlloc "func" (Just jsPOP)
255 , JSAlloc "args" (Just jsPOP)
256 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
257 ]
258 )
259 ]
261 invokeMain :: T.Text
262 invokeMain = compileJS $ JSApp (JSIdent "main") []
264optimizeConstructors :: [JS] -> ([JS], [JS])
265optimizeConstructors js =
266 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
267 (map (allocCon . snd) (M.toList cons), js')
268 where
269 allocCon :: (String, JS) -> JS
270 allocCon (name, con) = JSAlloc name (Just con)
272 newConstructor :: Int -> String
273 newConstructor n = "i$CON$" ++ show n
275 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
276 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
277 , JSArray []
278 , a
279 , e
280 ]) = do
281 s <- get
282 case M.lookup tag s of
283 Just (i, c) -> return $ JSIdent i
284 Nothing -> do let n = newConstructor tag
285 put $ M.insert tag (n, js) s
286 return $ JSIdent n
288 optimizeConstructor' (JSSeq seq) =
289 JSSeq <$> traverse optimizeConstructor' seq
291 optimizeConstructor' (JSSwitch reg cond def) = do
292 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
293 def' <- traverse optimizeConstructor' def
294 return $ JSSwitch reg cond' def'
296 optimizeConstructor' (JSCond cond) =
297 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
299 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
300 body' <- optimizeConstructor' body
301 return $ JSAlloc fun (Just (JSFunction args body'))
303 optimizeConstructor' (JSAssign lhs rhs) = do
304 lhs' <- optimizeConstructor' lhs
305 rhs' <- optimizeConstructor' rhs
306 return $ JSAssign lhs' rhs'
308 optimizeConstructor' js = return js
310collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
311collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
312 where
313 generateSplitFunction :: (Int,JS) -> JS
314 generateSplitFunction (depth, JSAlloc name fun) =
315 JSAlloc (name ++ "$" ++ show depth) fun
317splitFunction :: JS -> RWS () [(Int,JS)] Int JS
318splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
319 body' <- splitSequence body
320 return $ JSAlloc name (Just (JSFunction args body'))
321 where
322 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
323 splitCondition js
324 | JSCond branches <- js =
325 JSCond <$> processBranches branches
326 | JSSwitch cond branches def <- js =
327 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
328 | otherwise = return js
329 where
330 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
331 processBranches =
332 traverse (runKleisli (arr id *** Kleisli splitSequence))
334 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
335 splitSequence js@(JSSeq seq) =
336 let (pre,post) = break isBranch seq in
337 case post of
338 [_] -> JSSeq <$> traverse splitCondition seq
339 [call@(JSCond _),rest@(JSApp _ _)] -> do
340 rest' <- splitCondition rest
341 call' <- splitCondition call
342 return $ JSSeq (pre ++ [rest', call'])
343 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
344 rest' <- splitCondition rest
345 call' <- splitCondition call
346 return $ JSSeq (pre ++ [rest', call'])
347 (call:rest) -> do
348 depth <- get
349 put (depth + 1)
350 new <- splitFunction (newFun rest)
351 tell [(depth, new)]
352 call' <- splitCondition call
353 return $ JSSeq (pre ++ (newCall depth : [call']))
354 _ -> JSSeq <$> traverse splitCondition seq
356 splitSequence js = return js
358 isBranch :: JS -> Bool
359 isBranch (JSApp (JSIdent "i$CALL") _) = True
360 isBranch (JSCond _) = True
361 isBranch (JSSwitch _ _ _) = True
362 isBranch _ = False
364 newCall :: Int -> JS
365 newCall depth =
366 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
367 , JSArray [jsOLDBASE, jsMYOLDBASE]
368 ]
370 newFun :: [JS] -> JS
371 newFun seq =
372 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
374splitFunction js = return js
376translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
377translateDecl info (name@(MN 0 fun), bc)
378 | txt "APPLY" == fun =
379 allocCaseFunctions (snd body)
380 ++ [ JSAlloc (
381 translateName name
382 ) (Just $ JSFunction ["oldbase"] (
383 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
384 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
385 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
386 )
387 , ( JSNoop
388 , JSSeq $ map (translateBC info) (defaultCase (snd body))
389 )
390 ]
391 ]
392 )
393 )
394 ]
396 | txt "EVAL" == fun =
397 allocCaseFunctions (snd body)
398 ++ [ JSAlloc (
399 translateName name
400 ) (Just $ JSFunction ["oldbase"] (
401 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
402 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
403 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
404 )
405 , ( JSNoop
406 , JSSeq $ map (translateBC info) (defaultCase (snd body))
407 )
408 ]
409 ]
410 )
411 )
412 ]
413 where
414 body :: ([BC], [BC])
415 body = break isCase bc
417 isCase :: BC -> Bool
418 isCase bc
419 | CASE {} <- bc = True
420 | otherwise = False
422 defaultCase :: [BC] -> [BC]
423 defaultCase ((CASE _ _ _ (Just d)):_) = d
425 caseReg :: [BC] -> Reg
426 caseReg ((CASE _ r _ _):_) = r
428 allocCaseFunctions :: [BC] -> [JS]
429 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
430 allocCaseFunctions _ = []
432 splitBranches :: [(Int, [BC])] -> [JS]
433 splitBranches = map prepBranch
435 prepBranch :: (Int, [BC]) -> JS
436 prepBranch (tag, code) =
437 JSAlloc (
438 translateName name ++ "$" ++ show tag
439 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
440 JSSeq $ map (translateBC info) code
441 )
442 )
444translateDecl info (name, bc) =
445 [ JSAlloc (
446 translateName name
447 ) (Just $ JSFunction ["oldbase"] (
448 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
449 )
450 )
451 ]
453jsFUNPRELUDE :: [JS]
454jsFUNPRELUDE = [jsALLOCMYOLDBASE]
456jsALLOCMYOLDBASE :: JS
457jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
459translateReg :: Reg -> JS
460translateReg reg
461 | RVal <- reg = jsRET
462 | Tmp <- reg = JSRaw "//TMPREG"
463 | L n <- reg = jsLOC n
464 | T n <- reg = jsTOP n
466translateConstant :: Const -> JS
467translateConstant (I i) = JSNum (JSInt i)
468translateConstant (Fl f) = JSNum (JSFloat f)
469translateConstant (Ch c) = JSString $ translateChar c
470translateConstant (Str s) = JSString $ concatMap translateChar s
471translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
472translateConstant StrType = JSType JSStringTy
473translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
474translateConstant (AType ATFloat) = JSType JSFloatTy
475translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
476translateConstant Forgot = JSType JSForgotTy
477translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
478translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
479translateConstant (BI i) = jsBigInt (JSString $ show i)
480translateConstant (B8 b) = JSWord (JSWord8 b)
481translateConstant (B16 b) = JSWord (JSWord16 b)
482translateConstant (B32 b) = JSWord (JSWord32 b)
483translateConstant (B64 b) = JSWord (JSWord64 b)
484translateConstant c =
485 JSError $ "Unimplemented Constant: " ++ show c
488translateChar :: Char -> String
489translateChar ch
490 | '\a' <- ch = "\\u0007"
491 | '\b' <- ch = "\\b"
492 | '\f' <- ch = "\\f"
493 | '\n' <- ch = "\\n"
494 | '\r' <- ch = "\\r"
495 | '\t' <- ch = "\\t"
496 | '\v' <- ch = "\\v"
497 | '\SO' <- ch = "\\u000E"
498 | '\DEL' <- ch = "\\u007F"
499 | '\\' <- ch = "\\\\"
500 | '\"' <- ch = "\\\""
501 | '\'' <- ch = "\\\'"
502 | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
503 | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
504 | otherwise = [ch]
505 where
506 fill :: String -> String
507 fill s = case length s of
508 1 -> "000" ++ s
509 2 -> "00" ++ s
510 3 -> "0" ++ s
511 _ -> s
513 asciiTab =
514 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
515 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
516 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
517 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
519translateName :: Name -> String
520translateName n = "_idris_" ++ concatMap cchar (showCG n)
521 where cchar x | isAlphaNum x = [x]
522 | otherwise = "_" ++ show (fromEnum x) ++ "_"
524jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
525jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
527jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
528jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
530jsCALL :: CompileInfo -> Name -> JS
531jsCALL _ n =
532 JSApp (
533 JSIdent "i$CALL"
534 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
536jsTAILCALL :: CompileInfo -> Name -> JS
537jsTAILCALL _ n =
538 JSApp (
539 JSIdent "i$CALL"
540 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
542jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
543jsFOREIGN _ reg n args
544 | n == "isNull"
545 , [(FPtr, arg)] <- args =
546 JSAssign (
547 translateReg reg
548 ) (
549 JSBinOp "==" (translateReg arg) JSNull
550 )
552 | n == "idris_eqPtr"
553 , [(_, lhs),(_, rhs)] <- args =
554 JSAssign (
555 translateReg reg
556 ) (
557 JSBinOp "==" (translateReg lhs) (translateReg rhs)
558 )
559 | otherwise =
560 JSAssign (
561 translateReg reg
562 ) (
563 JSFFI n (map generateWrapper args)
564 )
565 where
566 generateWrapper :: (FType, Reg) -> JS
567 generateWrapper (ty, reg)
568 | FFunction <- ty =
569 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
570 , JSIdent "oldbase"
571 , JSIdent "myoldbase"
572 ]
573 | FFunctionIO <- ty =
574 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
575 , JSIdent "oldbase"
576 , JSIdent "myoldbase"
577 ]
579 generateWrapper (_, reg) =
580 translateReg reg
582jsREBASE :: CompileInfo -> JS
583jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
585jsSTOREOLD :: CompileInfo ->JS
586jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
588jsADDTOP :: CompileInfo -> Int -> JS
589jsADDTOP info n
590 | 0 <- n = JSNoop
591 | otherwise =
592 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
594jsTOPBASE :: CompileInfo -> Int -> JS
595jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
596jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
599jsBASETOP :: CompileInfo -> Int -> JS
600jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
601jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
603jsNULL :: CompileInfo -> Reg -> JS
604jsNULL _ r = JSAssign (translateReg r) JSNull
606jsERROR :: CompileInfo -> String -> JS
607jsERROR _ = JSError
609jsSLIDE :: CompileInfo -> Int -> JS
610jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
611jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
613jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
614jsMKCON info r t rs =
615 JSAssign (translateReg r) (
616 JSNew "i$CON" [ JSNum (JSInt t)
617 , JSArray (map translateReg rs)
618 , if t `elem` compileInfoApplyCases info
619 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
620 else JSNull
621 , if t `elem` compileInfoEvalCases info
622 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
623 else JSNull
624 ]
625 )
627jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
628jsCASE info safe reg cases def =
629 JSSwitch (tag safe $ translateReg reg) (
630 map ((JSNum . JSInt) *** prepBranch) cases
631 ) (fmap prepBranch def)
632 where
633 tag :: Bool -> JS -> JS
634 tag True = jsCTAG
635 tag False = jsTAG
637 prepBranch :: [BC] -> JS
638 prepBranch bc = JSSeq $ map (translateBC info) bc
640 jsTAG :: JS -> JS
641 jsTAG js =
642 (JSTernary (js `jsInstanceOf` "i$CON") (
643 JSProj js "tag"
644 ) (JSNum (JSInt $ negate 1)))
646 jsCTAG :: JS -> JS
647 jsCTAG js = JSProj js "tag"
650jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
651jsCONSTCASE info reg cases def =
652 JSCond $ (
653 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
654 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
655 where
656 prepBranch :: [BC] -> JS
657 prepBranch bc = JSSeq $ map (translateBC info) bc
659jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
660jsPROJECT _ reg loc 0 = JSNoop
661jsPROJECT _ reg loc 1 =
662 JSAssign (jsLOC loc) (
663 JSIndex (
664 JSProj (translateReg reg) "args"
665 ) (
666 JSNum (JSInt 0)
667 )
668 )
669jsPROJECT _ reg loc ar =
670 JSApp (JSIdent "i$PROJECT") [ translateReg reg
671 , JSNum (JSInt loc)
672 , JSNum (JSInt ar)
673 ]
675jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
676jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
677 where
678 jsOP' :: JS
679 jsOP'
680 | LNoOp <- op = translateReg (last args)
682 | LWriteStr <- op,
683 (_:str:_) <- args = JSAssign (translateReg reg)
684 (JSApp (JSIdent "i$putStr") [translateReg str])
686 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
687 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
688 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
690 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
691 | (LPlus (ATInt ITBig)) <- op
692 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
693 | (LMinus (ATInt ITBig)) <- op
694 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
695 | (LTimes (ATInt ITBig)) <- op
696 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
697 | (LSDiv (ATInt ITBig)) <- op
698 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
699 | (LSRem (ATInt ITBig)) <- op
700 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
701 | (LEq (ATInt ITBig)) <- op
702 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
703 | (LSLt (ATInt ITBig)) <- op
704 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
705 | (LSLe (ATInt ITBig)) <- op
706 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
707 | (LSGt (ATInt ITBig)) <- op
708 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
709 | (LSGe (ATInt ITBig)) <- op
710 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
712 | (LPlus ATFloat) <- op
713 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
714 | (LMinus ATFloat) <- op
715 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
716 | (LTimes ATFloat) <- op
717 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
718 | (LSDiv ATFloat) <- op
719 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
720 | (LEq ATFloat) <- op
721 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
722 | (LSLt ATFloat) <- op
723 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
724 | (LSLe ATFloat) <- op
725 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
726 | (LSGt ATFloat) <- op
727 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
728 | (LSGe ATFloat) <- op
729 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
731 | (LPlus (ATInt ITChar)) <- op
732 , (lhs:rhs:_) <- args =
733 jsCall "i$fromCharCode" [
734 JSBinOp "+" (
735 jsCall "i$charCode" [translateReg lhs]
736 ) (
737 jsCall "i$charCode" [translateReg rhs]
738 )
739 ]
741 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
742 , (arg:_) <- args =
743 jsPackUBits8 (
744 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
745 )
747 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
748 , (arg:_) <- args =
749 jsPackUBits16 (
750 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
751 )
753 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
754 , (arg:_) <- args =
755 jsPackUBits32 (
756 jsMeth (jsMeth (translateReg arg) "and" [
757 jsBigInt (JSString $ show 0xFFFFFFFF)
758 ]) "intValue" []
759 )
761 | (LTrunc ITBig (ITFixed IT64)) <- op
762 , (arg:_) <- args =
763 jsMeth (translateReg arg) "and" [
764 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
765 ]
767 | (LLSHR (ITFixed IT8)) <- op
768 , (lhs:rhs:_) <- args =
769 jsPackUBits8 (
770 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
771 )
773 | (LLSHR (ITFixed IT16)) <- op
774 , (lhs:rhs:_) <- args =
775 jsPackUBits16 (
776 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
777 )
779 | (LLSHR (ITFixed IT32)) <- op
780 , (lhs:rhs:_) <- args =
781 jsPackUBits32 (
782 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
783 )
785 | (LLSHR (ITFixed IT64)) <- op
786 , (lhs:rhs:_) <- args =
787 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
789 | (LSHL (ITFixed IT8)) <- op
790 , (lhs:rhs:_) <- args =
791 jsPackUBits8 (
792 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
793 )
795 | (LSHL (ITFixed IT16)) <- op
796 , (lhs:rhs:_) <- args =
797 jsPackUBits16 (
798 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
799 )
801 | (LSHL (ITFixed IT32)) <- op
802 , (lhs:rhs:_) <- args =
803 jsPackUBits32 (
804 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
805 )
807 | (LSHL (ITFixed IT64)) <- op
808 , (lhs:rhs:_) <- args =
809 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
810 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
811 ]
813 | (LAnd (ITFixed IT8)) <- op
814 , (lhs:rhs:_) <- args =
815 jsPackUBits8 (
816 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
817 )
819 | (LAnd (ITFixed IT16)) <- op
820 , (lhs:rhs:_) <- args =
821 jsPackUBits16 (
822 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
823 )
825 | (LAnd (ITFixed IT32)) <- op
826 , (lhs:rhs:_) <- args =
827 jsPackUBits32 (
828 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
829 )
831 | (LAnd (ITFixed IT64)) <- op
832 , (lhs:rhs:_) <- args =
833 jsMeth (translateReg lhs) "and" [translateReg rhs]
835 | (LOr (ITFixed IT8)) <- op
836 , (lhs:rhs:_) <- args =
837 jsPackUBits8 (
838 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
839 )
841 | (LOr (ITFixed IT16)) <- op
842 , (lhs:rhs:_) <- args =
843 jsPackUBits16 (
844 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
845 )
847 | (LOr (ITFixed IT32)) <- op
848 , (lhs:rhs:_) <- args =
849 jsPackUBits32 (
850 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
851 )
853 | (LOr (ITFixed IT64)) <- op
854 , (lhs:rhs:_) <- args =
855 jsMeth (translateReg lhs) "or" [translateReg rhs]
857 | (LXOr (ITFixed IT8)) <- op
858 , (lhs:rhs:_) <- args =
859 jsPackUBits8 (
860 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
861 )
863 | (LXOr (ITFixed IT16)) <- op
864 , (lhs:rhs:_) <- args =
865 jsPackUBits16 (
866 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
867 )
869 | (LXOr (ITFixed IT32)) <- op
870 , (lhs:rhs:_) <- args =
871 jsPackUBits32 (
872 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
873 )
875 | (LXOr (ITFixed IT64)) <- op
876 , (lhs:rhs:_) <- args =
877 jsMeth (translateReg lhs) "xor" [translateReg rhs]
879 | (LPlus (ATInt (ITFixed IT8))) <- op
880 , (lhs:rhs:_) <- args =
881 jsPackUBits8 (
882 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
883 )
885 | (LPlus (ATInt (ITFixed IT16))) <- op
886 , (lhs:rhs:_) <- args =
887 jsPackUBits16 (
888 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
889 )
891 | (LPlus (ATInt (ITFixed IT32))) <- op
892 , (lhs:rhs:_) <- args =
893 jsPackUBits32 (
894 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
895 )
897 | (LPlus (ATInt (ITFixed IT64))) <- op
898 , (lhs:rhs:_) <- args =
899 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
900 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
901 ]
903 | (LMinus (ATInt (ITFixed IT8))) <- op
904 , (lhs:rhs:_) <- args =
905 jsPackUBits8 (
906 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
907 )
909 | (LMinus (ATInt (ITFixed IT16))) <- op
910 , (lhs:rhs:_) <- args =
911 jsPackUBits16 (
912 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
913 )
915 | (LMinus (ATInt (ITFixed IT32))) <- op
916 , (lhs:rhs:_) <- args =
917 jsPackUBits32 (
918 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
919 )
921 | (LMinus (ATInt (ITFixed IT64))) <- op
922 , (lhs:rhs:_) <- args =
923 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
924 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
925 ]
927 | (LTimes (ATInt (ITFixed IT8))) <- op
928 , (lhs:rhs:_) <- args =
929 jsPackUBits8 (
930 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
931 )
933 | (LTimes (ATInt (ITFixed IT16))) <- op
934 , (lhs:rhs:_) <- args =
935 jsPackUBits16 (
936 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
937 )
939 | (LTimes (ATInt (ITFixed IT32))) <- op
940 , (lhs:rhs:_) <- args =
941 jsPackUBits32 (
942 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
943 )
945 | (LTimes (ATInt (ITFixed IT64))) <- op
946 , (lhs:rhs:_) <- args =
947 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
948 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
949 ]
951 | (LEq (ATInt (ITFixed IT8))) <- op
952 , (lhs:rhs:_) <- args =
953 jsPackUBits8 (
954 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
955 )
957 | (LEq (ATInt (ITFixed IT16))) <- op
958 , (lhs:rhs:_) <- args =
959 jsPackUBits16 (
960 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
961 )
963 | (LEq (ATInt (ITFixed IT32))) <- op
964 , (lhs:rhs:_) <- args =
965 jsPackUBits32 (
966 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
967 )
969 | (LEq (ATInt (ITFixed IT64))) <- op
970 , (lhs:rhs:_) <- args =
971 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
972 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
973 ]
975 | (LLt (ITFixed IT8)) <- op
976 , (lhs:rhs:_) <- args =
977 jsPackUBits8 (
978 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
979 )
981 | (LLt (ITFixed IT16)) <- op
982 , (lhs:rhs:_) <- args =
983 jsPackUBits16 (
984 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
985 )
987 | (LLt (ITFixed IT32)) <- op
988 , (lhs:rhs:_) <- args =
989 jsPackUBits32 (
990 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
991 )
993 | (LLt (ITFixed IT64)) <- op
994 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
996 | (LLe (ITFixed IT8)) <- op
997 , (lhs:rhs:_) <- args =
998 jsPackUBits8 (
999 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1002 | (LLe (ITFixed IT16)) <- op
1003 , (lhs:rhs:_) <- args =
1004 jsPackUBits16 (
1005 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1008 | (LLe (ITFixed IT32)) <- op
1009 , (lhs:rhs:_) <- args =
1010 jsPackUBits32 (
1011 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1014 | (LLe (ITFixed IT64)) <- op
1015 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1017 | (LGt (ITFixed IT8)) <- op
1018 , (lhs:rhs:_) <- args =
1019 jsPackUBits8 (
1020 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1023 | (LGt (ITFixed IT16)) <- op
1024 , (lhs:rhs:_) <- args =
1025 jsPackUBits16 (
1026 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1028 | (LGt (ITFixed IT32)) <- op
1029 , (lhs:rhs:_) <- args =
1030 jsPackUBits32 (
1031 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1034 | (LGt (ITFixed IT64)) <- op
1035 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1037 | (LGe (ITFixed IT8)) <- op
1038 , (lhs:rhs:_) <- args =
1039 jsPackUBits8 (
1040 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1043 | (LGe (ITFixed IT16)) <- op
1044 , (lhs:rhs:_) <- args =
1045 jsPackUBits16 (
1046 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1048 | (LGe (ITFixed IT32)) <- op
1049 , (lhs:rhs:_) <- args =
1050 jsPackUBits32 (
1051 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1054 | (LGe (ITFixed IT64)) <- op
1055 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1057 | (LUDiv (ITFixed IT8)) <- op
1058 , (lhs:rhs:_) <- args =
1059 jsPackUBits8 (
1060 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1063 | (LUDiv (ITFixed IT16)) <- op
1064 , (lhs:rhs:_) <- args =
1065 jsPackUBits16 (
1066 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1069 | (LUDiv (ITFixed IT32)) <- op
1070 , (lhs:rhs:_) <- args =
1071 jsPackUBits32 (
1072 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1075 | (LUDiv (ITFixed IT64)) <- op
1076 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1078 | (LSDiv (ATInt (ITFixed IT8))) <- op
1079 , (lhs:rhs:_) <- args =
1080 jsPackSBits8 (
1081 JSBinOp "/" (
1082 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1083 ) (
1084 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1088 | (LSDiv (ATInt (ITFixed IT16))) <- op
1089 , (lhs:rhs:_) <- args =
1090 jsPackSBits16 (
1091 JSBinOp "/" (
1092 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1093 ) (
1094 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1098 | (LSDiv (ATInt (ITFixed IT32))) <- op
1099 , (lhs:rhs:_) <- args =
1100 jsPackSBits32 (
1101 JSBinOp "/" (
1102 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1103 ) (
1104 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1108 | (LSDiv (ATInt (ITFixed IT64))) <- op
1109 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1111 | (LSRem (ATInt (ITFixed IT8))) <- op
1112 , (lhs:rhs:_) <- args =
1113 jsPackSBits8 (
1114 JSBinOp "%" (
1115 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1116 ) (
1117 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1121 | (LSRem (ATInt (ITFixed IT16))) <- op
1122 , (lhs:rhs:_) <- args =
1123 jsPackSBits16 (
1124 JSBinOp "%" (
1125 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1126 ) (
1127 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1131 | (LSRem (ATInt (ITFixed IT32))) <- op
1132 , (lhs:rhs:_) <- args =
1133 jsPackSBits32 (
1134 JSBinOp "%" (
1135 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1136 ) (
1137 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1141 | (LSRem (ATInt (ITFixed IT64))) <- op
1142 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1144 | (LCompl (ITFixed IT8)) <- op
1145 , (arg:_) <- args =
1146 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1148 | (LCompl (ITFixed IT16)) <- op
1149 , (arg:_) <- args =
1150 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1152 | (LCompl (ITFixed IT32)) <- op
1153 , (arg:_) <- args =
1154 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1156 | (LCompl (ITFixed IT64)) <- op
1157 , (arg:_) <- args =
1158 invokeMeth arg "not" []
1160 | (LPlus _) <- op
1161 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1162 | (LMinus _) <- op
1163 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1164 | (LTimes _) <- op
1165 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1166 | (LSDiv _) <- op
1167 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1168 | (LSRem _) <- op
1169 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1170 | (LEq _) <- op
1171 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1172 | (LSLt _) <- op
1173 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1174 | (LSLe _) <- op
1175 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1176 | (LSGt _) <- op
1177 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1178 | (LSGe _) <- op
1179 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1180 | (LAnd _) <- op
1181 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1182 | (LOr _) <- op
1183 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1184 | (LXOr _) <- op
1185 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1186 | (LSHL _) <- op
1187 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1188 | (LASHR _) <- op
1189 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1190 | (LCompl _) <- op
1191 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1193 | LStrConcat <- op
1194 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1195 | LStrEq <- op
1196 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1197 | LStrLt <- op
1198 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1199 | LStrLen <- op
1200 , (arg:_) <- args = JSProj (translateReg arg) "length"
1201 | (LStrInt ITNative) <- op
1202 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1203 | (LIntStr ITNative) <- op
1204 , (arg:_) <- args = jsCall "String" [translateReg arg]
1205 | (LSExt ITNative ITBig) <- op
1206 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1207 | (LTrunc ITBig ITNative) <- op
1208 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1209 | (LIntStr ITBig) <- op
1210 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1211 | (LStrInt ITBig) <- op
1212 , (arg:_) <- args = jsBigInt $ translateReg arg
1213 | LFloatStr <- op
1214 , (arg:_) <- args = jsCall "String" [translateReg arg]
1215 | LStrFloat <- op
1216 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1217 | (LIntFloat ITNative) <- op
1218 , (arg:_) <- args = translateReg arg
1219 | (LIntFloat ITBig) <- op
1220 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1221 | (LFloatInt ITNative) <- op
1222 , (arg:_) <- args = translateReg arg
1223 | (LChInt ITNative) <- op
1224 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1225 | (LIntCh ITNative) <- op
1226 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1228 | LFExp <- op
1229 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1230 | LFLog <- op
1231 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1232 | LFSin <- op
1233 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1234 | LFCos <- op
1235 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1236 | LFTan <- op
1237 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1238 | LFASin <- op
1239 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1240 | LFACos <- op
1241 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1242 | LFATan <- op
1243 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1244 | LFSqrt <- op
1245 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1246 | LFFloor <- op
1247 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1248 | LFCeil <- op
1249 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1250 | LFNegate <- op
1251 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1253 | LStrCons <- op
1254 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1255 | LStrHead <- op
1256 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1257 | LStrRev <- op
1258 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1259 | LStrIndex <- op
1260 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1261 | LStrTail <- op
1262 , (arg:_) <- args =
1263 let v = translateReg arg in
1264 JSApp (JSProj v "substr") [
1265 JSNum (JSInt 1),
1266 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1269 | LSystemInfo <- op
1270 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1271 | LExternal nul <- op
1272 , nul == sUN "prim__null"
1273 , (_) <- args = JSNull
1274 | otherwise = JSError $ "Not implemented: " ++ show op
1275 where
1276 translateBinaryOp :: String -> Reg -> Reg -> JS
1277 translateBinaryOp op lhs rhs =
1278 JSBinOp op (translateReg lhs) (translateReg rhs)
1280 invokeMeth :: Reg -> String -> [Reg] -> JS
1281 invokeMeth obj meth args =
1282 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1285jsRESERVE :: CompileInfo -> Int -> JS
1286jsRESERVE _ _ = JSNoop
1288jsSTACK :: JS
1289jsSTACK = JSIdent "i$valstack"
1291jsCALLSTACK :: JS
1292jsCALLSTACK = JSIdent "i$callstack"
1294jsSTACKBASE :: JS
1295jsSTACKBASE = JSIdent "i$valstack_base"
1297jsSTACKTOP :: JS
1298jsSTACKTOP = JSIdent "i$valstack_top"
1300jsOLDBASE :: JS
1301jsOLDBASE = JSIdent "oldbase"
1303jsMYOLDBASE :: JS
1304jsMYOLDBASE = JSIdent "myoldbase"
1306jsRET :: JS
1307jsRET = JSIdent "i$ret"
1309jsLOC :: Int -> JS
1310jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1311jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1313jsTOP :: Int -> JS
1314jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1315jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1317jsPUSH :: [JS] -> JS
1318jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1320jsPOP :: JS
1321jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1323translateBC :: CompileInfo -> BC -> JS
1324translateBC info bc
1325 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1326 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1327 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1328 | ADDTOP n <- bc = jsADDTOP info n
1329 | NULL r <- bc = jsNULL info r
1330 | CALL n <- bc = jsCALL info n
1331 | TAILCALL n <- bc = jsTAILCALL info n
1332 | FOREIGNCALL r _ (FStr n) args
1333 <- bc = jsFOREIGN info r n (map fcall args)
1334 | TOPBASE n <- bc = jsTOPBASE info n
1335 | BASETOP n <- bc = jsBASETOP info n
1336 | STOREOLD <- bc = jsSTOREOLD info
1337 | SLIDE n <- bc = jsSLIDE info n
1338 | REBASE <- bc = jsREBASE info
1339 | RESERVE n <- bc = jsRESERVE info n
1340 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1341 | CASE s r c d <- bc = jsCASE info s r c d
1342 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1343 | PROJECT r l a <- bc = jsPROJECT info r l a
1344 | OP r o a <- bc = jsOP info r o a
1345 | ERROR e <- bc = jsERROR info e
1346 | otherwise = JSRaw $ "//" ++ show bc
1347 where fcall (t, arg) = (toFType t, arg)
1349toAType (FCon i)
1350 | i == sUN "JS_IntChar" = ATInt ITChar
1351 | i == sUN "JS_IntNative" = ATInt ITNative
1352toAType t = error (show t ++ " not defined in toAType")
1354toFnType (FApp c [_,_,s,t])
1355 | c == sUN "JS_Fn" = toFnType t
1356toFnType (FApp c [_,_,r])
1357 | c == sUN "JS_FnIO" = FFunctionIO
1358toFnType (FApp c [_,r])
1359 | c == sUN "JS_FnBase" = FFunction
1360toFnType t = error (show t ++ " not defined in toFnType")
1362toFType (FCon c)
1363 | c == sUN "JS_Str" = FString
1364 | c == sUN "JS_Float" = FArith ATFloat
1365 | c == sUN "JS_Ptr" = FPtr
1366 | c == sUN "JS_Unit" = FUnit
1367toFType (FApp c [_,ity])
1368 | c == sUN "JS_IntT" = FArith (toAType ity)
1369toFType (FApp c [_,fty])
1370 | c == sUN "JS_FnT" = toFnType fty
1371toFType t = error (show t ++ " not yet defined in toFType")