git.iko.soy/Idris-dev
on 2cfbee4 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1279 lines 47 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
30import System.FilePath
32import qualified Data.Map.Strict as M
33import qualified Data.Text as T
34import qualified Data.Text.IO as TIO
37data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
38 , compileInfoEvalCases :: [Int]
39 , compileInfoNeedsBigInt :: Bool
40 }
43initCompileInfo :: [(Name, [BC])] -> CompileInfo
44initCompileInfo bc =
45 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
46 where
47 lookupBigInt :: [(Name, [BC])] -> Bool
48 lookupBigInt = any (needsBigInt . snd)
49 where
50 needsBigInt :: [BC] -> Bool
51 needsBigInt bc = any testBCForBigInt bc
52 where
53 testBCForBigInt :: BC -> Bool
54 testBCForBigInt (ASSIGNCONST _ c) =
55 testConstForBigInt c
57 testBCForBigInt (CONSTCASE _ c d) =
58 maybe False needsBigInt d
59 || any (needsBigInt . snd) c
60 || any (testConstForBigInt . fst) c
62 testBCForBigInt (CASE _ _ c d) =
63 maybe False needsBigInt d
64 || any (needsBigInt . snd) c
66 testBCForBigInt _ = False
68 testConstForBigInt :: Const -> Bool
69 testConstForBigInt (BI _) = True
70 testConstForBigInt (B64 _) = True
71 testConstForBigInt _ = False
74 collectCases :: String -> [(Name, [BC])] -> [Int]
75 collectCases fun bc = getCases $ findFunction fun bc
77 findFunction :: String -> [(Name, [BC])] -> [BC]
78 findFunction f ((MN 0 fun, bc):_)
79 | fun == txt f = bc
80 findFunction f (_:bc) = findFunction f bc
82 getCases :: [BC] -> [Int]
83 getCases = concatMap analyze
84 where
85 analyze :: BC -> [Int]
86 analyze (CASE _ _ b _) = map fst b
87 analyze _ = []
90data JSTarget = Node | JavaScript deriving Eq
93codegenJavaScript :: CodeGenerator
94codegenJavaScript ci =
95 codegenJS_all JavaScript (simpleDecls ci)
96 (includes ci) [] (outputFile ci) (outputType ci)
98codegenNode :: CodeGenerator
99codegenNode ci =
100 codegenJS_all Node (simpleDecls ci)
101 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
103codegenJS_all
104 :: JSTarget
105 -> [(Name, SDecl)]
106 -> [FilePath]
107 -> [String]
108 -> FilePath
109 -> OutputType
110 -> IO ()
111codegenJS_all target definitions includes libs filename outputType = do
112 let bytecode = map toBC definitions
113 let info = initCompileInfo bytecode
114 let js = concatMap (translateDecl info) bytecode
115 let full = concatMap processFunction js
116 let code = deadCodeElim full
117 let ext = takeExtension filename
118 let isHtml = target == JavaScript && ext == ".html"
119 let htmlPrologue = T.pack "<!doctype html><html><head><script>\n"
120 let htmlEpilogue = T.pack "\n</script></head><body></body></html>"
121 let (cons, opt) = optimizeConstructors code
122 let (header, rt) = case target of
123 Node -> ("#!/usr/bin/env node\n", "-node")
124 JavaScript -> ("", "-browser")
126 included <- concat <$> getIncludes includes
127 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
128 idrRuntime <- readFile $ path ++ "Runtime-common.js"
129 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
130 jsbn <- if compileInfoNeedsBigInt info
131 then readFile $ path ++ "jsbn/jsbn.js"
132 else return ""
133 let runtime = ( header
134 ++ includeLibs libs
135 ++ included
136 ++ jsbn
137 ++ idrRuntime
138 ++ tgtRuntime
139 )
140 let jsSource = T.pack runtime
141 `T.append` T.concat (map compileJS opt)
142 `T.append` T.concat (map compileJS cons)
143 `T.append` main
144 `T.append` invokeMain
145 let source = if isHtml
146 then htmlPrologue `T.append` jsSource `T.append` htmlEpilogue
147 else jsSource
148 writeSourceText filename source
149 setPermissions filename (emptyPermissions { readable = True
150 , executable = target == Node
151 , writable = True
152 })
153 where
154 deadCodeElim :: [JS] -> [JS]
155 deadCodeElim js = concatMap collectFunctions js
156 where
157 collectFunctions :: JS -> [JS]
158 collectFunctions fun@(JSAlloc name _)
159 | name == translateName (sMN 0 "runMain") = [fun]
161 collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =
162 let invokations = sum $ map (
163 \x -> execState (countInvokations name x) 0
164 ) js
165 in if invokations == 0
166 then []
167 else [fun]
169 countInvokations :: String -> JS -> State Int ()
170 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
171 countInvokations name body
173 countInvokations name (JSSeq seq) =
174 void $ traverse (countInvokations name) seq
176 countInvokations name (JSAssign _ rhs) =
177 countInvokations name rhs
179 countInvokations name (JSCond conds) =
180 void $ traverse (
181 runKleisli $ arr id *** Kleisli (countInvokations name)
182 ) conds
184 countInvokations name (JSSwitch _ conds def) =
185 void $ traverse (
186 runKleisli $ arr id *** Kleisli (countInvokations name)
187 ) conds >> traverse (countInvokations name) def
189 countInvokations name (JSApp lhs rhs) =
190 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
192 countInvokations name (JSNew _ args) =
193 void $ traverse (countInvokations name) args
195 countInvokations name (JSArray args) =
196 void $ traverse (countInvokations name) args
198 countInvokations name (JSIdent name')
199 | name == name' = get >>= put . (+1)
200 | otherwise = return ()
202 countInvokations _ _ = return ()
204 processFunction :: JS -> [JS]
205 processFunction =
206 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
208 includeLibs :: [String] -> String
209 includeLibs =
210 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
212 getIncludes :: [FilePath] -> IO [String]
213 getIncludes = mapM readFile
215 main :: T.Text
216 main =
217 compileJS $ JSAlloc "main" (Just $
218 JSFunction [] (
219 case target of
220 Node -> mainFun
221 JavaScript -> jsMain
222 )
223 )
225 jsMain :: JS
226 jsMain =
227 JSCond [ (exists document `jsAnd` isReady, mainFun)
228 , (exists window, windowMainFun)
229 , (JSTrue, mainFun)
230 ]
231 where
232 exists :: JS -> JS
233 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
235 window :: JS
236 window = JSIdent "window"
238 document :: JS
239 document = JSIdent "document"
241 windowMainFun :: JS
242 windowMainFun =
243 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
244 , JSFunction [] ( mainFun )
245 , JSFalse
246 ]
248 isReady :: JS
249 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
251 readyState :: JS
252 readyState = JSProj (JSIdent "document") "readyState"
254 mainFun :: JS
255 mainFun =
256 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
257 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
258 , JSApp (
259 JSIdent (translateName (sMN 0 "runMain"))
260 ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
261 , JSApp (JSIdent "i$RUN") []
262 ]
264 invokeMain :: T.Text
265 invokeMain = compileJS $ JSApp (JSIdent "main") []
267optimizeConstructors :: [JS] -> ([JS], [JS])
268optimizeConstructors js =
269 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
270 (map (allocCon . snd) (M.toList cons), js')
271 where
272 allocCon :: (String, JS) -> JS
273 allocCon (name, con) = JSAlloc name (Just con)
275 newConstructor :: Int -> String
276 newConstructor n = "i$CON$" ++ show n
278 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
279 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
280 , JSArray []
281 , a
282 , e
283 ]) = do
284 s <- get
285 case M.lookup tag s of
286 Just (i, c) -> return $ JSIdent i
287 Nothing -> do let n = newConstructor tag
288 put $ M.insert tag (n, js) s
289 return $ JSIdent n
291 optimizeConstructor' (JSSeq seq) =
292 JSSeq <$> traverse optimizeConstructor' seq
294 optimizeConstructor' (JSSwitch reg cond def) = do
295 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
296 def' <- traverse optimizeConstructor' def
297 return $ JSSwitch reg cond' def'
299 optimizeConstructor' (JSCond cond) =
300 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
302 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
303 body' <- optimizeConstructor' body
304 return $ JSAlloc fun (Just (JSFunction args body'))
306 optimizeConstructor' (JSAssign lhs rhs) = do
307 lhs' <- optimizeConstructor' lhs
308 rhs' <- optimizeConstructor' rhs
309 return $ JSAssign lhs' rhs'
311 optimizeConstructor' js = return js
313collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
314collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
315 where
316 generateSplitFunction :: (Int,JS) -> JS
317 generateSplitFunction (depth, JSAlloc name fun) =
318 JSAlloc (name ++ "$" ++ show depth) fun
320splitFunction :: JS -> RWS () [(Int,JS)] Int JS
321splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
322 body' <- splitSequence body
323 return $ JSAlloc name (Just (JSFunction args body'))
324 where
325 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
326 splitCondition js
327 | JSCond branches <- js =
328 JSCond <$> processBranches branches
329 | JSSwitch cond branches def <- js =
330 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
331 | otherwise = return js
332 where
333 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
334 processBranches =
335 traverse (runKleisli (arr id *** Kleisli splitSequence))
337 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
338 splitSequence js@(JSSeq seq) =
339 let (pre,post) = break isBranch seq in
340 case post of
341 [_] -> JSSeq <$> traverse splitCondition seq
342 [call@(JSCond _),rest@(JSApp _ _)] -> do
343 rest' <- splitCondition rest
344 call' <- splitCondition call
345 return $ JSSeq (pre ++ [rest', call'])
346 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
347 rest' <- splitCondition rest
348 call' <- splitCondition call
349 return $ JSSeq (pre ++ [rest', call'])
350 (call:rest) -> do
351 depth <- get
352 put (depth + 1)
353 new <- splitFunction (newFun rest)
354 tell [(depth, new)]
355 call' <- splitCondition call
356 return $ JSSeq (pre ++ (newCall depth : [call']))
357 _ -> JSSeq <$> traverse splitCondition seq
359 splitSequence js = return js
361 isBranch :: JS -> Bool
362 isBranch (JSApp (JSIdent "i$CALL") _) = True
363 isBranch (JSCond _) = True
364 isBranch (JSSwitch _ _ _) = True
365 isBranch _ = False
367 newCall :: Int -> JS
368 newCall depth =
369 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
370 , JSArray [jsOLDBASE, jsMYOLDBASE]
371 ]
373 newFun :: [JS] -> JS
374 newFun seq =
375 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
377splitFunction js = return js
379translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
380translateDecl info (name@(MN 0 fun), bc)
381 | txt "APPLY" == fun =
382 allocCaseFunctions (snd body)
383 ++ [ JSAlloc (
384 translateName name
385 ) (Just $ JSFunction ["oldbase"] (
386 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
387 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
388 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
389 )
390 , ( JSNoop
391 , JSSeq $ map (translateBC info) (defaultCase (snd body))
392 )
393 ]
394 ]
395 )
396 )
397 ]
399 | txt "EVAL" == fun =
400 allocCaseFunctions (snd body)
401 ++ [ JSAlloc (
402 translateName name
403 ) (Just $ JSFunction ["oldbase"] (
404 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
405 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
406 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
407 )
408 , ( JSNoop
409 , JSSeq $ map (translateBC info) (defaultCase (snd body))
410 )
411 ]
412 ]
413 )
414 )
415 ]
416 where
417 body :: ([BC], [BC])
418 body = break isCase bc
420 isCase :: BC -> Bool
421 isCase bc
422 | CASE {} <- bc = True
423 | otherwise = False
425 defaultCase :: [BC] -> [BC]
426 defaultCase ((CASE _ _ _ (Just d)):_) = d
428 caseReg :: [BC] -> Reg
429 caseReg ((CASE _ r _ _):_) = r
431 allocCaseFunctions :: [BC] -> [JS]
432 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
433 allocCaseFunctions _ = []
435 splitBranches :: [(Int, [BC])] -> [JS]
436 splitBranches = map prepBranch
438 prepBranch :: (Int, [BC]) -> JS
439 prepBranch (tag, code) =
440 JSAlloc (
441 translateName name ++ "$" ++ show tag
442 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
443 JSSeq $ map (translateBC info) code
444 )
445 )
447translateDecl info (name, bc) =
448 [ JSAlloc (
449 translateName name
450 ) (Just $ JSFunction ["oldbase"] (
451 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
452 )
453 )
454 ]
456jsFUNPRELUDE :: [JS]
457jsFUNPRELUDE = [jsALLOCMYOLDBASE]
459jsALLOCMYOLDBASE :: JS
460jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
462translateReg :: Reg -> JS
463translateReg reg
464 | RVal <- reg = jsRET
465 | Tmp <- reg = JSRaw "//TMPREG"
466 | L n <- reg = jsLOC n
467 | T n <- reg = jsTOP n
469translateConstant :: Const -> JS
470translateConstant (I i) = JSNum (JSInt i)
471translateConstant (Fl f) = JSNum (JSFloat f)
472translateConstant (Ch c) = JSString $ translateChar c
473translateConstant (Str s) = JSString $ concatMap translateChar s
474translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
475translateConstant StrType = JSType JSStringTy
476translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
477translateConstant (AType ATFloat) = JSType JSFloatTy
478translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
479translateConstant Forgot = JSType JSForgotTy
480translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
481translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
482translateConstant (BI i) = jsBigInt (JSString $ show i)
483translateConstant (B8 b) = JSWord (JSWord8 b)
484translateConstant (B16 b) = JSWord (JSWord16 b)
485translateConstant (B32 b) = JSWord (JSWord32 b)
486translateConstant (B64 b) = JSWord (JSWord64 b)
487translateConstant c =
488 JSError $ "Unimplemented Constant: " ++ show c
491translateChar :: Char -> String
492translateChar ch
493 | '\a' <- ch = "\\u0007"
494 | '\b' <- ch = "\\b"
495 | '\f' <- ch = "\\f"
496 | '\n' <- ch = "\\n"
497 | '\r' <- ch = "\\r"
498 | '\t' <- ch = "\\t"
499 | '\v' <- ch = "\\v"
500 | '\SO' <- ch = "\\u000E"
501 | '\DEL' <- ch = "\\u007F"
502 | '\\' <- ch = "\\\\"
503 | '\"' <- ch = "\\\""
504 | '\'' <- ch = "\\\'"
505 | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
506 | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
507 | otherwise = [ch]
508 where
509 fill :: String -> String
510 fill s = case length s of
511 1 -> "000" ++ s
512 2 -> "00" ++ s
513 3 -> "0" ++ s
514 _ -> s
516 asciiTab =
517 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
518 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
519 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
520 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
522translateName :: Name -> String
523translateName n = "_idris_" ++ concatMap cchar (showCG n)
524 where cchar x | isAlphaNum x = [x]
525 | otherwise = "_" ++ show (fromEnum x) ++ "_"
527jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
528jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
530jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
531jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
533jsCALL :: CompileInfo -> Name -> JS
534jsCALL _ n =
535 JSApp (
536 JSIdent "i$CALL"
537 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
539jsTAILCALL :: CompileInfo -> Name -> JS
540jsTAILCALL _ n =
541 JSApp (
542 JSIdent "i$CALL"
543 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
545jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
546jsFOREIGN _ reg n args
547 | n == "isNull"
548 , [(FPtr, arg)] <- args =
549 JSAssign (
550 translateReg reg
551 ) (
552 JSBinOp "==" (translateReg arg) JSNull
553 )
555 | n == "idris_eqPtr"
556 , [(_, lhs),(_, rhs)] <- args =
557 JSAssign (
558 translateReg reg
559 ) (
560 JSBinOp "==" (translateReg lhs) (translateReg rhs)
561 )
562 | otherwise =
563 JSAssign (
564 translateReg reg
565 ) (
566 JSFFI n (map generateWrapper args)
567 )
568 where
569 generateWrapper :: (FType, Reg) -> JS
570 generateWrapper (ty, reg)
571 | FFunction <- ty =
572 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
573 , JSIdent "oldbase"
574 , JSIdent "myoldbase"
575 ]
576 | FFunctionIO <- ty =
577 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
578 , JSIdent "oldbase"
579 , JSIdent "myoldbase"
580 ]
582 generateWrapper (_, reg) =
583 translateReg reg
585jsREBASE :: CompileInfo -> JS
586jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
588jsSTOREOLD :: CompileInfo ->JS
589jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
591jsADDTOP :: CompileInfo -> Int -> JS
592jsADDTOP info n
593 | 0 <- n = JSNoop
594 | otherwise =
595 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
597jsTOPBASE :: CompileInfo -> Int -> JS
598jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
599jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
602jsBASETOP :: CompileInfo -> Int -> JS
603jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
604jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
606jsNULL :: CompileInfo -> Reg -> JS
607jsNULL _ r = JSClear (translateReg r)
609jsERROR :: CompileInfo -> String -> JS
610jsERROR _ = JSError
612jsSLIDE :: CompileInfo -> Int -> JS
613jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
614jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
616jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
617jsMKCON info r t rs =
618 JSAssign (translateReg r) (
619 JSNew "i$CON" [ JSNum (JSInt t)
620 , JSArray (map translateReg rs)
621 , if t `elem` compileInfoApplyCases info
622 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
623 else JSNull
624 , if t `elem` compileInfoEvalCases info
625 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
626 else JSNull
627 ]
628 )
630jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
631jsCASE info safe reg cases def =
632 JSSwitch (tag safe $ translateReg reg) (
633 map ((JSNum . JSInt) *** prepBranch) cases
634 ) (fmap prepBranch def)
635 where
636 tag :: Bool -> JS -> JS
637 tag True = jsCTAG
638 tag False = jsTAG
640 prepBranch :: [BC] -> JS
641 prepBranch bc = JSSeq $ map (translateBC info) bc
643 jsTAG :: JS -> JS
644 jsTAG js =
645 (JSTernary (js `jsInstanceOf` "i$CON") (
646 JSProj js "tag"
647 ) (JSNum (JSInt $ negate 1)))
649 jsCTAG :: JS -> JS
650 jsCTAG js = JSProj js "tag"
653jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
654jsCONSTCASE info reg cases def =
655 JSCond $ (
656 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
657 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
658 where
659 prepBranch :: [BC] -> JS
660 prepBranch bc = JSSeq $ map (translateBC info) bc
662jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
663jsPROJECT _ reg loc 0 = JSNoop
664jsPROJECT _ reg loc 1 =
665 JSAssign (jsLOC loc) (
666 JSIndex (
667 JSProj (translateReg reg) "args"
668 ) (
669 JSNum (JSInt 0)
670 )
671 )
672jsPROJECT _ reg loc ar =
673 JSApp (JSIdent "i$PROJECT") [ translateReg reg
674 , JSNum (JSInt loc)
675 , JSNum (JSInt ar)
676 ]
678jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
679jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
680 where
681 jsOP' :: JS
682 jsOP'
683 | LNoOp <- op = translateReg (last args)
685 | LWriteStr <- op,
686 (_:str:_) <- args = JSApp (JSIdent "i$putStr") [translateReg str]
688 | LReadStr <- op = JSApp (JSIdent "i$getLine") []
690 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
691 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
692 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
694 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
695 | (LPlus (ATInt ITBig)) <- op
696 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
697 | (LMinus (ATInt ITBig)) <- op
698 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
699 | (LTimes (ATInt ITBig)) <- op
700 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
701 | (LSDiv (ATInt ITBig)) <- op
702 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
703 | (LSRem (ATInt ITBig)) <- op
704 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
705 | (LEq (ATInt ITBig)) <- op
706 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
707 | (LSLt (ATInt ITBig)) <- op
708 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
709 | (LSLe (ATInt ITBig)) <- op
710 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
711 | (LSGt (ATInt ITBig)) <- op
712 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
713 | (LSGe (ATInt ITBig)) <- op
714 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
716 | (LPlus ATFloat) <- op
717 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
718 | (LMinus ATFloat) <- op
719 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
720 | (LTimes ATFloat) <- op
721 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
722 | (LSDiv ATFloat) <- op
723 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
724 | (LEq ATFloat) <- op
725 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
726 | (LSLt ATFloat) <- op
727 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
728 | (LSLe ATFloat) <- op
729 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
730 | (LSGt ATFloat) <- op
731 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
732 | (LSGe ATFloat) <- op
733 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
735 | (LPlus (ATInt ITChar)) <- op
736 , (lhs:rhs:_) <- args =
737 jsCall "i$fromCharCode" [
738 JSBinOp "+" (
739 jsCall "i$charCode" [translateReg lhs]
740 ) (
741 jsCall "i$charCode" [translateReg rhs]
742 )
743 ]
745 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
746 , (arg:_) <- args =
747 jsPackUBits8 (
748 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
749 )
751 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
752 , (arg:_) <- args =
753 jsPackUBits16 (
754 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
755 )
757 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
758 , (arg:_) <- args =
759 jsPackUBits32 (
760 jsMeth (jsMeth (translateReg arg) "and" [
761 jsBigInt (JSString $ show 0xFFFFFFFF)
762 ]) "intValue" []
763 )
765 | (LTrunc ITBig (ITFixed IT64)) <- op
766 , (arg:_) <- args =
767 jsMeth (translateReg arg) "and" [
768 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
769 ]
771 | (LLSHR (ITFixed IT8)) <- op
772 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs
774 | (LLSHR (ITFixed IT16)) <- op
775 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs
777 | (LLSHR (ITFixed IT32)) <- op
778 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs
780 | (LLSHR (ITFixed IT64)) <- op
781 , (lhs:rhs:_) <- args =
782 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
784 | (LSHL (ITFixed IT8)) <- op
785 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs
787 | (LSHL (ITFixed IT16)) <- op
788 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs
790 | (LSHL (ITFixed IT32)) <- op
791 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs
793 | (LSHL (ITFixed IT64)) <- op
794 , (lhs:rhs:_) <- args =
795 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
796 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
797 ]
799 | (LAnd (ITFixed IT8)) <- op
800 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs
802 | (LAnd (ITFixed IT16)) <- op
803 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs
805 | (LAnd (ITFixed IT32)) <- op
806 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs
808 | (LAnd (ITFixed IT64)) <- op
809 , (lhs:rhs:_) <- args =
810 jsMeth (translateReg lhs) "and" [translateReg rhs]
812 | (LOr (ITFixed IT8)) <- op
813 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs
815 | (LOr (ITFixed IT16)) <- op
816 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs
818 | (LOr (ITFixed IT32)) <- op
819 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs
821 | (LOr (ITFixed IT64)) <- op
822 , (lhs:rhs:_) <- args =
823 jsMeth (translateReg lhs) "or" [translateReg rhs]
825 | (LXOr (ITFixed IT8)) <- op
826 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs
828 | (LXOr (ITFixed IT16)) <- op
829 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs
831 | (LXOr (ITFixed IT32)) <- op
832 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs
834 | (LXOr (ITFixed IT64)) <- op
835 , (lhs:rhs:_) <- args =
836 jsMeth (translateReg lhs) "xor" [translateReg rhs]
838 | (LPlus (ATInt (ITFixed IT8))) <- op
839 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs
841 | (LPlus (ATInt (ITFixed IT16))) <- op
842 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs
844 | (LPlus (ATInt (ITFixed IT32))) <- op
845 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs
847 | (LPlus (ATInt (ITFixed IT64))) <- op
848 , (lhs:rhs:_) <- args =
849 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
850 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
851 ]
853 | (LMinus (ATInt (ITFixed IT8))) <- op
854 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs
856 | (LMinus (ATInt (ITFixed IT16))) <- op
857 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs
859 | (LMinus (ATInt (ITFixed IT32))) <- op
860 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs
862 | (LMinus (ATInt (ITFixed IT64))) <- op
863 , (lhs:rhs:_) <- args =
864 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
865 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
866 ]
868 | (LTimes (ATInt (ITFixed IT8))) <- op
869 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs
871 | (LTimes (ATInt (ITFixed IT16))) <- op
872 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs
874 | (LTimes (ATInt (ITFixed IT32))) <- op
875 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs
877 | (LTimes (ATInt (ITFixed IT64))) <- op
878 , (lhs:rhs:_) <- args =
879 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
880 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
881 ]
883 | (LEq (ATInt (ITFixed IT8))) <- op
884 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
886 | (LEq (ATInt (ITFixed IT16))) <- op
887 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
889 | (LEq (ATInt (ITFixed IT32))) <- op
890 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
892 | (LEq (ATInt (ITFixed IT64))) <- op
893 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
895 | (LLt (ITFixed IT8)) <- op
896 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
898 | (LLt (ITFixed IT16)) <- op
899 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
901 | (LLt (ITFixed IT32)) <- op
902 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
904 | (LLt (ITFixed IT64)) <- op
905 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
907 | (LLe (ITFixed IT8)) <- op
908 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
910 | (LLe (ITFixed IT16)) <- op
911 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
913 | (LLe (ITFixed IT32)) <- op
914 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
916 | (LLe (ITFixed IT64)) <- op
917 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
919 | (LGt (ITFixed IT8)) <- op
920 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
922 | (LGt (ITFixed IT16)) <- op
923 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
924 | (LGt (ITFixed IT32)) <- op
925 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
927 | (LGt (ITFixed IT64)) <- op
928 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
930 | (LGe (ITFixed IT8)) <- op
931 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
933 | (LGe (ITFixed IT16)) <- op
934 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
935 | (LGe (ITFixed IT32)) <- op
936 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
938 | (LGe (ITFixed IT64)) <- op
939 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
941 | (LUDiv (ITFixed IT8)) <- op
942 , (lhs:rhs:_) <- args =
943 jsPackUBits8 (
944 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
945 )
947 | (LUDiv (ITFixed IT16)) <- op
948 , (lhs:rhs:_) <- args =
949 jsPackUBits16 (
950 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
951 )
953 | (LUDiv (ITFixed IT32)) <- op
954 , (lhs:rhs:_) <- args =
955 jsPackUBits32 (
956 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
957 )
959 | (LUDiv (ITFixed IT64)) <- op
960 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
962 | (LSDiv (ATInt (ITFixed IT8))) <- op
963 , (lhs:rhs:_) <- args =
964 jsPackSBits8 (
965 JSBinOp "/" (
966 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
967 ) (
968 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
969 )
970 )
972 | (LSDiv (ATInt (ITFixed IT16))) <- op
973 , (lhs:rhs:_) <- args =
974 jsPackSBits16 (
975 JSBinOp "/" (
976 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
977 ) (
978 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
979 )
980 )
982 | (LSDiv (ATInt (ITFixed IT32))) <- op
983 , (lhs:rhs:_) <- args =
984 jsPackSBits32 (
985 JSBinOp "/" (
986 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
987 ) (
988 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
989 )
990 )
992 | (LSDiv (ATInt (ITFixed IT64))) <- op
993 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
995 | (LSRem (ATInt (ITFixed IT8))) <- op
996 , (lhs:rhs:_) <- args =
997 jsPackSBits8 (
998 JSBinOp "%" (
999 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1000 ) (
1001 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1005 | (LSRem (ATInt (ITFixed IT16))) <- op
1006 , (lhs:rhs:_) <- args =
1007 jsPackSBits16 (
1008 JSBinOp "%" (
1009 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1010 ) (
1011 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1015 | (LSRem (ATInt (ITFixed IT32))) <- op
1016 , (lhs:rhs:_) <- args =
1017 jsPackSBits32 (
1018 JSBinOp "%" (
1019 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1020 ) (
1021 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1025 | (LSRem (ATInt (ITFixed IT64))) <- op
1026 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1028 | (LCompl (ITFixed IT8)) <- op
1029 , (arg:_) <- args =
1030 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1032 | (LCompl (ITFixed IT16)) <- op
1033 , (arg:_) <- args =
1034 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1036 | (LCompl (ITFixed IT32)) <- op
1037 , (arg:_) <- args =
1038 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1040 | (LCompl (ITFixed IT64)) <- op
1041 , (arg:_) <- args = invokeMeth arg "not" []
1043 | (LPlus _) <- op
1044 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1045 | (LMinus _) <- op
1046 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1047 | (LTimes _) <- op
1048 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1049 | (LSDiv _) <- op
1050 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1051 | (LSRem _) <- op
1052 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1053 | (LEq _) <- op
1054 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1055 | (LSLt _) <- op
1056 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1057 | (LSLe _) <- op
1058 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
1059 | (LSGt _) <- op
1060 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
1061 | (LSGe _) <- op
1062 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
1063 | (LAnd _) <- op
1064 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1065 | (LOr _) <- op
1066 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1067 | (LXOr _) <- op
1068 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1069 | (LSHL _) <- op
1070 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1071 | (LASHR _) <- op
1072 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1073 | (LCompl _) <- op
1074 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1076 | LStrConcat <- op
1077 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1078 | LStrEq <- op
1079 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1080 | LStrLt <- op
1081 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1082 | LStrLen <- op
1083 , (arg:_) <- args = JSProj (translateReg arg) "length"
1084 | (LStrInt ITNative) <- op
1085 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1086 | (LIntStr ITNative) <- op
1087 , (arg:_) <- args = jsCall "String" [translateReg arg]
1088 | (LSExt ITNative ITBig) <- op
1089 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1090 | (LTrunc ITBig ITNative) <- op
1091 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1092 | (LIntStr ITBig) <- op
1093 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1094 | (LStrInt ITBig) <- op
1095 , (arg:_) <- args = jsBigInt $ translateReg arg
1096 | LFloatStr <- op
1097 , (arg:_) <- args = jsCall "String" [translateReg arg]
1098 | LStrFloat <- op
1099 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1100 | (LIntFloat ITNative) <- op
1101 , (arg:_) <- args = translateReg arg
1102 | (LIntFloat ITBig) <- op
1103 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1104 | (LFloatInt ITNative) <- op
1105 , (arg:_) <- args = translateReg arg
1106 | (LChInt ITNative) <- op
1107 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1108 | (LIntCh ITNative) <- op
1109 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1111 | LFExp <- op
1112 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1113 | LFLog <- op
1114 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1115 | LFSin <- op
1116 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1117 | LFCos <- op
1118 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1119 | LFTan <- op
1120 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1121 | LFASin <- op
1122 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1123 | LFACos <- op
1124 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1125 | LFATan <- op
1126 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1127 | LFSqrt <- op
1128 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1129 | LFFloor <- op
1130 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1131 | LFCeil <- op
1132 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1133 | LFNegate <- op
1134 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1136 | LStrCons <- op
1137 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1138 | LStrHead <- op
1139 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1140 | LStrRev <- op
1141 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1142 | LStrIndex <- op
1143 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1144 | LStrTail <- op
1145 , (arg:_) <- args =
1146 let v = translateReg arg in
1147 JSApp (JSProj v "substr") [
1148 JSNum (JSInt 1),
1149 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1151 | LStrSubstr <- op
1152 , (offset:length:string:_) <- args =
1153 let off = translateReg offset
1154 len = translateReg length
1155 str = translateReg string
1156 in JSApp (JSProj str "substr") [
1157 jsCall "Math.max" [JSNum (JSInt 0), off],
1158 jsCall "Math.max" [JSNum (JSInt 0), len]
1161 | LSystemInfo <- op
1162 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1163 | LExternal nul <- op
1164 , nul == sUN "prim__null"
1165 , _ <- args = JSNull
1166 | LExternal ex <- op
1167 , ex == sUN "prim__eqPtr"
1168 , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs
1169 | otherwise = JSError $ "Not implemented: " ++ show op
1170 where
1171 translateBinaryOp :: String -> Reg -> Reg -> JS
1172 translateBinaryOp op lhs rhs =
1173 JSBinOp op (translateReg lhs) (translateReg rhs)
1175 translateCompareOp :: String -> Reg -> Reg -> JS
1176 translateCompareOp op lhs rhs =
1177 JSPreOp "+" $ translateBinaryOp op lhs rhs
1179 bitsBinaryOp :: String -> Reg -> Reg -> JS
1180 bitsBinaryOp op lhs rhs =
1181 JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1183 bitsCompareOp :: String -> Reg -> Reg -> JS
1184 bitsCompareOp op lhs rhs =
1185 JSPreOp "+" $ bitsBinaryOp op lhs rhs
1187 invokeMeth :: Reg -> String -> [Reg] -> JS
1188 invokeMeth obj meth args =
1189 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1192jsRESERVE :: CompileInfo -> Int -> JS
1193jsRESERVE _ _ = JSNoop
1195jsSTACK :: JS
1196jsSTACK = JSIdent "i$valstack"
1198jsCALLSTACK :: JS
1199jsCALLSTACK = JSIdent "i$callstack"
1201jsSTACKBASE :: JS
1202jsSTACKBASE = JSIdent "i$valstack_base"
1204jsSTACKTOP :: JS
1205jsSTACKTOP = JSIdent "i$valstack_top"
1207jsOLDBASE :: JS
1208jsOLDBASE = JSIdent "oldbase"
1210jsMYOLDBASE :: JS
1211jsMYOLDBASE = JSIdent "myoldbase"
1213jsRET :: JS
1214jsRET = JSIdent "i$ret"
1216jsLOC :: Int -> JS
1217jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1218jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1220jsTOP :: Int -> JS
1221jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1222jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1224jsPUSH :: [JS] -> JS
1225jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1227jsPOP :: JS
1228jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1230translateBC :: CompileInfo -> BC -> JS
1231translateBC info bc
1232 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1233 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1234 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1235 | ADDTOP n <- bc = jsADDTOP info n
1236 | NULL r <- bc = jsNULL info r
1237 | CALL n <- bc = jsCALL info n
1238 | TAILCALL n <- bc = jsTAILCALL info n
1239 | FOREIGNCALL r _ (FStr n) args
1240 <- bc = jsFOREIGN info r n (map fcall args)
1241 | FOREIGNCALL _ _ _ _ <- bc = error "JS FFI call not statically known"
1242 | TOPBASE n <- bc = jsTOPBASE info n
1243 | BASETOP n <- bc = jsBASETOP info n
1244 | STOREOLD <- bc = jsSTOREOLD info
1245 | SLIDE n <- bc = jsSLIDE info n
1246 | REBASE <- bc = jsREBASE info
1247 | RESERVE n <- bc = jsRESERVE info n
1248 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1249 | CASE s r c d <- bc = jsCASE info s r c d
1250 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1251 | PROJECT r l a <- bc = jsPROJECT info r l a
1252 | OP r o a <- bc = jsOP info r o a
1253 | ERROR e <- bc = jsERROR info e
1254 | otherwise = JSRaw $ "//" ++ show bc
1255 where fcall (t, arg) = (toFType t, arg)
1257toAType (FCon i)
1258 | i == sUN "JS_IntChar" = ATInt ITChar
1259 | i == sUN "JS_IntNative" = ATInt ITNative
1260toAType t = error (show t ++ " not defined in toAType")
1262toFnType (FApp c [_,_,s,t])
1263 | c == sUN "JS_Fn" = toFnType t
1264toFnType (FApp c [_,_,r])
1265 | c == sUN "JS_FnIO" = FFunctionIO
1266toFnType (FApp c [_,r])
1267 | c == sUN "JS_FnBase" = FFunction
1268toFnType t = error (show t ++ " not defined in toFnType")
1270toFType (FCon c)
1271 | c == sUN "JS_Str" = FString
1272 | c == sUN "JS_Float" = FArith ATFloat
1273 | c == sUN "JS_Ptr" = FPtr
1274 | c == sUN "JS_Unit" = FUnit
1275toFType (FApp c [_,ity])
1276 | c == sUN "JS_IntT" = FArith (toAType ity)
1277toFType (FApp c [_,fty])
1278 | c == sUN "JS_FnT" = toFnType fty
1279toFType t = error (show t ++ " not yet defined in toFType")