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