git.iko.soy/Idris-dev
on d176363 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1345 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 _ = False
62 testConstForBigInt :: Const -> Bool
63 testConstForBigInt (BI _) = True
64 testConstForBigInt (B64 _) = True
65 testConstForBigInt _ = False
68 collectCases :: String -> [(Name, [BC])] -> [Int]
69 collectCases fun bc = getCases $ findFunction fun bc
71 findFunction :: String -> [(Name, [BC])] -> [BC]
72 findFunction f ((MN 0 fun, bc):_)
73 | fun == txt f = bc
74 findFunction f (_:bc) = findFunction f bc
76 getCases :: [BC] -> [Int]
77 getCases = concatMap analyze
78 where
79 analyze :: BC -> [Int]
80 analyze (CASE _ _ b _) = map fst b
81 analyze _ = []
84data JSTarget = Node | JavaScript deriving Eq
87codegenJavaScript :: CodeGenerator
88codegenJavaScript ci =
89 codegenJS_all JavaScript (simpleDecls ci)
90 (includes ci) [] (outputFile ci) (outputType ci)
92codegenNode :: CodeGenerator
93codegenNode ci =
94 codegenJS_all Node (simpleDecls ci)
95 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
97codegenJS_all
98 :: JSTarget
99 -> [(Name, SDecl)]
100 -> [FilePath]
101 -> [String]
102 -> FilePath
103 -> OutputType
104 -> IO ()
105codegenJS_all target definitions includes libs filename outputType = do
106 let bytecode = map toBC definitions
107 let info = initCompileInfo bytecode
108 let js = concatMap (translateDecl info) bytecode
109 let full = concatMap processFunction js
110 let code = deadCodeElim full
111 let (cons, opt) = optimizeConstructors code
112 let (header, rt) = case target of
113 Node -> ("#!/usr/bin/env node\n", "-node")
114 JavaScript -> ("", "-browser")
116 included <- concat <$> getIncludes includes
117 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
118 idrRuntime <- readFile $ path ++ "Runtime-common.js"
119 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
120 jsbn <- if compileInfoNeedsBigInt info
121 then readFile $ path ++ "jsbn/jsbn.js"
122 else return ""
123 let runtime = ( header
124 ++ includeLibs libs
125 ++ included
126 ++ jsbn
127 ++ idrRuntime
128 ++ tgtRuntime
129 )
130 TIO.writeFile filename ( T.pack runtime
131 `T.append` T.concat (map compileJS opt)
132 `T.append` T.concat (map compileJS cons)
133 `T.append` main
134 `T.append` invokeMain
135 )
136 setPermissions filename (emptyPermissions { readable = True
137 , executable = target == Node
138 , writable = True
139 })
140 where
141 deadCodeElim :: [JS] -> [JS]
142 deadCodeElim js = concatMap collectFunctions js
143 where
144 collectFunctions :: JS -> [JS]
145 collectFunctions fun@(JSAlloc name _)
146 | name == translateName (sMN 0 "runMain") = [fun]
148 collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =
149 let invokations = sum $ map (
150 \x -> execState (countInvokations name x) 0
151 ) js
152 in if invokations == 0
153 then []
154 else [fun]
156 countInvokations :: String -> JS -> State Int ()
157 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
158 countInvokations name body
160 countInvokations name (JSSeq seq) =
161 void $ traverse (countInvokations name) seq
163 countInvokations name (JSAssign _ rhs) =
164 countInvokations name rhs
166 countInvokations name (JSCond conds) =
167 void $ traverse (
168 runKleisli $ arr id *** Kleisli (countInvokations name)
169 ) conds
171 countInvokations name (JSSwitch _ conds def) =
172 void $ traverse (
173 runKleisli $ arr id *** Kleisli (countInvokations name)
174 ) conds >> traverse (countInvokations name) def
176 countInvokations name (JSApp lhs rhs) =
177 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
179 countInvokations name (JSNew _ args) =
180 void $ traverse (countInvokations name) args
182 countInvokations name (JSArray args) =
183 void $ traverse (countInvokations name) args
185 countInvokations name (JSIdent name')
186 | name == name' = get >>= put . (+1)
187 | otherwise = return ()
189 countInvokations _ _ = return ()
191 processFunction :: JS -> [JS]
192 processFunction =
193 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
195 includeLibs :: [String] -> String
196 includeLibs =
197 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
199 getIncludes :: [FilePath] -> IO [String]
200 getIncludes = mapM readFile
202 main :: T.Text
203 main =
204 compileJS $ JSAlloc "main" (Just $
205 JSFunction [] (
206 case target of
207 Node -> mainFun
208 JavaScript -> jsMain
209 )
210 )
212 jsMain :: JS
213 jsMain =
214 JSCond [ (exists document `jsAnd` isReady, mainFun)
215 , (exists window, windowMainFun)
216 , (JSTrue, mainFun)
217 ]
218 where
219 exists :: JS -> JS
220 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
222 window :: JS
223 window = JSIdent "window"
225 document :: JS
226 document = JSIdent "document"
228 windowMainFun :: JS
229 windowMainFun =
230 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
231 , JSFunction [] ( mainFun )
232 , JSFalse
233 ]
235 isReady :: JS
236 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
238 readyState :: JS
239 readyState = JSProj (JSIdent "document") "readyState"
241 mainFun :: JS
242 mainFun =
243 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
244 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
245 , JSApp (
246 JSIdent (translateName (sMN 0 "runMain"))
247 ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
248 , JSWhile (JSProj jsCALLSTACK "length") (
249 JSSeq [ JSAlloc "func" (Just jsPOP)
250 , JSAlloc "args" (Just jsPOP)
251 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
252 ]
253 )
254 ]
256 invokeMain :: T.Text
257 invokeMain = compileJS $ JSApp (JSIdent "main") []
259optimizeConstructors :: [JS] -> ([JS], [JS])
260optimizeConstructors js =
261 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
262 (map (allocCon . snd) (M.toList cons), js')
263 where
264 allocCon :: (String, JS) -> JS
265 allocCon (name, con) = JSAlloc name (Just con)
267 newConstructor :: Int -> String
268 newConstructor n = "i$CON$" ++ show n
270 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
271 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
272 , JSArray []
273 , a
274 , e
275 ]) = do
276 s <- get
277 case M.lookup tag s of
278 Just (i, c) -> return $ JSIdent i
279 Nothing -> do let n = newConstructor tag
280 put $ M.insert tag (n, js) s
281 return $ JSIdent n
283 optimizeConstructor' (JSSeq seq) =
284 JSSeq <$> traverse optimizeConstructor' seq
286 optimizeConstructor' (JSSwitch reg cond def) = do
287 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
288 def' <- traverse optimizeConstructor' def
289 return $ JSSwitch reg cond' def'
291 optimizeConstructor' (JSCond cond) =
292 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
294 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
295 body' <- optimizeConstructor' body
296 return $ JSAlloc fun (Just (JSFunction args body'))
298 optimizeConstructor' (JSAssign lhs rhs) = do
299 lhs' <- optimizeConstructor' lhs
300 rhs' <- optimizeConstructor' rhs
301 return $ JSAssign lhs' rhs'
303 optimizeConstructor' js = return js
305collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
306collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
307 where
308 generateSplitFunction :: (Int,JS) -> JS
309 generateSplitFunction (depth, JSAlloc name fun) =
310 JSAlloc (name ++ "$" ++ show depth) fun
312splitFunction :: JS -> RWS () [(Int,JS)] Int JS
313splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
314 body' <- splitSequence body
315 return $ JSAlloc name (Just (JSFunction args body'))
316 where
317 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
318 splitCondition js
319 | JSCond branches <- js =
320 JSCond <$> processBranches branches
321 | JSSwitch cond branches def <- js =
322 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
323 | otherwise = return js
324 where
325 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
326 processBranches =
327 traverse (runKleisli (arr id *** Kleisli splitSequence))
329 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
330 splitSequence js@(JSSeq seq) =
331 let (pre,post) = break isBranch seq in
332 case post of
333 [_] -> JSSeq <$> traverse splitCondition seq
334 [call@(JSCond _),rest@(JSApp _ _)] -> do
335 rest' <- splitCondition rest
336 call' <- splitCondition call
337 return $ JSSeq (pre ++ [rest', call'])
338 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
339 rest' <- splitCondition rest
340 call' <- splitCondition call
341 return $ JSSeq (pre ++ [rest', call'])
342 (call:rest) -> do
343 depth <- get
344 put (depth + 1)
345 new <- splitFunction (newFun rest)
346 tell [(depth, new)]
347 call' <- splitCondition call
348 return $ JSSeq (pre ++ (newCall depth : [call']))
349 _ -> JSSeq <$> traverse splitCondition seq
351 splitSequence js = return js
353 isBranch :: JS -> Bool
354 isBranch (JSApp (JSIdent "i$CALL") _) = True
355 isBranch (JSCond _) = True
356 isBranch (JSSwitch _ _ _) = True
357 isBranch _ = False
359 newCall :: Int -> JS
360 newCall depth =
361 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
362 , JSArray [jsOLDBASE, jsMYOLDBASE]
363 ]
365 newFun :: [JS] -> JS
366 newFun seq =
367 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
369splitFunction js = return js
371translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
372translateDecl info (name@(MN 0 fun), bc)
373 | txt "APPLY" == fun =
374 allocCaseFunctions (snd body)
375 ++ [ JSAlloc (
376 translateName name
377 ) (Just $ JSFunction ["oldbase"] (
378 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
379 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
380 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
381 )
382 , ( JSNoop
383 , JSSeq $ map (translateBC info) (defaultCase (snd body))
384 )
385 ]
386 ]
387 )
388 )
389 ]
391 | txt "EVAL" == fun =
392 allocCaseFunctions (snd body)
393 ++ [ JSAlloc (
394 translateName name
395 ) (Just $ JSFunction ["oldbase"] (
396 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
397 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
398 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
399 )
400 , ( JSNoop
401 , JSSeq $ map (translateBC info) (defaultCase (snd body))
402 )
403 ]
404 ]
405 )
406 )
407 ]
408 where
409 body :: ([BC], [BC])
410 body = break isCase bc
412 isCase :: BC -> Bool
413 isCase bc
414 | CASE {} <- bc = True
415 | otherwise = False
417 defaultCase :: [BC] -> [BC]
418 defaultCase ((CASE _ _ _ (Just d)):_) = d
420 caseReg :: [BC] -> Reg
421 caseReg ((CASE _ r _ _):_) = r
423 allocCaseFunctions :: [BC] -> [JS]
424 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
425 allocCaseFunctions _ = []
427 splitBranches :: [(Int, [BC])] -> [JS]
428 splitBranches = map prepBranch
430 prepBranch :: (Int, [BC]) -> JS
431 prepBranch (tag, code) =
432 JSAlloc (
433 translateName name ++ "$" ++ show tag
434 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
435 JSSeq $ map (translateBC info) code
436 )
437 )
439translateDecl info (name, bc) =
440 [ JSAlloc (
441 translateName name
442 ) (Just $ JSFunction ["oldbase"] (
443 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
444 )
445 )
446 ]
448jsFUNPRELUDE :: [JS]
449jsFUNPRELUDE = [jsALLOCMYOLDBASE]
451jsALLOCMYOLDBASE :: JS
452jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
454translateReg :: Reg -> JS
455translateReg reg
456 | RVal <- reg = jsRET
457 | Tmp <- reg = JSRaw "//TMPREG"
458 | L n <- reg = jsLOC n
459 | T n <- reg = jsTOP n
461translateConstant :: Const -> JS
462translateConstant (I i) = JSNum (JSInt i)
463translateConstant (Fl f) = JSNum (JSFloat f)
464translateConstant (Ch c) = JSString $ translateChar c
465translateConstant (Str s) = JSString $ concatMap translateChar s
466translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
467translateConstant StrType = JSType JSStringTy
468translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
469translateConstant (AType ATFloat) = JSType JSFloatTy
470translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
471translateConstant PtrType = JSType JSPtrTy
472translateConstant Forgot = JSType JSForgotTy
473translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
474translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
475translateConstant (BI i) = jsBigInt (JSString $ show i)
476translateConstant (B8 b) = JSWord (JSWord8 b)
477translateConstant (B16 b) = JSWord (JSWord16 b)
478translateConstant (B32 b) = JSWord (JSWord32 b)
479translateConstant (B64 b) = JSWord (JSWord64 b)
480translateConstant c =
481 JSError $ "Unimplemented Constant: " ++ show c
484translateChar :: Char -> String
485translateChar ch
486 | '\a' <- ch = "\\u0007"
487 | '\b' <- ch = "\\b"
488 | '\f' <- ch = "\\f"
489 | '\n' <- ch = "\\n"
490 | '\r' <- ch = "\\r"
491 | '\t' <- ch = "\\t"
492 | '\v' <- ch = "\\v"
493 | '\SO' <- ch = "\\u000E"
494 | '\DEL' <- ch = "\\u007F"
495 | '\\' <- ch = "\\\\"
496 | '\"' <- ch = "\\\""
497 | '\'' <- ch = "\\\'"
498 | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
499 | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
500 | otherwise = [ch]
501 where
502 fill :: String -> String
503 fill s = case length s of
504 1 -> "000" ++ s
505 2 -> "00" ++ s
506 3 -> "0" ++ s
507 _ -> s
509 asciiTab =
510 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
511 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
512 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
513 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
515translateName :: Name -> String
516translateName n = "_idris_" ++ concatMap cchar (showCG n)
517 where cchar x | isAlphaNum x = [x]
518 | otherwise = "_" ++ show (fromEnum x) ++ "_"
520jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
521jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
523jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
524jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
526jsCALL :: CompileInfo -> Name -> JS
527jsCALL _ n =
528 JSApp (
529 JSIdent "i$CALL"
530 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
532jsTAILCALL :: CompileInfo -> Name -> JS
533jsTAILCALL _ n =
534 JSApp (
535 JSIdent "i$CALL"
536 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
538jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
539jsFOREIGN _ reg n args
540 | n == "putStr"
541 , [(FString, arg)] <- args =
542 JSAssign (
543 translateReg reg
544 ) (
545 JSApp (JSIdent "i$putStr") [translateReg arg]
546 )
548 | n == "isNull"
549 , [(FPtr, arg)] <- args =
550 JSAssign (
551 translateReg reg
552 ) (
553 JSBinOp "==" (translateReg arg) JSNull
554 )
556 | n == "idris_eqPtr"
557 , [(_, lhs),(_, rhs)] <- args =
558 JSAssign (
559 translateReg reg
560 ) (
561 JSBinOp "==" (translateReg lhs) (translateReg rhs)
562 )
563 | otherwise =
564 JSAssign (
565 translateReg reg
566 ) (
567 JSFFI n (map generateWrapper args)
568 )
569 where
570 generateWrapper :: (FType, Reg) -> JS
571 generateWrapper (ty, reg)
572 | FFunction <- ty =
573 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
574 , JSIdent "oldbase"
575 , JSIdent "myoldbase"
576 ]
577 | FFunctionIO <- ty =
578 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
579 , JSIdent "oldbase"
580 , JSIdent "myoldbase"
581 ]
583 generateWrapper (_, reg) =
584 translateReg reg
586jsREBASE :: CompileInfo -> JS
587jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
589jsSTOREOLD :: CompileInfo ->JS
590jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
592jsADDTOP :: CompileInfo -> Int -> JS
593jsADDTOP info n
594 | 0 <- n = JSNoop
595 | otherwise =
596 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
598jsTOPBASE :: CompileInfo -> Int -> JS
599jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
600jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
603jsBASETOP :: CompileInfo -> Int -> JS
604jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
605jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
607jsNULL :: CompileInfo -> Reg -> JS
608jsNULL _ r = JSAssign (translateReg r) JSNull
610jsERROR :: CompileInfo -> String -> JS
611jsERROR _ = JSError
613jsSLIDE :: CompileInfo -> Int -> JS
614jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
615jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
617jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
618jsMKCON info r t rs =
619 JSAssign (translateReg r) (
620 JSNew "i$CON" [ JSNum (JSInt t)
621 , JSArray (map translateReg rs)
622 , if t `elem` compileInfoApplyCases info
623 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
624 else JSNull
625 , if t `elem` compileInfoEvalCases info
626 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
627 else JSNull
628 ]
629 )
631jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
632jsCASE info safe reg cases def =
633 JSSwitch (tag safe $ translateReg reg) (
634 map ((JSNum . JSInt) *** prepBranch) cases
635 ) (fmap prepBranch def)
636 where
637 tag :: Bool -> JS -> JS
638 tag True = jsCTAG
639 tag False = jsTAG
641 prepBranch :: [BC] -> JS
642 prepBranch bc = JSSeq $ map (translateBC info) bc
644 jsTAG :: JS -> JS
645 jsTAG js =
646 (JSTernary (js `jsInstanceOf` "i$CON") (
647 JSProj js "tag"
648 ) (JSNum (JSInt $ negate 1)))
650 jsCTAG :: JS -> JS
651 jsCTAG js = JSProj js "tag"
654jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
655jsCONSTCASE info reg cases def =
656 JSCond $ (
657 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
658 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
659 where
660 prepBranch :: [BC] -> JS
661 prepBranch bc = JSSeq $ map (translateBC info) bc
663jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
664jsPROJECT _ reg loc 0 = JSNoop
665jsPROJECT _ reg loc 1 =
666 JSAssign (jsLOC loc) (
667 JSIndex (
668 JSProj (translateReg reg) "args"
669 ) (
670 JSNum (JSInt 0)
671 )
672 )
673jsPROJECT _ reg loc ar =
674 JSApp (JSIdent "i$PROJECT") [ translateReg reg
675 , JSNum (JSInt loc)
676 , JSNum (JSInt ar)
677 ]
679jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
680jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
681 where
682 jsOP' :: JS
683 jsOP'
684 | LNoOp <- op = translateReg (last args)
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 | LNullPtr <- op
1272 , (_) <- args = JSNull
1273 | otherwise = JSError $ "Not implemented: " ++ show op
1274 where
1275 translateBinaryOp :: String -> Reg -> Reg -> JS
1276 translateBinaryOp op lhs rhs =
1277 JSBinOp op (translateReg lhs) (translateReg rhs)
1279 invokeMeth :: Reg -> String -> [Reg] -> JS
1280 invokeMeth obj meth args =
1281 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1284jsRESERVE :: CompileInfo -> Int -> JS
1285jsRESERVE _ _ = JSNoop
1287jsSTACK :: JS
1288jsSTACK = JSIdent "i$valstack"
1290jsCALLSTACK :: JS
1291jsCALLSTACK = JSIdent "i$callstack"
1293jsSTACKBASE :: JS
1294jsSTACKBASE = JSIdent "i$valstack_base"
1296jsSTACKTOP :: JS
1297jsSTACKTOP = JSIdent "i$valstack_top"
1299jsOLDBASE :: JS
1300jsOLDBASE = JSIdent "oldbase"
1302jsMYOLDBASE :: JS
1303jsMYOLDBASE = JSIdent "myoldbase"
1305jsRET :: JS
1306jsRET = JSIdent "i$ret"
1308jsLOC :: Int -> JS
1309jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1310jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1312jsTOP :: Int -> JS
1313jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1314jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1316jsPUSH :: [JS] -> JS
1317jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1319jsPOP :: JS
1320jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1322translateBC :: CompileInfo -> BC -> JS
1323translateBC info bc
1324 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1325 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1326 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1327 | ADDTOP n <- bc = jsADDTOP info n
1328 | NULL r <- bc = jsNULL info r
1329 | CALL n <- bc = jsCALL info n
1330 | TAILCALL n <- bc = jsTAILCALL info n
1331 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1332 | TOPBASE n <- bc = jsTOPBASE info n
1333 | BASETOP n <- bc = jsBASETOP info n
1334 | STOREOLD <- bc = jsSTOREOLD info
1335 | SLIDE n <- bc = jsSLIDE info n
1336 | REBASE <- bc = jsREBASE info
1337 | RESERVE n <- bc = jsRESERVE info n
1338 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1339 | CASE s r c d <- bc = jsCASE info s r c d
1340 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1341 | PROJECT r l a <- bc = jsPROJECT info r l a
1342 | OP r o a <- bc = jsOP info r o a
1343 | ERROR e <- bc = jsERROR info e
1344 | otherwise = JSRaw $ "//" ++ show bc