git.iko.soy/Idris-dev
on 6cc18fd help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1324 lines 48 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 ) [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 isCall seq in
332 case post of
333 [] -> JSSeq <$> traverse splitCondition seq
334 [js@(JSCond _)] -> splitCondition js
335 [js@(JSSwitch {})] -> splitCondition js
336 [_] -> return js
337 (call:rest) -> do
338 depth <- get
339 put (depth + 1)
340 new <- splitFunction (newFun rest)
341 tell [(depth, new)]
342 return $ JSSeq (pre ++ (newCall depth : [call]))
344 splitSequence js = return js
346 isCall :: JS -> Bool
347 isCall (JSApp (JSIdent "i$CALL") _) = True
348 isCall _ = False
350 newCall :: Int -> JS
351 newCall depth =
352 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
353 , JSArray [jsOLDBASE, jsMYOLDBASE]
354 ]
356 newFun :: [JS] -> JS
357 newFun seq =
358 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
360splitFunction js = return js
362translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
363translateDecl info (name@(MN 0 fun), bc)
364 | txt "APPLY" == fun =
365 allocCaseFunctions (snd body)
366 ++ [ JSAlloc (
367 translateName name
368 ) (Just $ JSFunction ["oldbase"] (
369 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
370 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
371 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
372 )
373 , ( JSNoop
374 , JSSeq $ map (translateBC info) (defaultCase (snd body))
375 )
376 ]
377 ]
378 )
379 )
380 ]
382 | txt "EVAL" == fun =
383 allocCaseFunctions (snd body)
384 ++ [ JSAlloc (
385 translateName name
386 ) (Just $ JSFunction ["oldbase"] (
387 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
388 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
389 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
390 )
391 , ( JSNoop
392 , JSSeq $ map (translateBC info) (defaultCase (snd body))
393 )
394 ]
395 ]
396 )
397 )
398 ]
399 where
400 body :: ([BC], [BC])
401 body = break isCase bc
403 isCase :: BC -> Bool
404 isCase bc
405 | CASE {} <- bc = True
406 | otherwise = False
408 defaultCase :: [BC] -> [BC]
409 defaultCase ((CASE _ _ _ (Just d)):_) = d
411 caseReg :: [BC] -> Reg
412 caseReg ((CASE _ r _ _):_) = r
414 allocCaseFunctions :: [BC] -> [JS]
415 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
416 allocCaseFunctions _ = []
418 splitBranches :: [(Int, [BC])] -> [JS]
419 splitBranches = map prepBranch
421 prepBranch :: (Int, [BC]) -> JS
422 prepBranch (tag, code) =
423 JSAlloc (
424 translateName name ++ "$" ++ show tag
425 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
426 JSSeq $ map (translateBC info) code
427 )
428 )
430translateDecl info (name, bc) =
431 [ JSAlloc (
432 translateName name
433 ) (Just $ JSFunction ["oldbase"] (
434 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
435 )
436 )
437 ]
440translateReg :: Reg -> JS
441translateReg reg
442 | RVal <- reg = jsRET
443 | Tmp <- reg = JSRaw "//TMPREG"
444 | L n <- reg = jsLOC n
445 | T n <- reg = jsTOP n
447translateConstant :: Const -> JS
448translateConstant (I i) = JSNum (JSInt i)
449translateConstant (Fl f) = JSNum (JSFloat f)
450translateConstant (Ch c) = JSString $ translateChar c
451translateConstant (Str s) = JSString $ concatMap translateChar s
452translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
453translateConstant StrType = JSType JSStringTy
454translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
455translateConstant (AType ATFloat) = JSType JSFloatTy
456translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
457translateConstant PtrType = JSType JSPtrTy
458translateConstant Forgot = JSType JSForgotTy
459translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
460translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
461translateConstant (BI i) = jsBigInt (JSString $ show i)
462translateConstant (B8 b) = JSWord (JSWord8 b)
463translateConstant (B16 b) = JSWord (JSWord16 b)
464translateConstant (B32 b) = JSWord (JSWord32 b)
465translateConstant (B64 b) = JSWord (JSWord64 b)
466translateConstant c =
467 JSError $ "Unimplemented Constant: " ++ show c
470translateChar :: Char -> String
471translateChar ch
472 | '\a' <- ch = "\\u0007"
473 | '\b' <- ch = "\\b"
474 | '\f' <- ch = "\\f"
475 | '\n' <- ch = "\\n"
476 | '\r' <- ch = "\\r"
477 | '\t' <- ch = "\\t"
478 | '\v' <- ch = "\\v"
479 | '\SO' <- ch = "\\u000E"
480 | '\DEL' <- ch = "\\u007F"
481 | '\\' <- ch = "\\\\"
482 | '\"' <- ch = "\\\""
483 | '\'' <- ch = "\\\'"
484 | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")
485 | otherwise = [ch]
486 where
487 fill :: String -> String
488 fill s = if length s == 1
489 then '0' : s
490 else s
492 asciiTab =
493 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
494 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
495 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
496 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
498translateName :: Name -> String
499translateName n = "_idris_" ++ concatMap cchar (showCG n)
500 where cchar x | isAlphaNum x = [x]
501 | otherwise = "_" ++ show (fromEnum x) ++ "_"
503jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
504jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
506jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
507jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
509jsCALL :: CompileInfo -> Name -> JS
510jsCALL _ n =
511 JSApp (
512 JSIdent "i$CALL"
513 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
515jsTAILCALL :: CompileInfo -> Name -> JS
516jsTAILCALL _ n =
517 JSApp (
518 JSIdent "i$CALL"
519 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
521jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
522jsFOREIGN _ reg n args
523 | n == "putStr"
524 , [(FString, arg)] <- args =
525 JSAssign (
526 translateReg reg
527 ) (
528 JSApp (JSIdent "i$putStr") [translateReg arg]
529 )
531 | n == "isNull"
532 , [(FPtr, arg)] <- args =
533 JSAssign (
534 translateReg reg
535 ) (
536 JSBinOp "==" (translateReg arg) JSNull
537 )
539 | n == "idris_eqPtr"
540 , [(_, lhs),(_, rhs)] <- args =
541 JSAssign (
542 translateReg reg
543 ) (
544 JSBinOp "==" (translateReg lhs) (translateReg rhs)
545 )
546 | otherwise =
547 JSAssign (
548 translateReg reg
549 ) (
550 JSFFI n (map generateWrapper args)
551 )
552 where
553 generateWrapper :: (FType, Reg) -> JS
554 generateWrapper (ty, reg)
555 | FFunction <- ty =
556 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
557 , JSIdent "oldbase"
558 , JSIdent "myoldbase"
559 ]
560 | FFunctionIO <- ty =
561 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
562 , JSIdent "oldbase"
563 , JSIdent "myoldbase"
564 ]
566 generateWrapper (_, reg) =
567 translateReg reg
569jsREBASE :: CompileInfo -> JS
570jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
572jsSTOREOLD :: CompileInfo ->JS
573jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
575jsADDTOP :: CompileInfo -> Int -> JS
576jsADDTOP info n
577 | 0 <- n = JSNoop
578 | otherwise =
579 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
581jsTOPBASE :: CompileInfo -> Int -> JS
582jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
583jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
586jsBASETOP :: CompileInfo -> Int -> JS
587jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
588jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
590jsNULL :: CompileInfo -> Reg -> JS
591jsNULL _ r = JSAssign (translateReg r) JSNull
593jsERROR :: CompileInfo -> String -> JS
594jsERROR _ = JSError
596jsSLIDE :: CompileInfo -> Int -> JS
597jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
598jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
600jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
601jsMKCON info r t rs =
602 JSAssign (translateReg r) (
603 JSNew "i$CON" [ JSNum (JSInt t)
604 , JSArray (map translateReg rs)
605 , if t `elem` compileInfoApplyCases info
606 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
607 else JSNull
608 , if t `elem` compileInfoEvalCases info
609 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
610 else JSNull
611 ]
612 )
614jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
615jsCASE info safe reg cases def =
616 JSSwitch (tag safe $ translateReg reg) (
617 map ((JSNum . JSInt) *** prepBranch) cases
618 ) (fmap prepBranch def)
619 where
620 tag :: Bool -> JS -> JS
621 tag True = jsCTAG
622 tag False = jsTAG
624 prepBranch :: [BC] -> JS
625 prepBranch bc = JSSeq $ map (translateBC info) bc
627 jsTAG :: JS -> JS
628 jsTAG js =
629 (JSTernary (js `jsInstanceOf` "i$CON") (
630 JSProj js "tag"
631 ) (JSNum (JSInt $ negate 1)))
633 jsCTAG :: JS -> JS
634 jsCTAG js = JSProj js "tag"
637jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
638jsCONSTCASE info reg cases def =
639 JSCond $ (
640 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
641 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
642 where
643 prepBranch :: [BC] -> JS
644 prepBranch bc = JSSeq $ map (translateBC info) bc
646jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
647jsPROJECT _ reg loc 0 = JSNoop
648jsPROJECT _ reg loc 1 =
649 JSAssign (jsLOC loc) (
650 JSIndex (
651 JSProj (translateReg reg) "args"
652 ) (
653 JSNum (JSInt 0)
654 )
655 )
656jsPROJECT _ reg loc ar =
657 JSApp (JSIdent "i$PROJECT") [ translateReg reg
658 , JSNum (JSInt loc)
659 , JSNum (JSInt ar)
660 ]
662jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
663jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
664 where
665 jsOP' :: JS
666 jsOP'
667 | LNoOp <- op = translateReg (last args)
669 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
670 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
671 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
673 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
674 | (LPlus (ATInt ITBig)) <- op
675 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
676 | (LMinus (ATInt ITBig)) <- op
677 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
678 | (LTimes (ATInt ITBig)) <- op
679 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
680 | (LSDiv (ATInt ITBig)) <- op
681 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
682 | (LSRem (ATInt ITBig)) <- op
683 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
684 | (LEq (ATInt ITBig)) <- op
685 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
686 | (LSLt (ATInt ITBig)) <- op
687 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
688 | (LSLe (ATInt ITBig)) <- op
689 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
690 | (LSGt (ATInt ITBig)) <- op
691 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
692 | (LSGe (ATInt ITBig)) <- op
693 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
695 | (LPlus ATFloat) <- op
696 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
697 | (LMinus ATFloat) <- op
698 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
699 | (LTimes ATFloat) <- op
700 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
701 | (LSDiv ATFloat) <- op
702 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
703 | (LEq ATFloat) <- op
704 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
705 | (LSLt ATFloat) <- op
706 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
707 | (LSLe ATFloat) <- op
708 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
709 | (LSGt ATFloat) <- op
710 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
711 | (LSGe ATFloat) <- op
712 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
714 | (LPlus (ATInt ITChar)) <- op
715 , (lhs:rhs:_) <- args =
716 jsCall "i$fromCharCode" [
717 JSBinOp "+" (
718 jsCall "i$charCode" [translateReg lhs]
719 ) (
720 jsCall "i$charCode" [translateReg rhs]
721 )
722 ]
724 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
725 , (arg:_) <- args =
726 jsPackUBits8 (
727 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
728 )
730 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
731 , (arg:_) <- args =
732 jsPackUBits16 (
733 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
734 )
736 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
737 , (arg:_) <- args =
738 jsPackUBits32 (
739 jsMeth (jsMeth (translateReg arg) "and" [
740 jsBigInt (JSString $ show 0xFFFFFFFF)
741 ]) "intValue" []
742 )
744 | (LTrunc ITBig (ITFixed IT64)) <- op
745 , (arg:_) <- args =
746 jsMeth (translateReg arg) "and" [
747 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
748 ]
750 | (LLSHR (ITFixed IT8)) <- op
751 , (lhs:rhs:_) <- args =
752 jsPackUBits8 (
753 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
754 )
756 | (LLSHR (ITFixed IT16)) <- op
757 , (lhs:rhs:_) <- args =
758 jsPackUBits16 (
759 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
760 )
762 | (LLSHR (ITFixed IT32)) <- op
763 , (lhs:rhs:_) <- args =
764 jsPackUBits32 (
765 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
766 )
768 | (LLSHR (ITFixed IT64)) <- op
769 , (lhs:rhs:_) <- args =
770 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
772 | (LSHL (ITFixed IT8)) <- op
773 , (lhs:rhs:_) <- args =
774 jsPackUBits8 (
775 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
776 )
778 | (LSHL (ITFixed IT16)) <- op
779 , (lhs:rhs:_) <- args =
780 jsPackUBits16 (
781 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
782 )
784 | (LSHL (ITFixed IT32)) <- op
785 , (lhs:rhs:_) <- args =
786 jsPackUBits32 (
787 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
788 )
790 | (LSHL (ITFixed IT64)) <- op
791 , (lhs:rhs:_) <- args =
792 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
793 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
794 ]
796 | (LAnd (ITFixed IT8)) <- op
797 , (lhs:rhs:_) <- args =
798 jsPackUBits8 (
799 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
800 )
802 | (LAnd (ITFixed IT16)) <- op
803 , (lhs:rhs:_) <- args =
804 jsPackUBits16 (
805 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
806 )
808 | (LAnd (ITFixed IT32)) <- op
809 , (lhs:rhs:_) <- args =
810 jsPackUBits32 (
811 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
812 )
814 | (LAnd (ITFixed IT64)) <- op
815 , (lhs:rhs:_) <- args =
816 jsMeth (translateReg lhs) "and" [translateReg rhs]
818 | (LOr (ITFixed IT8)) <- op
819 , (lhs:rhs:_) <- args =
820 jsPackUBits8 (
821 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
822 )
824 | (LOr (ITFixed IT16)) <- op
825 , (lhs:rhs:_) <- args =
826 jsPackUBits16 (
827 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
828 )
830 | (LOr (ITFixed IT32)) <- op
831 , (lhs:rhs:_) <- args =
832 jsPackUBits32 (
833 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
834 )
836 | (LOr (ITFixed IT64)) <- op
837 , (lhs:rhs:_) <- args =
838 jsMeth (translateReg lhs) "or" [translateReg rhs]
840 | (LXOr (ITFixed IT8)) <- op
841 , (lhs:rhs:_) <- args =
842 jsPackUBits8 (
843 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
844 )
846 | (LXOr (ITFixed IT16)) <- op
847 , (lhs:rhs:_) <- args =
848 jsPackUBits16 (
849 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
850 )
852 | (LXOr (ITFixed IT32)) <- op
853 , (lhs:rhs:_) <- args =
854 jsPackUBits32 (
855 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
856 )
858 | (LXOr (ITFixed IT64)) <- op
859 , (lhs:rhs:_) <- args =
860 jsMeth (translateReg lhs) "xor" [translateReg rhs]
862 | (LPlus (ATInt (ITFixed IT8))) <- op
863 , (lhs:rhs:_) <- args =
864 jsPackUBits8 (
865 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
866 )
868 | (LPlus (ATInt (ITFixed IT16))) <- op
869 , (lhs:rhs:_) <- args =
870 jsPackUBits16 (
871 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
872 )
874 | (LPlus (ATInt (ITFixed IT32))) <- op
875 , (lhs:rhs:_) <- args =
876 jsPackUBits32 (
877 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
878 )
880 | (LPlus (ATInt (ITFixed IT64))) <- op
881 , (lhs:rhs:_) <- args =
882 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
883 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
884 ]
886 | (LMinus (ATInt (ITFixed IT8))) <- op
887 , (lhs:rhs:_) <- args =
888 jsPackUBits8 (
889 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
890 )
892 | (LMinus (ATInt (ITFixed IT16))) <- op
893 , (lhs:rhs:_) <- args =
894 jsPackUBits16 (
895 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
896 )
898 | (LMinus (ATInt (ITFixed IT32))) <- op
899 , (lhs:rhs:_) <- args =
900 jsPackUBits32 (
901 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
902 )
904 | (LMinus (ATInt (ITFixed IT64))) <- op
905 , (lhs:rhs:_) <- args =
906 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
907 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
908 ]
910 | (LTimes (ATInt (ITFixed IT8))) <- op
911 , (lhs:rhs:_) <- args =
912 jsPackUBits8 (
913 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
914 )
916 | (LTimes (ATInt (ITFixed IT16))) <- op
917 , (lhs:rhs:_) <- args =
918 jsPackUBits16 (
919 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
920 )
922 | (LTimes (ATInt (ITFixed IT32))) <- op
923 , (lhs:rhs:_) <- args =
924 jsPackUBits32 (
925 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
926 )
928 | (LTimes (ATInt (ITFixed IT64))) <- op
929 , (lhs:rhs:_) <- args =
930 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
931 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
932 ]
934 | (LEq (ATInt (ITFixed IT8))) <- op
935 , (lhs:rhs:_) <- args =
936 jsPackUBits8 (
937 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
938 )
940 | (LEq (ATInt (ITFixed IT16))) <- op
941 , (lhs:rhs:_) <- args =
942 jsPackUBits16 (
943 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
944 )
946 | (LEq (ATInt (ITFixed IT32))) <- op
947 , (lhs:rhs:_) <- args =
948 jsPackUBits32 (
949 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
950 )
952 | (LEq (ATInt (ITFixed IT64))) <- op
953 , (lhs:rhs:_) <- args =
954 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
955 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
956 ]
958 | (LLt (ITFixed IT8)) <- op
959 , (lhs:rhs:_) <- args =
960 jsPackUBits8 (
961 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
962 )
964 | (LLt (ITFixed IT16)) <- op
965 , (lhs:rhs:_) <- args =
966 jsPackUBits16 (
967 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
968 )
970 | (LLt (ITFixed IT32)) <- op
971 , (lhs:rhs:_) <- args =
972 jsPackUBits32 (
973 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
974 )
976 | (LLt (ITFixed IT64)) <- op
977 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
979 | (LLe (ITFixed IT8)) <- op
980 , (lhs:rhs:_) <- args =
981 jsPackUBits8 (
982 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
983 )
985 | (LLe (ITFixed IT16)) <- op
986 , (lhs:rhs:_) <- args =
987 jsPackUBits16 (
988 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
989 )
991 | (LLe (ITFixed IT32)) <- op
992 , (lhs:rhs:_) <- args =
993 jsPackUBits32 (
994 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
995 )
997 | (LLe (ITFixed IT64)) <- op
998 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1000 | (LGt (ITFixed IT8)) <- op
1001 , (lhs:rhs:_) <- args =
1002 jsPackUBits8 (
1003 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1006 | (LGt (ITFixed IT16)) <- op
1007 , (lhs:rhs:_) <- args =
1008 jsPackUBits16 (
1009 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1011 | (LGt (ITFixed IT32)) <- op
1012 , (lhs:rhs:_) <- args =
1013 jsPackUBits32 (
1014 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1017 | (LGt (ITFixed IT64)) <- op
1018 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1020 | (LGe (ITFixed IT8)) <- op
1021 , (lhs:rhs:_) <- args =
1022 jsPackUBits8 (
1023 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1026 | (LGe (ITFixed IT16)) <- op
1027 , (lhs:rhs:_) <- args =
1028 jsPackUBits16 (
1029 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1031 | (LGe (ITFixed IT32)) <- op
1032 , (lhs:rhs:_) <- args =
1033 jsPackUBits32 (
1034 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1037 | (LGe (ITFixed IT64)) <- op
1038 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1040 | (LUDiv (ITFixed IT8)) <- op
1041 , (lhs:rhs:_) <- args =
1042 jsPackUBits8 (
1043 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1046 | (LUDiv (ITFixed IT16)) <- op
1047 , (lhs:rhs:_) <- args =
1048 jsPackUBits16 (
1049 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1052 | (LUDiv (ITFixed IT32)) <- op
1053 , (lhs:rhs:_) <- args =
1054 jsPackUBits32 (
1055 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1058 | (LUDiv (ITFixed IT64)) <- op
1059 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1061 | (LSDiv (ATInt (ITFixed IT8))) <- op
1062 , (lhs:rhs:_) <- args =
1063 jsPackSBits8 (
1064 JSBinOp "/" (
1065 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1066 ) (
1067 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1071 | (LSDiv (ATInt (ITFixed IT16))) <- op
1072 , (lhs:rhs:_) <- args =
1073 jsPackSBits16 (
1074 JSBinOp "/" (
1075 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1076 ) (
1077 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1081 | (LSDiv (ATInt (ITFixed IT32))) <- op
1082 , (lhs:rhs:_) <- args =
1083 jsPackSBits32 (
1084 JSBinOp "/" (
1085 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1086 ) (
1087 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1091 | (LSDiv (ATInt (ITFixed IT64))) <- op
1092 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1094 | (LSRem (ATInt (ITFixed IT8))) <- op
1095 , (lhs:rhs:_) <- args =
1096 jsPackSBits8 (
1097 JSBinOp "%" (
1098 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1099 ) (
1100 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1104 | (LSRem (ATInt (ITFixed IT16))) <- op
1105 , (lhs:rhs:_) <- args =
1106 jsPackSBits16 (
1107 JSBinOp "%" (
1108 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1109 ) (
1110 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1114 | (LSRem (ATInt (ITFixed IT32))) <- op
1115 , (lhs:rhs:_) <- args =
1116 jsPackSBits32 (
1117 JSBinOp "%" (
1118 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1119 ) (
1120 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1124 | (LSRem (ATInt (ITFixed IT64))) <- op
1125 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1127 | (LCompl (ITFixed IT8)) <- op
1128 , (arg:_) <- args =
1129 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1131 | (LCompl (ITFixed IT16)) <- op
1132 , (arg:_) <- args =
1133 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1135 | (LCompl (ITFixed IT32)) <- op
1136 , (arg:_) <- args =
1137 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1139 | (LCompl (ITFixed IT64)) <- op
1140 , (arg:_) <- args =
1141 invokeMeth arg "not" []
1143 | (LPlus _) <- op
1144 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1145 | (LMinus _) <- op
1146 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1147 | (LTimes _) <- op
1148 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1149 | (LSDiv _) <- op
1150 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1151 | (LSRem _) <- op
1152 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1153 | (LEq _) <- op
1154 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1155 | (LSLt _) <- op
1156 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1157 | (LSLe _) <- op
1158 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1159 | (LSGt _) <- op
1160 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1161 | (LSGe _) <- op
1162 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1163 | (LAnd _) <- op
1164 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1165 | (LOr _) <- op
1166 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1167 | (LXOr _) <- op
1168 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1169 | (LSHL _) <- op
1170 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1171 | (LASHR _) <- op
1172 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1173 | (LCompl _) <- op
1174 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1176 | LStrConcat <- op
1177 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1178 | LStrEq <- op
1179 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1180 | LStrLt <- op
1181 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1182 | LStrLen <- op
1183 , (arg:_) <- args = JSProj (translateReg arg) "length"
1184 | (LStrInt ITNative) <- op
1185 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1186 | (LIntStr ITNative) <- op
1187 , (arg:_) <- args = jsCall "String" [translateReg arg]
1188 | (LSExt ITNative ITBig) <- op
1189 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1190 | (LTrunc ITBig ITNative) <- op
1191 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1192 | (LIntStr ITBig) <- op
1193 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1194 | (LStrInt ITBig) <- op
1195 , (arg:_) <- args = jsBigInt $ translateReg arg
1196 | LFloatStr <- op
1197 , (arg:_) <- args = jsCall "String" [translateReg arg]
1198 | LStrFloat <- op
1199 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1200 | (LIntFloat ITNative) <- op
1201 , (arg:_) <- args = translateReg arg
1202 | (LFloatInt ITNative) <- op
1203 , (arg:_) <- args = translateReg arg
1204 | (LChInt ITNative) <- op
1205 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1206 | (LIntCh ITNative) <- op
1207 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1209 | LFExp <- op
1210 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1211 | LFLog <- op
1212 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1213 | LFSin <- op
1214 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1215 | LFCos <- op
1216 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1217 | LFTan <- op
1218 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1219 | LFASin <- op
1220 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1221 | LFACos <- op
1222 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1223 | LFATan <- op
1224 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1225 | LFSqrt <- op
1226 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1227 | LFFloor <- op
1228 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1229 | LFCeil <- op
1230 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1232 | LStrCons <- op
1233 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1234 | LStrHead <- op
1235 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1236 | LStrRev <- op
1237 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1238 | LStrIndex <- op
1239 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1240 | LStrTail <- op
1241 , (arg:_) <- args =
1242 let v = translateReg arg in
1243 JSApp (JSProj v "substr") [
1244 JSNum (JSInt 1),
1245 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1248 | LSystemInfo <- op
1249 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1250 | LNullPtr <- op
1251 , (_) <- args = JSNull
1252 | otherwise = JSError $ "Not implemented: " ++ show op
1253 where
1254 translateBinaryOp :: String -> Reg -> Reg -> JS
1255 translateBinaryOp op lhs rhs =
1256 JSBinOp op (translateReg lhs) (translateReg rhs)
1258 invokeMeth :: Reg -> String -> [Reg] -> JS
1259 invokeMeth obj meth args =
1260 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1263jsRESERVE :: CompileInfo -> Int -> JS
1264jsRESERVE _ _ = JSNoop
1266jsSTACK :: JS
1267jsSTACK = JSIdent "i$valstack"
1269jsCALLSTACK :: JS
1270jsCALLSTACK = JSIdent "i$callstack"
1272jsSTACKBASE :: JS
1273jsSTACKBASE = JSIdent "i$valstack_base"
1275jsSTACKTOP :: JS
1276jsSTACKTOP = JSIdent "i$valstack_top"
1278jsOLDBASE :: JS
1279jsOLDBASE = JSIdent "oldbase"
1281jsMYOLDBASE :: JS
1282jsMYOLDBASE = JSIdent "myoldbase"
1284jsRET :: JS
1285jsRET = JSIdent "i$ret"
1287jsLOC :: Int -> JS
1288jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1289jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1291jsTOP :: Int -> JS
1292jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1293jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1295jsPUSH :: [JS] -> JS
1296jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1298jsPOP :: JS
1299jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1301translateBC :: CompileInfo -> BC -> JS
1302translateBC info bc
1303 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1304 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1305 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1306 | ADDTOP n <- bc = jsADDTOP info n
1307 | NULL r <- bc = jsNULL info r
1308 | CALL n <- bc = jsCALL info n
1309 | TAILCALL n <- bc = jsTAILCALL info n
1310 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1311 | TOPBASE n <- bc = jsTOPBASE info n
1312 | BASETOP n <- bc = jsBASETOP info n
1313 | STOREOLD <- bc = jsSTOREOLD info
1314 | SLIDE n <- bc = jsSLIDE info n
1315 | REBASE <- bc = jsREBASE info
1316 | RESERVE n <- bc = jsRESERVE info n
1317 | MKCON r t rs <- bc = jsMKCON info r t rs
1318 | CASE s r c d <- bc = jsCASE info s r c d
1319 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1320 | PROJECT r l a <- bc = jsPROJECT info r l a
1321 | OP r o a <- bc = jsOP info r o a
1322 | ERROR e <- bc = jsERROR info e
1323 | otherwise = JSRaw $ "//" ++ show bc