git.iko.soy/Idris-dev
on 85cf83f help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1349 lines 49 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.CodegenCommon
12import Idris.Core.TT
13import IRTS.System
14import Util.System
16import Control.Arrow
17import Control.Monad (mapM)
18import Control.Applicative ((<$>), (<*>), pure)
19import Control.Monad.RWS hiding (mapM)
20import Control.Monad.State
21import Data.Char
22import Numeric
23import Data.List
24import Data.Maybe
25import Data.Word
26import Data.Traversable hiding (mapM)
27import System.IO
28import System.Directory
30import qualified Data.Map.Strict as M
31import qualified Data.Text as T
32import qualified Data.Text.IO as TIO
35data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
36 , compileInfoEvalCases :: [Int]
37 , compileInfoNeedsBigInt :: Bool
38 }
41initCompileInfo :: [(Name, [BC])] -> CompileInfo
42initCompileInfo bc =
43 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
44 where
45 lookupBigInt :: [(Name, [BC])] -> Bool
46 lookupBigInt = any (needsBigInt . snd)
47 where
48 needsBigInt :: [BC] -> Bool
49 needsBigInt bc = or $ map testBCForBigInt bc
50 where
51 testBCForBigInt :: BC -> Bool
52 testBCForBigInt (ASSIGNCONST _ c) =
53 testConstForBigInt c
55 testBCForBigInt (CONSTCASE _ c d) =
56 maybe False needsBigInt d
57 || (or $ map (needsBigInt . snd) c)
58 || (or $ map (testConstForBigInt . fst) c)
60 testBCForBigInt (CASE _ _ c d) =
61 maybe False needsBigInt d
62 || (or $ map (needsBigInt . snd) c)
64 testBCForBigInt _ = False
66 testConstForBigInt :: Const -> Bool
67 testConstForBigInt (BI _) = True
68 testConstForBigInt (B64 _) = True
69 testConstForBigInt _ = False
72 collectCases :: String -> [(Name, [BC])] -> [Int]
73 collectCases fun bc = getCases $ findFunction fun bc
75 findFunction :: String -> [(Name, [BC])] -> [BC]
76 findFunction f ((MN 0 fun, bc):_)
77 | fun == txt f = bc
78 findFunction f (_:bc) = findFunction f bc
80 getCases :: [BC] -> [Int]
81 getCases = concatMap analyze
82 where
83 analyze :: BC -> [Int]
84 analyze (CASE _ _ b _) = map fst b
85 analyze _ = []
88data JSTarget = Node | JavaScript deriving Eq
91codegenJavaScript :: CodeGenerator
92codegenJavaScript ci =
93 codegenJS_all JavaScript (simpleDecls ci)
94 (includes ci) [] (outputFile ci) (outputType ci)
96codegenNode :: CodeGenerator
97codegenNode ci =
98 codegenJS_all Node (simpleDecls ci)
99 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
101codegenJS_all
102 :: JSTarget
103 -> [(Name, SDecl)]
104 -> [FilePath]
105 -> [String]
106 -> FilePath
107 -> OutputType
108 -> IO ()
109codegenJS_all target definitions includes libs filename outputType = do
110 let bytecode = map toBC definitions
111 let info = initCompileInfo bytecode
112 let js = concatMap (translateDecl info) bytecode
113 let full = concatMap processFunction js
114 let code = deadCodeElim full
115 let (cons, opt) = optimizeConstructors code
116 let (header, rt) = case target of
117 Node -> ("#!/usr/bin/env node\n", "-node")
118 JavaScript -> ("", "-browser")
120 included <- concat <$> getIncludes includes
121 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
122 idrRuntime <- readFile $ path ++ "Runtime-common.js"
123 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
124 jsbn <- if compileInfoNeedsBigInt info
125 then readFile $ path ++ "jsbn/jsbn.js"
126 else return ""
127 let runtime = ( header
128 ++ includeLibs libs
129 ++ included
130 ++ jsbn
131 ++ idrRuntime
132 ++ tgtRuntime
133 )
134 TIO.writeFile filename ( T.pack runtime
135 `T.append` T.concat (map compileJS opt)
136 `T.append` T.concat (map compileJS cons)
137 `T.append` main
138 `T.append` invokeMain
139 )
140 setPermissions filename (emptyPermissions { readable = True
141 , executable = target == Node
142 , writable = True
143 })
144 where
145 deadCodeElim :: [JS] -> [JS]
146 deadCodeElim js = concatMap collectFunctions js
147 where
148 collectFunctions :: JS -> [JS]
149 collectFunctions fun@(JSAlloc name _)
150 | name == translateName (sMN 0 "runMain") = [fun]
152 collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =
153 let invokations = sum $ map (
154 \x -> execState (countInvokations name x) 0
155 ) js
156 in if invokations == 0
157 then []
158 else [fun]
160 countInvokations :: String -> JS -> State Int ()
161 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
162 countInvokations name body
164 countInvokations name (JSSeq seq) =
165 void $ traverse (countInvokations name) seq
167 countInvokations name (JSAssign _ rhs) =
168 countInvokations name rhs
170 countInvokations name (JSCond conds) =
171 void $ traverse (
172 runKleisli $ arr id *** Kleisli (countInvokations name)
173 ) conds
175 countInvokations name (JSSwitch _ conds def) =
176 void $ traverse (
177 runKleisli $ arr id *** Kleisli (countInvokations name)
178 ) conds >> traverse (countInvokations name) def
180 countInvokations name (JSApp lhs rhs) =
181 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
183 countInvokations name (JSNew _ args) =
184 void $ traverse (countInvokations name) args
186 countInvokations name (JSArray args) =
187 void $ traverse (countInvokations name) args
189 countInvokations name (JSIdent name')
190 | name == name' = get >>= put . (+1)
191 | otherwise = return ()
193 countInvokations _ _ = return ()
195 processFunction :: JS -> [JS]
196 processFunction =
197 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
199 includeLibs :: [String] -> String
200 includeLibs =
201 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
203 getIncludes :: [FilePath] -> IO [String]
204 getIncludes = mapM readFile
206 main :: T.Text
207 main =
208 compileJS $ JSAlloc "main" (Just $
209 JSFunction [] (
210 case target of
211 Node -> mainFun
212 JavaScript -> jsMain
213 )
214 )
216 jsMain :: JS
217 jsMain =
218 JSCond [ (exists document `jsAnd` isReady, mainFun)
219 , (exists window, windowMainFun)
220 , (JSTrue, mainFun)
221 ]
222 where
223 exists :: JS -> JS
224 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
226 window :: JS
227 window = JSIdent "window"
229 document :: JS
230 document = JSIdent "document"
232 windowMainFun :: JS
233 windowMainFun =
234 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
235 , JSFunction [] ( mainFun )
236 , JSFalse
237 ]
239 isReady :: JS
240 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
242 readyState :: JS
243 readyState = JSProj (JSIdent "document") "readyState"
245 mainFun :: JS
246 mainFun =
247 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
248 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
249 , JSApp (
250 JSIdent (translateName (sMN 0 "runMain"))
251 ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
252 , JSWhile (JSProj jsCALLSTACK "length") (
253 JSSeq [ JSAlloc "func" (Just jsPOP)
254 , JSAlloc "args" (Just jsPOP)
255 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
256 ]
257 )
258 ]
260 invokeMain :: T.Text
261 invokeMain = compileJS $ JSApp (JSIdent "main") []
263optimizeConstructors :: [JS] -> ([JS], [JS])
264optimizeConstructors js =
265 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
266 (map (allocCon . snd) (M.toList cons), js')
267 where
268 allocCon :: (String, JS) -> JS
269 allocCon (name, con) = JSAlloc name (Just con)
271 newConstructor :: Int -> String
272 newConstructor n = "i$CON$" ++ show n
274 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
275 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
276 , JSArray []
277 , a
278 , e
279 ]) = do
280 s <- get
281 case M.lookup tag s of
282 Just (i, c) -> return $ JSIdent i
283 Nothing -> do let n = newConstructor tag
284 put $ M.insert tag (n, js) s
285 return $ JSIdent n
287 optimizeConstructor' (JSSeq seq) =
288 JSSeq <$> traverse optimizeConstructor' seq
290 optimizeConstructor' (JSSwitch reg cond def) = do
291 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
292 def' <- traverse optimizeConstructor' def
293 return $ JSSwitch reg cond' def'
295 optimizeConstructor' (JSCond cond) =
296 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
298 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
299 body' <- optimizeConstructor' body
300 return $ JSAlloc fun (Just (JSFunction args body'))
302 optimizeConstructor' (JSAssign lhs rhs) = do
303 lhs' <- optimizeConstructor' lhs
304 rhs' <- optimizeConstructor' rhs
305 return $ JSAssign lhs' rhs'
307 optimizeConstructor' js = return js
309collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
310collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
311 where
312 generateSplitFunction :: (Int,JS) -> JS
313 generateSplitFunction (depth, JSAlloc name fun) =
314 JSAlloc (name ++ "$" ++ show depth) fun
316splitFunction :: JS -> RWS () [(Int,JS)] Int JS
317splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
318 body' <- splitSequence body
319 return $ JSAlloc name (Just (JSFunction args body'))
320 where
321 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
322 splitCondition js
323 | JSCond branches <- js =
324 JSCond <$> processBranches branches
325 | JSSwitch cond branches def <- js =
326 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
327 | otherwise = return js
328 where
329 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
330 processBranches =
331 traverse (runKleisli (arr id *** Kleisli splitSequence))
333 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
334 splitSequence js@(JSSeq seq) =
335 let (pre,post) = break isBranch seq in
336 case post of
337 [_] -> JSSeq <$> traverse splitCondition seq
338 [call@(JSCond _),rest@(JSApp _ _)] -> do
339 rest' <- splitCondition rest
340 call' <- splitCondition call
341 return $ JSSeq (pre ++ [rest', call'])
342 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
343 rest' <- splitCondition rest
344 call' <- splitCondition call
345 return $ JSSeq (pre ++ [rest', call'])
346 (call:rest) -> do
347 depth <- get
348 put (depth + 1)
349 new <- splitFunction (newFun rest)
350 tell [(depth, new)]
351 call' <- splitCondition call
352 return $ JSSeq (pre ++ (newCall depth : [call']))
353 _ -> JSSeq <$> traverse splitCondition seq
355 splitSequence js = return js
357 isBranch :: JS -> Bool
358 isBranch (JSApp (JSIdent "i$CALL") _) = True
359 isBranch (JSCond _) = True
360 isBranch (JSSwitch _ _ _) = True
361 isBranch _ = False
363 newCall :: Int -> JS
364 newCall depth =
365 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
366 , JSArray [jsOLDBASE, jsMYOLDBASE]
367 ]
369 newFun :: [JS] -> JS
370 newFun seq =
371 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
373splitFunction js = return js
375translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
376translateDecl info (name@(MN 0 fun), bc)
377 | txt "APPLY" == fun =
378 allocCaseFunctions (snd body)
379 ++ [ JSAlloc (
380 translateName name
381 ) (Just $ JSFunction ["oldbase"] (
382 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
383 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
384 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
385 )
386 , ( JSNoop
387 , JSSeq $ map (translateBC info) (defaultCase (snd body))
388 )
389 ]
390 ]
391 )
392 )
393 ]
395 | txt "EVAL" == fun =
396 allocCaseFunctions (snd body)
397 ++ [ JSAlloc (
398 translateName name
399 ) (Just $ JSFunction ["oldbase"] (
400 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
401 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
402 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
403 )
404 , ( JSNoop
405 , JSSeq $ map (translateBC info) (defaultCase (snd body))
406 )
407 ]
408 ]
409 )
410 )
411 ]
412 where
413 body :: ([BC], [BC])
414 body = break isCase bc
416 isCase :: BC -> Bool
417 isCase bc
418 | CASE {} <- bc = True
419 | otherwise = False
421 defaultCase :: [BC] -> [BC]
422 defaultCase ((CASE _ _ _ (Just d)):_) = d
424 caseReg :: [BC] -> Reg
425 caseReg ((CASE _ r _ _):_) = r
427 allocCaseFunctions :: [BC] -> [JS]
428 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
429 allocCaseFunctions _ = []
431 splitBranches :: [(Int, [BC])] -> [JS]
432 splitBranches = map prepBranch
434 prepBranch :: (Int, [BC]) -> JS
435 prepBranch (tag, code) =
436 JSAlloc (
437 translateName name ++ "$" ++ show tag
438 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
439 JSSeq $ map (translateBC info) code
440 )
441 )
443translateDecl info (name, bc) =
444 [ JSAlloc (
445 translateName name
446 ) (Just $ JSFunction ["oldbase"] (
447 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
448 )
449 )
450 ]
452jsFUNPRELUDE :: [JS]
453jsFUNPRELUDE = [jsALLOCMYOLDBASE]
455jsALLOCMYOLDBASE :: JS
456jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
458translateReg :: Reg -> JS
459translateReg reg
460 | RVal <- reg = jsRET
461 | Tmp <- reg = JSRaw "//TMPREG"
462 | L n <- reg = jsLOC n
463 | T n <- reg = jsTOP n
465translateConstant :: Const -> JS
466translateConstant (I i) = JSNum (JSInt i)
467translateConstant (Fl f) = JSNum (JSFloat f)
468translateConstant (Ch c) = JSString $ translateChar c
469translateConstant (Str s) = JSString $ concatMap translateChar s
470translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
471translateConstant StrType = JSType JSStringTy
472translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
473translateConstant (AType ATFloat) = JSType JSFloatTy
474translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
475translateConstant PtrType = JSType JSPtrTy
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 == "putStr"
545 , [(FString, arg)] <- args =
546 JSAssign (
547 translateReg reg
548 ) (
549 JSApp (JSIdent "i$putStr") [translateReg arg]
550 )
552 | n == "isNull"
553 , [(FPtr, arg)] <- args =
554 JSAssign (
555 translateReg reg
556 ) (
557 JSBinOp "==" (translateReg arg) JSNull
558 )
560 | n == "idris_eqPtr"
561 , [(_, lhs),(_, rhs)] <- args =
562 JSAssign (
563 translateReg reg
564 ) (
565 JSBinOp "==" (translateReg lhs) (translateReg rhs)
566 )
567 | otherwise =
568 JSAssign (
569 translateReg reg
570 ) (
571 JSFFI n (map generateWrapper args)
572 )
573 where
574 generateWrapper :: (FType, Reg) -> JS
575 generateWrapper (ty, reg)
576 | FFunction <- ty =
577 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
578 , JSIdent "oldbase"
579 , JSIdent "myoldbase"
580 ]
581 | FFunctionIO <- ty =
582 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
583 , JSIdent "oldbase"
584 , JSIdent "myoldbase"
585 ]
587 generateWrapper (_, reg) =
588 translateReg reg
590jsREBASE :: CompileInfo -> JS
591jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
593jsSTOREOLD :: CompileInfo ->JS
594jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
596jsADDTOP :: CompileInfo -> Int -> JS
597jsADDTOP info n
598 | 0 <- n = JSNoop
599 | otherwise =
600 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
602jsTOPBASE :: CompileInfo -> Int -> JS
603jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
604jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
607jsBASETOP :: CompileInfo -> Int -> JS
608jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
609jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
611jsNULL :: CompileInfo -> Reg -> JS
612jsNULL _ r = JSAssign (translateReg r) JSNull
614jsERROR :: CompileInfo -> String -> JS
615jsERROR _ = JSError
617jsSLIDE :: CompileInfo -> Int -> JS
618jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
619jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
621jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
622jsMKCON info r t rs =
623 JSAssign (translateReg r) (
624 JSNew "i$CON" [ JSNum (JSInt t)
625 , JSArray (map translateReg rs)
626 , if t `elem` compileInfoApplyCases info
627 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
628 else JSNull
629 , if t `elem` compileInfoEvalCases info
630 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
631 else JSNull
632 ]
633 )
635jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
636jsCASE info safe reg cases def =
637 JSSwitch (tag safe $ translateReg reg) (
638 map ((JSNum . JSInt) *** prepBranch) cases
639 ) (fmap prepBranch def)
640 where
641 tag :: Bool -> JS -> JS
642 tag True = jsCTAG
643 tag False = jsTAG
645 prepBranch :: [BC] -> JS
646 prepBranch bc = JSSeq $ map (translateBC info) bc
648 jsTAG :: JS -> JS
649 jsTAG js =
650 (JSTernary (js `jsInstanceOf` "i$CON") (
651 JSProj js "tag"
652 ) (JSNum (JSInt $ negate 1)))
654 jsCTAG :: JS -> JS
655 jsCTAG js = JSProj js "tag"
658jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
659jsCONSTCASE info reg cases def =
660 JSCond $ (
661 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
662 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
663 where
664 prepBranch :: [BC] -> JS
665 prepBranch bc = JSSeq $ map (translateBC info) bc
667jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
668jsPROJECT _ reg loc 0 = JSNoop
669jsPROJECT _ reg loc 1 =
670 JSAssign (jsLOC loc) (
671 JSIndex (
672 JSProj (translateReg reg) "args"
673 ) (
674 JSNum (JSInt 0)
675 )
676 )
677jsPROJECT _ reg loc ar =
678 JSApp (JSIdent "i$PROJECT") [ translateReg reg
679 , JSNum (JSInt loc)
680 , JSNum (JSInt ar)
681 ]
683jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
684jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
685 where
686 jsOP' :: JS
687 jsOP'
688 | LNoOp <- op = translateReg (last args)
690 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
691 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
692 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
694 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
695 | (LPlus (ATInt ITBig)) <- op
696 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
697 | (LMinus (ATInt ITBig)) <- op
698 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
699 | (LTimes (ATInt ITBig)) <- op
700 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
701 | (LSDiv (ATInt ITBig)) <- op
702 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
703 | (LSRem (ATInt ITBig)) <- op
704 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
705 | (LEq (ATInt ITBig)) <- op
706 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
707 | (LSLt (ATInt ITBig)) <- op
708 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
709 | (LSLe (ATInt ITBig)) <- op
710 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
711 | (LSGt (ATInt ITBig)) <- op
712 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
713 | (LSGe (ATInt ITBig)) <- op
714 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
716 | (LPlus ATFloat) <- op
717 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
718 | (LMinus ATFloat) <- op
719 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
720 | (LTimes ATFloat) <- op
721 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
722 | (LSDiv ATFloat) <- op
723 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
724 | (LEq ATFloat) <- op
725 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
726 | (LSLt ATFloat) <- op
727 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
728 | (LSLe ATFloat) <- op
729 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
730 | (LSGt ATFloat) <- op
731 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
732 | (LSGe ATFloat) <- op
733 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
735 | (LPlus (ATInt ITChar)) <- op
736 , (lhs:rhs:_) <- args =
737 jsCall "i$fromCharCode" [
738 JSBinOp "+" (
739 jsCall "i$charCode" [translateReg lhs]
740 ) (
741 jsCall "i$charCode" [translateReg rhs]
742 )
743 ]
745 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
746 , (arg:_) <- args =
747 jsPackUBits8 (
748 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
749 )
751 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
752 , (arg:_) <- args =
753 jsPackUBits16 (
754 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
755 )
757 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
758 , (arg:_) <- args =
759 jsPackUBits32 (
760 jsMeth (jsMeth (translateReg arg) "and" [
761 jsBigInt (JSString $ show 0xFFFFFFFF)
762 ]) "intValue" []
763 )
765 | (LTrunc ITBig (ITFixed IT64)) <- op
766 , (arg:_) <- args =
767 jsMeth (translateReg arg) "and" [
768 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
769 ]
771 | (LLSHR (ITFixed IT8)) <- op
772 , (lhs:rhs:_) <- args =
773 jsPackUBits8 (
774 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
775 )
777 | (LLSHR (ITFixed IT16)) <- op
778 , (lhs:rhs:_) <- args =
779 jsPackUBits16 (
780 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
781 )
783 | (LLSHR (ITFixed IT32)) <- op
784 , (lhs:rhs:_) <- args =
785 jsPackUBits32 (
786 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
787 )
789 | (LLSHR (ITFixed IT64)) <- op
790 , (lhs:rhs:_) <- args =
791 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
793 | (LSHL (ITFixed IT8)) <- op
794 , (lhs:rhs:_) <- args =
795 jsPackUBits8 (
796 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
797 )
799 | (LSHL (ITFixed IT16)) <- op
800 , (lhs:rhs:_) <- args =
801 jsPackUBits16 (
802 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
803 )
805 | (LSHL (ITFixed IT32)) <- op
806 , (lhs:rhs:_) <- args =
807 jsPackUBits32 (
808 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
809 )
811 | (LSHL (ITFixed IT64)) <- op
812 , (lhs:rhs:_) <- args =
813 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
814 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
815 ]
817 | (LAnd (ITFixed IT8)) <- op
818 , (lhs:rhs:_) <- args =
819 jsPackUBits8 (
820 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
821 )
823 | (LAnd (ITFixed IT16)) <- op
824 , (lhs:rhs:_) <- args =
825 jsPackUBits16 (
826 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
827 )
829 | (LAnd (ITFixed IT32)) <- op
830 , (lhs:rhs:_) <- args =
831 jsPackUBits32 (
832 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
833 )
835 | (LAnd (ITFixed IT64)) <- op
836 , (lhs:rhs:_) <- args =
837 jsMeth (translateReg lhs) "and" [translateReg rhs]
839 | (LOr (ITFixed IT8)) <- op
840 , (lhs:rhs:_) <- args =
841 jsPackUBits8 (
842 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
843 )
845 | (LOr (ITFixed IT16)) <- op
846 , (lhs:rhs:_) <- args =
847 jsPackUBits16 (
848 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
849 )
851 | (LOr (ITFixed IT32)) <- op
852 , (lhs:rhs:_) <- args =
853 jsPackUBits32 (
854 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
855 )
857 | (LOr (ITFixed IT64)) <- op
858 , (lhs:rhs:_) <- args =
859 jsMeth (translateReg lhs) "or" [translateReg rhs]
861 | (LXOr (ITFixed IT8)) <- op
862 , (lhs:rhs:_) <- args =
863 jsPackUBits8 (
864 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
865 )
867 | (LXOr (ITFixed IT16)) <- op
868 , (lhs:rhs:_) <- args =
869 jsPackUBits16 (
870 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
871 )
873 | (LXOr (ITFixed IT32)) <- op
874 , (lhs:rhs:_) <- args =
875 jsPackUBits32 (
876 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
877 )
879 | (LXOr (ITFixed IT64)) <- op
880 , (lhs:rhs:_) <- args =
881 jsMeth (translateReg lhs) "xor" [translateReg rhs]
883 | (LPlus (ATInt (ITFixed IT8))) <- op
884 , (lhs:rhs:_) <- args =
885 jsPackUBits8 (
886 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
887 )
889 | (LPlus (ATInt (ITFixed IT16))) <- op
890 , (lhs:rhs:_) <- args =
891 jsPackUBits16 (
892 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
893 )
895 | (LPlus (ATInt (ITFixed IT32))) <- op
896 , (lhs:rhs:_) <- args =
897 jsPackUBits32 (
898 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
899 )
901 | (LPlus (ATInt (ITFixed IT64))) <- op
902 , (lhs:rhs:_) <- args =
903 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
904 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
905 ]
907 | (LMinus (ATInt (ITFixed IT8))) <- op
908 , (lhs:rhs:_) <- args =
909 jsPackUBits8 (
910 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
911 )
913 | (LMinus (ATInt (ITFixed IT16))) <- op
914 , (lhs:rhs:_) <- args =
915 jsPackUBits16 (
916 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
917 )
919 | (LMinus (ATInt (ITFixed IT32))) <- op
920 , (lhs:rhs:_) <- args =
921 jsPackUBits32 (
922 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
923 )
925 | (LMinus (ATInt (ITFixed IT64))) <- op
926 , (lhs:rhs:_) <- args =
927 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
928 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
929 ]
931 | (LTimes (ATInt (ITFixed IT8))) <- op
932 , (lhs:rhs:_) <- args =
933 jsPackUBits8 (
934 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
935 )
937 | (LTimes (ATInt (ITFixed IT16))) <- op
938 , (lhs:rhs:_) <- args =
939 jsPackUBits16 (
940 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
941 )
943 | (LTimes (ATInt (ITFixed IT32))) <- op
944 , (lhs:rhs:_) <- args =
945 jsPackUBits32 (
946 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
947 )
949 | (LTimes (ATInt (ITFixed IT64))) <- op
950 , (lhs:rhs:_) <- args =
951 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
952 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
953 ]
955 | (LEq (ATInt (ITFixed IT8))) <- op
956 , (lhs:rhs:_) <- args =
957 jsPackUBits8 (
958 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
959 )
961 | (LEq (ATInt (ITFixed IT16))) <- op
962 , (lhs:rhs:_) <- args =
963 jsPackUBits16 (
964 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
965 )
967 | (LEq (ATInt (ITFixed IT32))) <- op
968 , (lhs:rhs:_) <- args =
969 jsPackUBits32 (
970 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
971 )
973 | (LEq (ATInt (ITFixed IT64))) <- op
974 , (lhs:rhs:_) <- args =
975 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
976 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
977 ]
979 | (LLt (ITFixed IT8)) <- op
980 , (lhs:rhs:_) <- args =
981 jsPackUBits8 (
982 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
983 )
985 | (LLt (ITFixed IT16)) <- op
986 , (lhs:rhs:_) <- args =
987 jsPackUBits16 (
988 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
989 )
991 | (LLt (ITFixed IT32)) <- op
992 , (lhs:rhs:_) <- args =
993 jsPackUBits32 (
994 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
995 )
997 | (LLt (ITFixed IT64)) <- op
998 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1000 | (LLe (ITFixed IT8)) <- op
1001 , (lhs:rhs:_) <- args =
1002 jsPackUBits8 (
1003 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1006 | (LLe (ITFixed IT16)) <- op
1007 , (lhs:rhs:_) <- args =
1008 jsPackUBits16 (
1009 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1012 | (LLe (ITFixed IT32)) <- op
1013 , (lhs:rhs:_) <- args =
1014 jsPackUBits32 (
1015 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1018 | (LLe (ITFixed IT64)) <- op
1019 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1021 | (LGt (ITFixed IT8)) <- op
1022 , (lhs:rhs:_) <- args =
1023 jsPackUBits8 (
1024 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1027 | (LGt (ITFixed IT16)) <- op
1028 , (lhs:rhs:_) <- args =
1029 jsPackUBits16 (
1030 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1032 | (LGt (ITFixed IT32)) <- op
1033 , (lhs:rhs:_) <- args =
1034 jsPackUBits32 (
1035 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1038 | (LGt (ITFixed IT64)) <- op
1039 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1041 | (LGe (ITFixed IT8)) <- op
1042 , (lhs:rhs:_) <- args =
1043 jsPackUBits8 (
1044 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1047 | (LGe (ITFixed IT16)) <- op
1048 , (lhs:rhs:_) <- args =
1049 jsPackUBits16 (
1050 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1052 | (LGe (ITFixed IT32)) <- op
1053 , (lhs:rhs:_) <- args =
1054 jsPackUBits32 (
1055 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1058 | (LGe (ITFixed IT64)) <- op
1059 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1061 | (LUDiv (ITFixed IT8)) <- op
1062 , (lhs:rhs:_) <- args =
1063 jsPackUBits8 (
1064 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1067 | (LUDiv (ITFixed IT16)) <- op
1068 , (lhs:rhs:_) <- args =
1069 jsPackUBits16 (
1070 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1073 | (LUDiv (ITFixed IT32)) <- op
1074 , (lhs:rhs:_) <- args =
1075 jsPackUBits32 (
1076 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1079 | (LUDiv (ITFixed IT64)) <- op
1080 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1082 | (LSDiv (ATInt (ITFixed IT8))) <- op
1083 , (lhs:rhs:_) <- args =
1084 jsPackSBits8 (
1085 JSBinOp "/" (
1086 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1087 ) (
1088 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1092 | (LSDiv (ATInt (ITFixed IT16))) <- op
1093 , (lhs:rhs:_) <- args =
1094 jsPackSBits16 (
1095 JSBinOp "/" (
1096 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1097 ) (
1098 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1102 | (LSDiv (ATInt (ITFixed IT32))) <- op
1103 , (lhs:rhs:_) <- args =
1104 jsPackSBits32 (
1105 JSBinOp "/" (
1106 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1107 ) (
1108 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1112 | (LSDiv (ATInt (ITFixed IT64))) <- op
1113 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1115 | (LSRem (ATInt (ITFixed IT8))) <- op
1116 , (lhs:rhs:_) <- args =
1117 jsPackSBits8 (
1118 JSBinOp "%" (
1119 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1120 ) (
1121 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1125 | (LSRem (ATInt (ITFixed IT16))) <- op
1126 , (lhs:rhs:_) <- args =
1127 jsPackSBits16 (
1128 JSBinOp "%" (
1129 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1130 ) (
1131 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1135 | (LSRem (ATInt (ITFixed IT32))) <- op
1136 , (lhs:rhs:_) <- args =
1137 jsPackSBits32 (
1138 JSBinOp "%" (
1139 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1140 ) (
1141 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1145 | (LSRem (ATInt (ITFixed IT64))) <- op
1146 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1148 | (LCompl (ITFixed IT8)) <- op
1149 , (arg:_) <- args =
1150 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1152 | (LCompl (ITFixed IT16)) <- op
1153 , (arg:_) <- args =
1154 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1156 | (LCompl (ITFixed IT32)) <- op
1157 , (arg:_) <- args =
1158 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1160 | (LCompl (ITFixed IT64)) <- op
1161 , (arg:_) <- args =
1162 invokeMeth arg "not" []
1164 | (LPlus _) <- op
1165 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1166 | (LMinus _) <- op
1167 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1168 | (LTimes _) <- op
1169 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1170 | (LSDiv _) <- op
1171 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1172 | (LSRem _) <- op
1173 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1174 | (LEq _) <- op
1175 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1176 | (LSLt _) <- op
1177 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1178 | (LSLe _) <- op
1179 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1180 | (LSGt _) <- op
1181 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1182 | (LSGe _) <- op
1183 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1184 | (LAnd _) <- op
1185 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1186 | (LOr _) <- op
1187 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1188 | (LXOr _) <- op
1189 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1190 | (LSHL _) <- op
1191 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1192 | (LASHR _) <- op
1193 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1194 | (LCompl _) <- op
1195 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1197 | LStrConcat <- op
1198 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1199 | LStrEq <- op
1200 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1201 | LStrLt <- op
1202 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1203 | LStrLen <- op
1204 , (arg:_) <- args = JSProj (translateReg arg) "length"
1205 | (LStrInt ITNative) <- op
1206 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1207 | (LIntStr ITNative) <- op
1208 , (arg:_) <- args = jsCall "String" [translateReg arg]
1209 | (LSExt ITNative ITBig) <- op
1210 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1211 | (LTrunc ITBig ITNative) <- op
1212 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1213 | (LIntStr ITBig) <- op
1214 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1215 | (LStrInt ITBig) <- op
1216 , (arg:_) <- args = jsBigInt $ translateReg arg
1217 | LFloatStr <- op
1218 , (arg:_) <- args = jsCall "String" [translateReg arg]
1219 | LStrFloat <- op
1220 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1221 | (LIntFloat ITNative) <- op
1222 , (arg:_) <- args = translateReg arg
1223 | (LIntFloat ITBig) <- op
1224 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1225 | (LFloatInt ITNative) <- op
1226 , (arg:_) <- args = translateReg arg
1227 | (LChInt ITNative) <- op
1228 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1229 | (LIntCh ITNative) <- op
1230 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1232 | LFExp <- op
1233 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1234 | LFLog <- op
1235 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1236 | LFSin <- op
1237 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1238 | LFCos <- op
1239 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1240 | LFTan <- op
1241 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1242 | LFASin <- op
1243 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1244 | LFACos <- op
1245 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1246 | LFATan <- op
1247 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1248 | LFSqrt <- op
1249 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1250 | LFFloor <- op
1251 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1252 | LFCeil <- op
1253 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1254 | LFNegate <- op
1255 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1257 | LStrCons <- op
1258 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1259 | LStrHead <- op
1260 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1261 | LStrRev <- op
1262 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1263 | LStrIndex <- op
1264 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1265 | LStrTail <- op
1266 , (arg:_) <- args =
1267 let v = translateReg arg in
1268 JSApp (JSProj v "substr") [
1269 JSNum (JSInt 1),
1270 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1273 | LSystemInfo <- op
1274 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1275 | LNullPtr <- op
1276 , (_) <- args = JSNull
1277 | otherwise = JSError $ "Not implemented: " ++ show op
1278 where
1279 translateBinaryOp :: String -> Reg -> Reg -> JS
1280 translateBinaryOp op lhs rhs =
1281 JSBinOp op (translateReg lhs) (translateReg rhs)
1283 invokeMeth :: Reg -> String -> [Reg] -> JS
1284 invokeMeth obj meth args =
1285 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1288jsRESERVE :: CompileInfo -> Int -> JS
1289jsRESERVE _ _ = JSNoop
1291jsSTACK :: JS
1292jsSTACK = JSIdent "i$valstack"
1294jsCALLSTACK :: JS
1295jsCALLSTACK = JSIdent "i$callstack"
1297jsSTACKBASE :: JS
1298jsSTACKBASE = JSIdent "i$valstack_base"
1300jsSTACKTOP :: JS
1301jsSTACKTOP = JSIdent "i$valstack_top"
1303jsOLDBASE :: JS
1304jsOLDBASE = JSIdent "oldbase"
1306jsMYOLDBASE :: JS
1307jsMYOLDBASE = JSIdent "myoldbase"
1309jsRET :: JS
1310jsRET = JSIdent "i$ret"
1312jsLOC :: Int -> JS
1313jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1314jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1316jsTOP :: Int -> JS
1317jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1318jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1320jsPUSH :: [JS] -> JS
1321jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1323jsPOP :: JS
1324jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1326translateBC :: CompileInfo -> BC -> JS
1327translateBC info bc
1328 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1329 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1330 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1331 | ADDTOP n <- bc = jsADDTOP info n
1332 | NULL r <- bc = jsNULL info r
1333 | CALL n <- bc = jsCALL info n
1334 | TAILCALL n <- bc = jsTAILCALL info n
1335 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1336 | TOPBASE n <- bc = jsTOPBASE info n
1337 | BASETOP n <- bc = jsBASETOP info n
1338 | STOREOLD <- bc = jsSTOREOLD info
1339 | SLIDE n <- bc = jsSLIDE info n
1340 | REBASE <- bc = jsREBASE info
1341 | RESERVE n <- bc = jsRESERVE info n
1342 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1343 | CASE s r c d <- bc = jsCASE info s r c d
1344 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1345 | PROJECT r l a <- bc = jsPROJECT info r l a
1346 | OP r o a <- bc = jsOP info r o a
1347 | ERROR e <- bc = jsERROR info e
1348 | otherwise = JSRaw $ "//" ++ show bc