git.iko.soy/Idris-dev
on fbcd643 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1342 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 ) [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 = "\\u00" ++ fill (showHex (ord ch) "")
499 | otherwise = [ch]
500 where
501 fill :: String -> String
502 fill s = if length s == 1
503 then '0' : s
504 else s
506 asciiTab =
507 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
508 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
509 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
510 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
512translateName :: Name -> String
513translateName n = "_idris_" ++ concatMap cchar (showCG n)
514 where cchar x | isAlphaNum x = [x]
515 | otherwise = "_" ++ show (fromEnum x) ++ "_"
517jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
518jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
520jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
521jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
523jsCALL :: CompileInfo -> Name -> JS
524jsCALL _ n =
525 JSApp (
526 JSIdent "i$CALL"
527 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
529jsTAILCALL :: CompileInfo -> Name -> JS
530jsTAILCALL _ n =
531 JSApp (
532 JSIdent "i$CALL"
533 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
535jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
536jsFOREIGN _ reg n args
537 | n == "putStr"
538 , [(FString, arg)] <- args =
539 JSAssign (
540 translateReg reg
541 ) (
542 JSApp (JSIdent "i$putStr") [translateReg arg]
543 )
545 | n == "isNull"
546 , [(FPtr, arg)] <- args =
547 JSAssign (
548 translateReg reg
549 ) (
550 JSBinOp "==" (translateReg arg) JSNull
551 )
553 | n == "idris_eqPtr"
554 , [(_, lhs),(_, rhs)] <- args =
555 JSAssign (
556 translateReg reg
557 ) (
558 JSBinOp "==" (translateReg lhs) (translateReg rhs)
559 )
560 | otherwise =
561 JSAssign (
562 translateReg reg
563 ) (
564 JSFFI n (map generateWrapper args)
565 )
566 where
567 generateWrapper :: (FType, Reg) -> JS
568 generateWrapper (ty, reg)
569 | FFunction <- ty =
570 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
571 , JSIdent "oldbase"
572 , JSIdent "myoldbase"
573 ]
574 | FFunctionIO <- ty =
575 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
576 , JSIdent "oldbase"
577 , JSIdent "myoldbase"
578 ]
580 generateWrapper (_, reg) =
581 translateReg reg
583jsREBASE :: CompileInfo -> JS
584jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
586jsSTOREOLD :: CompileInfo ->JS
587jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
589jsADDTOP :: CompileInfo -> Int -> JS
590jsADDTOP info n
591 | 0 <- n = JSNoop
592 | otherwise =
593 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
595jsTOPBASE :: CompileInfo -> Int -> JS
596jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
597jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
600jsBASETOP :: CompileInfo -> Int -> JS
601jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
602jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
604jsNULL :: CompileInfo -> Reg -> JS
605jsNULL _ r = JSAssign (translateReg r) JSNull
607jsERROR :: CompileInfo -> String -> JS
608jsERROR _ = JSError
610jsSLIDE :: CompileInfo -> Int -> JS
611jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
612jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
614jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
615jsMKCON info r t rs =
616 JSAssign (translateReg r) (
617 JSNew "i$CON" [ JSNum (JSInt t)
618 , JSArray (map translateReg rs)
619 , if t `elem` compileInfoApplyCases info
620 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
621 else JSNull
622 , if t `elem` compileInfoEvalCases info
623 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
624 else JSNull
625 ]
626 )
628jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
629jsCASE info safe reg cases def =
630 JSSwitch (tag safe $ translateReg reg) (
631 map ((JSNum . JSInt) *** prepBranch) cases
632 ) (fmap prepBranch def)
633 where
634 tag :: Bool -> JS -> JS
635 tag True = jsCTAG
636 tag False = jsTAG
638 prepBranch :: [BC] -> JS
639 prepBranch bc = JSSeq $ map (translateBC info) bc
641 jsTAG :: JS -> JS
642 jsTAG js =
643 (JSTernary (js `jsInstanceOf` "i$CON") (
644 JSProj js "tag"
645 ) (JSNum (JSInt $ negate 1)))
647 jsCTAG :: JS -> JS
648 jsCTAG js = JSProj js "tag"
651jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
652jsCONSTCASE info reg cases def =
653 JSCond $ (
654 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
655 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
656 where
657 prepBranch :: [BC] -> JS
658 prepBranch bc = JSSeq $ map (translateBC info) bc
660jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
661jsPROJECT _ reg loc 0 = JSNoop
662jsPROJECT _ reg loc 1 =
663 JSAssign (jsLOC loc) (
664 JSIndex (
665 JSProj (translateReg reg) "args"
666 ) (
667 JSNum (JSInt 0)
668 )
669 )
670jsPROJECT _ reg loc ar =
671 JSApp (JSIdent "i$PROJECT") [ translateReg reg
672 , JSNum (JSInt loc)
673 , JSNum (JSInt ar)
674 ]
676jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
677jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
678 where
679 jsOP' :: JS
680 jsOP'
681 | LNoOp <- op = translateReg (last args)
683 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
684 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
685 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
687 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
688 | (LPlus (ATInt ITBig)) <- op
689 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
690 | (LMinus (ATInt ITBig)) <- op
691 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
692 | (LTimes (ATInt ITBig)) <- op
693 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
694 | (LSDiv (ATInt ITBig)) <- op
695 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
696 | (LSRem (ATInt ITBig)) <- op
697 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
698 | (LEq (ATInt ITBig)) <- op
699 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
700 | (LSLt (ATInt ITBig)) <- op
701 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
702 | (LSLe (ATInt ITBig)) <- op
703 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
704 | (LSGt (ATInt ITBig)) <- op
705 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
706 | (LSGe (ATInt ITBig)) <- op
707 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
709 | (LPlus ATFloat) <- op
710 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
711 | (LMinus ATFloat) <- op
712 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
713 | (LTimes ATFloat) <- op
714 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
715 | (LSDiv ATFloat) <- op
716 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
717 | (LEq ATFloat) <- op
718 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
719 | (LSLt ATFloat) <- op
720 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
721 | (LSLe ATFloat) <- op
722 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
723 | (LSGt ATFloat) <- op
724 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
725 | (LSGe ATFloat) <- op
726 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
728 | (LPlus (ATInt ITChar)) <- op
729 , (lhs:rhs:_) <- args =
730 jsCall "i$fromCharCode" [
731 JSBinOp "+" (
732 jsCall "i$charCode" [translateReg lhs]
733 ) (
734 jsCall "i$charCode" [translateReg rhs]
735 )
736 ]
738 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
739 , (arg:_) <- args =
740 jsPackUBits8 (
741 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
742 )
744 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
745 , (arg:_) <- args =
746 jsPackUBits16 (
747 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
748 )
750 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
751 , (arg:_) <- args =
752 jsPackUBits32 (
753 jsMeth (jsMeth (translateReg arg) "and" [
754 jsBigInt (JSString $ show 0xFFFFFFFF)
755 ]) "intValue" []
756 )
758 | (LTrunc ITBig (ITFixed IT64)) <- op
759 , (arg:_) <- args =
760 jsMeth (translateReg arg) "and" [
761 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
762 ]
764 | (LLSHR (ITFixed IT8)) <- op
765 , (lhs:rhs:_) <- args =
766 jsPackUBits8 (
767 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
768 )
770 | (LLSHR (ITFixed IT16)) <- op
771 , (lhs:rhs:_) <- args =
772 jsPackUBits16 (
773 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
774 )
776 | (LLSHR (ITFixed IT32)) <- op
777 , (lhs:rhs:_) <- args =
778 jsPackUBits32 (
779 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
780 )
782 | (LLSHR (ITFixed IT64)) <- op
783 , (lhs:rhs:_) <- args =
784 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
786 | (LSHL (ITFixed IT8)) <- op
787 , (lhs:rhs:_) <- args =
788 jsPackUBits8 (
789 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
790 )
792 | (LSHL (ITFixed IT16)) <- op
793 , (lhs:rhs:_) <- args =
794 jsPackUBits16 (
795 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
796 )
798 | (LSHL (ITFixed IT32)) <- op
799 , (lhs:rhs:_) <- args =
800 jsPackUBits32 (
801 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
802 )
804 | (LSHL (ITFixed IT64)) <- op
805 , (lhs:rhs:_) <- args =
806 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
807 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
808 ]
810 | (LAnd (ITFixed IT8)) <- op
811 , (lhs:rhs:_) <- args =
812 jsPackUBits8 (
813 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
814 )
816 | (LAnd (ITFixed IT16)) <- op
817 , (lhs:rhs:_) <- args =
818 jsPackUBits16 (
819 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
820 )
822 | (LAnd (ITFixed IT32)) <- op
823 , (lhs:rhs:_) <- args =
824 jsPackUBits32 (
825 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
826 )
828 | (LAnd (ITFixed IT64)) <- op
829 , (lhs:rhs:_) <- args =
830 jsMeth (translateReg lhs) "and" [translateReg rhs]
832 | (LOr (ITFixed IT8)) <- op
833 , (lhs:rhs:_) <- args =
834 jsPackUBits8 (
835 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
836 )
838 | (LOr (ITFixed IT16)) <- op
839 , (lhs:rhs:_) <- args =
840 jsPackUBits16 (
841 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
842 )
844 | (LOr (ITFixed IT32)) <- op
845 , (lhs:rhs:_) <- args =
846 jsPackUBits32 (
847 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
848 )
850 | (LOr (ITFixed IT64)) <- op
851 , (lhs:rhs:_) <- args =
852 jsMeth (translateReg lhs) "or" [translateReg rhs]
854 | (LXOr (ITFixed IT8)) <- op
855 , (lhs:rhs:_) <- args =
856 jsPackUBits8 (
857 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
858 )
860 | (LXOr (ITFixed IT16)) <- op
861 , (lhs:rhs:_) <- args =
862 jsPackUBits16 (
863 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
864 )
866 | (LXOr (ITFixed IT32)) <- op
867 , (lhs:rhs:_) <- args =
868 jsPackUBits32 (
869 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
870 )
872 | (LXOr (ITFixed IT64)) <- op
873 , (lhs:rhs:_) <- args =
874 jsMeth (translateReg lhs) "xor" [translateReg rhs]
876 | (LPlus (ATInt (ITFixed IT8))) <- op
877 , (lhs:rhs:_) <- args =
878 jsPackUBits8 (
879 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
880 )
882 | (LPlus (ATInt (ITFixed IT16))) <- op
883 , (lhs:rhs:_) <- args =
884 jsPackUBits16 (
885 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
886 )
888 | (LPlus (ATInt (ITFixed IT32))) <- op
889 , (lhs:rhs:_) <- args =
890 jsPackUBits32 (
891 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
892 )
894 | (LPlus (ATInt (ITFixed IT64))) <- op
895 , (lhs:rhs:_) <- args =
896 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
897 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
898 ]
900 | (LMinus (ATInt (ITFixed IT8))) <- op
901 , (lhs:rhs:_) <- args =
902 jsPackUBits8 (
903 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
904 )
906 | (LMinus (ATInt (ITFixed IT16))) <- op
907 , (lhs:rhs:_) <- args =
908 jsPackUBits16 (
909 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
910 )
912 | (LMinus (ATInt (ITFixed IT32))) <- op
913 , (lhs:rhs:_) <- args =
914 jsPackUBits32 (
915 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
916 )
918 | (LMinus (ATInt (ITFixed IT64))) <- op
919 , (lhs:rhs:_) <- args =
920 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
921 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
922 ]
924 | (LTimes (ATInt (ITFixed IT8))) <- op
925 , (lhs:rhs:_) <- args =
926 jsPackUBits8 (
927 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
928 )
930 | (LTimes (ATInt (ITFixed IT16))) <- op
931 , (lhs:rhs:_) <- args =
932 jsPackUBits16 (
933 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
934 )
936 | (LTimes (ATInt (ITFixed IT32))) <- op
937 , (lhs:rhs:_) <- args =
938 jsPackUBits32 (
939 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
940 )
942 | (LTimes (ATInt (ITFixed IT64))) <- op
943 , (lhs:rhs:_) <- args =
944 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
945 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
946 ]
948 | (LEq (ATInt (ITFixed IT8))) <- op
949 , (lhs:rhs:_) <- args =
950 jsPackUBits8 (
951 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
952 )
954 | (LEq (ATInt (ITFixed IT16))) <- op
955 , (lhs:rhs:_) <- args =
956 jsPackUBits16 (
957 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
958 )
960 | (LEq (ATInt (ITFixed IT32))) <- op
961 , (lhs:rhs:_) <- args =
962 jsPackUBits32 (
963 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
964 )
966 | (LEq (ATInt (ITFixed IT64))) <- op
967 , (lhs:rhs:_) <- args =
968 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
969 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
970 ]
972 | (LLt (ITFixed IT8)) <- op
973 , (lhs:rhs:_) <- args =
974 jsPackUBits8 (
975 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
976 )
978 | (LLt (ITFixed IT16)) <- op
979 , (lhs:rhs:_) <- args =
980 jsPackUBits16 (
981 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
982 )
984 | (LLt (ITFixed IT32)) <- op
985 , (lhs:rhs:_) <- args =
986 jsPackUBits32 (
987 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
988 )
990 | (LLt (ITFixed IT64)) <- op
991 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
993 | (LLe (ITFixed IT8)) <- op
994 , (lhs:rhs:_) <- args =
995 jsPackUBits8 (
996 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
997 )
999 | (LLe (ITFixed IT16)) <- op
1000 , (lhs:rhs:_) <- args =
1001 jsPackUBits16 (
1002 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1005 | (LLe (ITFixed IT32)) <- op
1006 , (lhs:rhs:_) <- args =
1007 jsPackUBits32 (
1008 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1011 | (LLe (ITFixed IT64)) <- op
1012 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1014 | (LGt (ITFixed IT8)) <- op
1015 , (lhs:rhs:_) <- args =
1016 jsPackUBits8 (
1017 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1020 | (LGt (ITFixed IT16)) <- op
1021 , (lhs:rhs:_) <- args =
1022 jsPackUBits16 (
1023 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1025 | (LGt (ITFixed IT32)) <- op
1026 , (lhs:rhs:_) <- args =
1027 jsPackUBits32 (
1028 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1031 | (LGt (ITFixed IT64)) <- op
1032 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1034 | (LGe (ITFixed IT8)) <- op
1035 , (lhs:rhs:_) <- args =
1036 jsPackUBits8 (
1037 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1040 | (LGe (ITFixed IT16)) <- op
1041 , (lhs:rhs:_) <- args =
1042 jsPackUBits16 (
1043 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1045 | (LGe (ITFixed IT32)) <- op
1046 , (lhs:rhs:_) <- args =
1047 jsPackUBits32 (
1048 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1051 | (LGe (ITFixed IT64)) <- op
1052 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1054 | (LUDiv (ITFixed IT8)) <- op
1055 , (lhs:rhs:_) <- args =
1056 jsPackUBits8 (
1057 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1060 | (LUDiv (ITFixed IT16)) <- op
1061 , (lhs:rhs:_) <- args =
1062 jsPackUBits16 (
1063 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1066 | (LUDiv (ITFixed IT32)) <- op
1067 , (lhs:rhs:_) <- args =
1068 jsPackUBits32 (
1069 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1072 | (LUDiv (ITFixed IT64)) <- op
1073 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1075 | (LSDiv (ATInt (ITFixed IT8))) <- op
1076 , (lhs:rhs:_) <- args =
1077 jsPackSBits8 (
1078 JSBinOp "/" (
1079 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1080 ) (
1081 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1085 | (LSDiv (ATInt (ITFixed IT16))) <- op
1086 , (lhs:rhs:_) <- args =
1087 jsPackSBits16 (
1088 JSBinOp "/" (
1089 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1090 ) (
1091 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1095 | (LSDiv (ATInt (ITFixed IT32))) <- op
1096 , (lhs:rhs:_) <- args =
1097 jsPackSBits32 (
1098 JSBinOp "/" (
1099 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1100 ) (
1101 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1105 | (LSDiv (ATInt (ITFixed IT64))) <- op
1106 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1108 | (LSRem (ATInt (ITFixed IT8))) <- op
1109 , (lhs:rhs:_) <- args =
1110 jsPackSBits8 (
1111 JSBinOp "%" (
1112 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1113 ) (
1114 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1118 | (LSRem (ATInt (ITFixed IT16))) <- op
1119 , (lhs:rhs:_) <- args =
1120 jsPackSBits16 (
1121 JSBinOp "%" (
1122 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1123 ) (
1124 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1128 | (LSRem (ATInt (ITFixed IT32))) <- op
1129 , (lhs:rhs:_) <- args =
1130 jsPackSBits32 (
1131 JSBinOp "%" (
1132 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1133 ) (
1134 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1138 | (LSRem (ATInt (ITFixed IT64))) <- op
1139 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1141 | (LCompl (ITFixed IT8)) <- op
1142 , (arg:_) <- args =
1143 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1145 | (LCompl (ITFixed IT16)) <- op
1146 , (arg:_) <- args =
1147 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1149 | (LCompl (ITFixed IT32)) <- op
1150 , (arg:_) <- args =
1151 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1153 | (LCompl (ITFixed IT64)) <- op
1154 , (arg:_) <- args =
1155 invokeMeth arg "not" []
1157 | (LPlus _) <- op
1158 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1159 | (LMinus _) <- op
1160 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1161 | (LTimes _) <- op
1162 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1163 | (LSDiv _) <- op
1164 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1165 | (LSRem _) <- op
1166 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1167 | (LEq _) <- op
1168 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1169 | (LSLt _) <- op
1170 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1171 | (LSLe _) <- op
1172 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1173 | (LSGt _) <- op
1174 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1175 | (LSGe _) <- op
1176 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1177 | (LAnd _) <- op
1178 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1179 | (LOr _) <- op
1180 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1181 | (LXOr _) <- op
1182 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1183 | (LSHL _) <- op
1184 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1185 | (LASHR _) <- op
1186 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1187 | (LCompl _) <- op
1188 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1190 | LStrConcat <- op
1191 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1192 | LStrEq <- op
1193 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1194 | LStrLt <- op
1195 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1196 | LStrLen <- op
1197 , (arg:_) <- args = JSProj (translateReg arg) "length"
1198 | (LStrInt ITNative) <- op
1199 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1200 | (LIntStr ITNative) <- op
1201 , (arg:_) <- args = jsCall "String" [translateReg arg]
1202 | (LSExt ITNative ITBig) <- op
1203 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1204 | (LTrunc ITBig ITNative) <- op
1205 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1206 | (LIntStr ITBig) <- op
1207 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1208 | (LStrInt ITBig) <- op
1209 , (arg:_) <- args = jsBigInt $ translateReg arg
1210 | LFloatStr <- op
1211 , (arg:_) <- args = jsCall "String" [translateReg arg]
1212 | LStrFloat <- op
1213 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1214 | (LIntFloat ITNative) <- op
1215 , (arg:_) <- args = translateReg arg
1216 | (LIntFloat ITBig) <- op
1217 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1218 | (LFloatInt ITNative) <- op
1219 , (arg:_) <- args = translateReg arg
1220 | (LChInt ITNative) <- op
1221 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1222 | (LIntCh ITNative) <- op
1223 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1225 | LFExp <- op
1226 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1227 | LFLog <- op
1228 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1229 | LFSin <- op
1230 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1231 | LFCos <- op
1232 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1233 | LFTan <- op
1234 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1235 | LFASin <- op
1236 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1237 | LFACos <- op
1238 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1239 | LFATan <- op
1240 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1241 | LFSqrt <- op
1242 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1243 | LFFloor <- op
1244 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1245 | LFCeil <- op
1246 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1247 | LFNegate <- op
1248 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1250 | LStrCons <- op
1251 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1252 | LStrHead <- op
1253 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1254 | LStrRev <- op
1255 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1256 | LStrIndex <- op
1257 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1258 | LStrTail <- op
1259 , (arg:_) <- args =
1260 let v = translateReg arg in
1261 JSApp (JSProj v "substr") [
1262 JSNum (JSInt 1),
1263 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1266 | LSystemInfo <- op
1267 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1268 | LNullPtr <- op
1269 , (_) <- args = JSNull
1270 | otherwise = JSError $ "Not implemented: " ++ show op
1271 where
1272 translateBinaryOp :: String -> Reg -> Reg -> JS
1273 translateBinaryOp op lhs rhs =
1274 JSBinOp op (translateReg lhs) (translateReg rhs)
1276 invokeMeth :: Reg -> String -> [Reg] -> JS
1277 invokeMeth obj meth args =
1278 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1281jsRESERVE :: CompileInfo -> Int -> JS
1282jsRESERVE _ _ = JSNoop
1284jsSTACK :: JS
1285jsSTACK = JSIdent "i$valstack"
1287jsCALLSTACK :: JS
1288jsCALLSTACK = JSIdent "i$callstack"
1290jsSTACKBASE :: JS
1291jsSTACKBASE = JSIdent "i$valstack_base"
1293jsSTACKTOP :: JS
1294jsSTACKTOP = JSIdent "i$valstack_top"
1296jsOLDBASE :: JS
1297jsOLDBASE = JSIdent "oldbase"
1299jsMYOLDBASE :: JS
1300jsMYOLDBASE = JSIdent "myoldbase"
1302jsRET :: JS
1303jsRET = JSIdent "i$ret"
1305jsLOC :: Int -> JS
1306jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1307jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1309jsTOP :: Int -> JS
1310jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1311jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1313jsPUSH :: [JS] -> JS
1314jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1316jsPOP :: JS
1317jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1319translateBC :: CompileInfo -> BC -> JS
1320translateBC info bc
1321 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1322 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1323 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1324 | ADDTOP n <- bc = jsADDTOP info n
1325 | NULL r <- bc = jsNULL info r
1326 | CALL n <- bc = jsCALL info n
1327 | TAILCALL n <- bc = jsTAILCALL info n
1328 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1329 | TOPBASE n <- bc = jsTOPBASE info n
1330 | BASETOP n <- bc = jsBASETOP info n
1331 | STOREOLD <- bc = jsSTOREOLD info
1332 | SLIDE n <- bc = jsSLIDE info n
1333 | REBASE <- bc = jsREBASE info
1334 | RESERVE n <- bc = jsRESERVE info n
1335 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1336 | CASE s r c d <- bc = jsCASE info s r c d
1337 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1338 | PROJECT r l a <- bc = jsPROJECT info r l a
1339 | OP r o a <- bc = jsOP info r o a
1340 | ERROR e <- bc = jsERROR info e
1341 | otherwise = JSRaw $ "//" ++ show bc