git.iko.soy/Idris-dev
on 76bb5f7 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1289 lines 47 kB history raw
1{-|
2Module : IRTS.CodegenJavaScript
3Description : The JavaScript code generator.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE OverloadedStrings #-}
10module IRTS.CodegenJavaScript (codegenJavaScript
11 , codegenNode
12 , JSTarget(..)
13 ) where
15import IRTS.JavaScript.AST
17import Idris.AbsSyntax hiding (TypeCase)
18import IRTS.Bytecode
19import IRTS.Lang
20import IRTS.Simplified
21import IRTS.Defunctionalise
22import IRTS.CodegenCommon
23import Idris.Core.TT
24import IRTS.System
25import Util.System
27import Control.Arrow
28import Control.Monad (mapM)
29import Control.Applicative ((<$>), (<*>), pure)
30import Control.Monad.RWS hiding (mapM)
31import Control.Monad.State
32import Data.Char
33import Numeric
34import Data.List
35import Data.Maybe
36import Data.Word
37import Data.Traversable hiding (mapM)
38import System.IO
39import System.Directory
40import System.FilePath
42import qualified Data.Map.Strict as M
43import qualified Data.Text as T
44import qualified Data.Text.IO as TIO
47data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
48 , compileInfoEvalCases :: [Int]
49 , compileInfoNeedsBigInt :: Bool
50 }
53initCompileInfo :: [(Name, [BC])] -> CompileInfo
54initCompileInfo bc =
55 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
56 where
57 lookupBigInt :: [(Name, [BC])] -> Bool
58 lookupBigInt = any (needsBigInt . snd)
59 where
60 needsBigInt :: [BC] -> Bool
61 needsBigInt bc = any testBCForBigInt bc
62 where
63 testBCForBigInt :: BC -> Bool
64 testBCForBigInt (ASSIGNCONST _ c) =
65 testConstForBigInt c
67 testBCForBigInt (CONSTCASE _ c d) =
68 maybe False needsBigInt d
69 || any (needsBigInt . snd) c
70 || any (testConstForBigInt . fst) c
72 testBCForBigInt (CASE _ _ c d) =
73 maybe False needsBigInt d
74 || any (needsBigInt . snd) c
76 testBCForBigInt _ = False
78 testConstForBigInt :: Const -> Bool
79 testConstForBigInt (BI _) = True
80 testConstForBigInt (B64 _) = True
81 testConstForBigInt _ = False
84 collectCases :: String -> [(Name, [BC])] -> [Int]
85 collectCases fun bc = getCases $ findFunction fun bc
87 findFunction :: String -> [(Name, [BC])] -> [BC]
88 findFunction f ((MN 0 fun, bc):_)
89 | fun == txt f = bc
90 findFunction f (_:bc) = findFunction f bc
92 getCases :: [BC] -> [Int]
93 getCases = concatMap analyze
94 where
95 analyze :: BC -> [Int]
96 analyze (CASE _ _ b _) = map fst b
97 analyze _ = []
100data JSTarget = Node | JavaScript deriving Eq
103codegenJavaScript :: CodeGenerator
104codegenJavaScript ci =
105 codegenJS_all JavaScript (simpleDecls ci)
106 (includes ci) [] (outputFile ci) (outputType ci)
108codegenNode :: CodeGenerator
109codegenNode ci =
110 codegenJS_all Node (simpleDecls ci)
111 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
113codegenJS_all
114 :: JSTarget
115 -> [(Name, SDecl)]
116 -> [FilePath]
117 -> [String]
118 -> FilePath
119 -> OutputType
120 -> IO ()
121codegenJS_all target definitions includes libs filename outputType = do
122 let bytecode = map toBC definitions
123 let info = initCompileInfo bytecode
124 let js = concatMap (translateDecl info) bytecode
125 let full = concatMap processFunction js
126 let code = deadCodeElim full
127 let ext = takeExtension filename
128 let isHtml = target == JavaScript && ext == ".html"
129 let htmlPrologue = T.pack "<!doctype html><html><head><script>\n"
130 let htmlEpilogue = T.pack "\n</script></head><body></body></html>"
131 let (cons, opt) = optimizeConstructors code
132 let (header, rt) = case target of
133 Node -> ("#!/usr/bin/env node\n", "-node")
134 JavaScript -> ("", "-browser")
136 included <- concat <$> getIncludes includes
137 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
138 idrRuntime <- readFile $ path ++ "Runtime-common.js"
139 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
140 jsbn <- if compileInfoNeedsBigInt info
141 then readFile $ path ++ "jsbn/jsbn.js"
142 else return ""
143 let runtime = ( header
144 ++ includeLibs libs
145 ++ included
146 ++ jsbn
147 ++ idrRuntime
148 ++ tgtRuntime
149 )
150 let jsSource = T.pack runtime
151 `T.append` T.concat (map compileJS opt)
152 `T.append` T.concat (map compileJS cons)
153 `T.append` main
154 `T.append` invokeMain
155 let source = if isHtml
156 then htmlPrologue `T.append` jsSource `T.append` htmlEpilogue
157 else jsSource
158 writeSourceText filename source
159 setPermissions filename (emptyPermissions { readable = True
160 , executable = target == Node
161 , writable = True
162 })
163 where
164 deadCodeElim :: [JS] -> [JS]
165 deadCodeElim js = concatMap collectFunctions js
166 where
167 collectFunctions :: JS -> [JS]
168 collectFunctions fun@(JSAlloc name _)
169 | name == translateName (sMN 0 "runMain") = [fun]
171 collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =
172 let invokations = sum $ map (
173 \x -> execState (countInvokations name x) 0
174 ) js
175 in if invokations == 0
176 then []
177 else [fun]
179 countInvokations :: String -> JS -> State Int ()
180 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
181 countInvokations name body
183 countInvokations name (JSSeq seq) =
184 void $ traverse (countInvokations name) seq
186 countInvokations name (JSAssign _ rhs) =
187 countInvokations name rhs
189 countInvokations name (JSCond conds) =
190 void $ traverse (
191 runKleisli $ arr id *** Kleisli (countInvokations name)
192 ) conds
194 countInvokations name (JSSwitch _ conds def) =
195 void $ traverse (
196 runKleisli $ arr id *** Kleisli (countInvokations name)
197 ) conds >> traverse (countInvokations name) def
199 countInvokations name (JSApp lhs rhs) =
200 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
202 countInvokations name (JSNew _ args) =
203 void $ traverse (countInvokations name) args
205 countInvokations name (JSArray args) =
206 void $ traverse (countInvokations name) args
208 countInvokations name (JSIdent name')
209 | name == name' = get >>= put . (+1)
210 | otherwise = return ()
212 countInvokations _ _ = return ()
214 processFunction :: JS -> [JS]
215 processFunction =
216 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
218 includeLibs :: [String] -> String
219 includeLibs =
220 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
222 getIncludes :: [FilePath] -> IO [String]
223 getIncludes = mapM readFile
225 main :: T.Text
226 main =
227 compileJS $ JSAlloc "main" (Just $
228 JSFunction [] (
229 case target of
230 Node -> mainFun
231 JavaScript -> jsMain
232 )
233 )
235 jsMain :: JS
236 jsMain =
237 JSCond [ (exists document `jsAnd` isReady, mainFun)
238 , (exists window, windowMainFun)
239 , (JSTrue, mainFun)
240 ]
241 where
242 exists :: JS -> JS
243 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
245 window :: JS
246 window = JSIdent "window"
248 document :: JS
249 document = JSIdent "document"
251 windowMainFun :: JS
252 windowMainFun =
253 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
254 , JSFunction [] ( mainFun )
255 , JSFalse
256 ]
258 isReady :: JS
259 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
261 readyState :: JS
262 readyState = JSProj (JSIdent "document") "readyState"
264 mainFun :: JS
265 mainFun =
266 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
267 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
268 , JSApp (
269 JSIdent (translateName (sMN 0 "runMain"))
270 ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
271 , JSApp (JSIdent "i$RUN") []
272 ]
274 invokeMain :: T.Text
275 invokeMain = compileJS $ JSApp (JSIdent "main") []
277optimizeConstructors :: [JS] -> ([JS], [JS])
278optimizeConstructors js =
279 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
280 (map (allocCon . snd) (M.toList cons), js')
281 where
282 allocCon :: (String, JS) -> JS
283 allocCon (name, con) = JSAlloc name (Just con)
285 newConstructor :: Int -> String
286 newConstructor n = "i$CON$" ++ show n
288 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
289 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
290 , JSArray []
291 , a
292 , e
293 ]) = do
294 s <- get
295 case M.lookup tag s of
296 Just (i, c) -> return $ JSIdent i
297 Nothing -> do let n = newConstructor tag
298 put $ M.insert tag (n, js) s
299 return $ JSIdent n
301 optimizeConstructor' (JSSeq seq) =
302 JSSeq <$> traverse optimizeConstructor' seq
304 optimizeConstructor' (JSSwitch reg cond def) = do
305 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
306 def' <- traverse optimizeConstructor' def
307 return $ JSSwitch reg cond' def'
309 optimizeConstructor' (JSCond cond) =
310 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
312 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
313 body' <- optimizeConstructor' body
314 return $ JSAlloc fun (Just (JSFunction args body'))
316 optimizeConstructor' (JSAssign lhs rhs) = do
317 lhs' <- optimizeConstructor' lhs
318 rhs' <- optimizeConstructor' rhs
319 return $ JSAssign lhs' rhs'
321 optimizeConstructor' js = return js
323collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
324collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
325 where
326 generateSplitFunction :: (Int,JS) -> JS
327 generateSplitFunction (depth, JSAlloc name fun) =
328 JSAlloc (name ++ "$" ++ show depth) fun
330splitFunction :: JS -> RWS () [(Int,JS)] Int JS
331splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
332 body' <- splitSequence body
333 return $ JSAlloc name (Just (JSFunction args body'))
334 where
335 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
336 splitCondition js
337 | JSCond branches <- js =
338 JSCond <$> processBranches branches
339 | JSSwitch cond branches def <- js =
340 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
341 | otherwise = return js
342 where
343 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
344 processBranches =
345 traverse (runKleisli (arr id *** Kleisli splitSequence))
347 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
348 splitSequence js@(JSSeq seq) =
349 let (pre,post) = break isBranch seq in
350 case post of
351 [_] -> JSSeq <$> traverse splitCondition seq
352 [call@(JSCond _),rest@(JSApp _ _)] -> do
353 rest' <- splitCondition rest
354 call' <- splitCondition call
355 return $ JSSeq (pre ++ [rest', call'])
356 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
357 rest' <- splitCondition rest
358 call' <- splitCondition call
359 return $ JSSeq (pre ++ [rest', call'])
360 (call:rest) -> do
361 depth <- get
362 put (depth + 1)
363 new <- splitFunction (newFun rest)
364 tell [(depth, new)]
365 call' <- splitCondition call
366 return $ JSSeq (pre ++ (newCall depth : [call']))
367 _ -> JSSeq <$> traverse splitCondition seq
369 splitSequence js = return js
371 isBranch :: JS -> Bool
372 isBranch (JSApp (JSIdent "i$CALL") _) = True
373 isBranch (JSCond _) = True
374 isBranch (JSSwitch _ _ _) = True
375 isBranch _ = False
377 newCall :: Int -> JS
378 newCall depth =
379 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
380 , JSArray [jsOLDBASE, jsMYOLDBASE]
381 ]
383 newFun :: [JS] -> JS
384 newFun seq =
385 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
387splitFunction js = return js
389translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
390translateDecl info (name@(MN 0 fun), bc)
391 | txt "APPLY" == 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)) "app")
398 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
399 )
400 , ( JSNoop
401 , JSSeq $ map (translateBC info) (defaultCase (snd body))
402 )
403 ]
404 ]
405 )
406 )
407 ]
409 | txt "EVAL" == fun =
410 allocCaseFunctions (snd body)
411 ++ [ JSAlloc (
412 translateName name
413 ) (Just $ JSFunction ["oldbase"] (
414 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
415 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
416 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
417 )
418 , ( JSNoop
419 , JSSeq $ map (translateBC info) (defaultCase (snd body))
420 )
421 ]
422 ]
423 )
424 )
425 ]
426 where
427 body :: ([BC], [BC])
428 body = break isCase bc
430 isCase :: BC -> Bool
431 isCase bc
432 | CASE {} <- bc = True
433 | otherwise = False
435 defaultCase :: [BC] -> [BC]
436 defaultCase ((CASE _ _ _ (Just d)):_) = d
438 caseReg :: [BC] -> Reg
439 caseReg ((CASE _ r _ _):_) = r
441 allocCaseFunctions :: [BC] -> [JS]
442 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
443 allocCaseFunctions _ = []
445 splitBranches :: [(Int, [BC])] -> [JS]
446 splitBranches = map prepBranch
448 prepBranch :: (Int, [BC]) -> JS
449 prepBranch (tag, code) =
450 JSAlloc (
451 translateName name ++ "$" ++ show tag
452 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
453 JSSeq $ map (translateBC info) code
454 )
455 )
457translateDecl info (name, bc) =
458 [ JSAlloc (
459 translateName name
460 ) (Just $ JSFunction ["oldbase"] (
461 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
462 )
463 )
464 ]
466jsFUNPRELUDE :: [JS]
467jsFUNPRELUDE = [jsALLOCMYOLDBASE]
469jsALLOCMYOLDBASE :: JS
470jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
472translateReg :: Reg -> JS
473translateReg reg
474 | RVal <- reg = jsRET
475 | Tmp <- reg = JSRaw "//TMPREG"
476 | L n <- reg = jsLOC n
477 | T n <- reg = jsTOP n
479translateConstant :: Const -> JS
480translateConstant (I i) = JSNum (JSInt i)
481translateConstant (Fl f) = JSNum (JSFloat f)
482translateConstant (Ch c) = JSString $ translateChar c
483translateConstant (Str s) = JSString $ concatMap translateChar s
484translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
485translateConstant StrType = JSType JSStringTy
486translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
487translateConstant (AType ATFloat) = JSType JSFloatTy
488translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
489translateConstant Forgot = JSType JSForgotTy
490translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
491translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
492translateConstant (BI i) = jsBigInt (JSString $ show i)
493translateConstant (B8 b) = JSWord (JSWord8 b)
494translateConstant (B16 b) = JSWord (JSWord16 b)
495translateConstant (B32 b) = JSWord (JSWord32 b)
496translateConstant (B64 b) = JSWord (JSWord64 b)
497translateConstant c =
498 JSError $ "Unimplemented Constant: " ++ show c
501translateChar :: Char -> String
502translateChar ch
503 | '\a' <- ch = "\\u0007"
504 | '\b' <- ch = "\\b"
505 | '\f' <- ch = "\\f"
506 | '\n' <- ch = "\\n"
507 | '\r' <- ch = "\\r"
508 | '\t' <- ch = "\\t"
509 | '\v' <- ch = "\\v"
510 | '\SO' <- ch = "\\u000E"
511 | '\DEL' <- ch = "\\u007F"
512 | '\\' <- ch = "\\\\"
513 | '\"' <- ch = "\\\""
514 | '\'' <- ch = "\\\'"
515 | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
516 | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
517 | otherwise = [ch]
518 where
519 fill :: String -> String
520 fill s = case length s of
521 1 -> "000" ++ s
522 2 -> "00" ++ s
523 3 -> "0" ++ s
524 _ -> s
526 asciiTab =
527 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
528 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
529 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
530 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
532translateName :: Name -> String
533translateName n = "_idris_" ++ concatMap cchar (showCG n)
534 where cchar x | isAlphaNum x = [x]
535 | otherwise = "_" ++ show (fromEnum x) ++ "_"
537jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
538jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
540jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
541jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
543jsCALL :: CompileInfo -> Name -> JS
544jsCALL _ n =
545 JSApp (
546 JSIdent "i$CALL"
547 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
549jsTAILCALL :: CompileInfo -> Name -> JS
550jsTAILCALL _ n =
551 JSApp (
552 JSIdent "i$CALL"
553 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
555jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
556jsFOREIGN _ reg n args
557 | n == "isNull"
558 , [(FPtr, arg)] <- args =
559 JSAssign (
560 translateReg reg
561 ) (
562 JSBinOp "==" (translateReg arg) JSNull
563 )
565 | n == "idris_eqPtr"
566 , [(_, lhs),(_, rhs)] <- args =
567 JSAssign (
568 translateReg reg
569 ) (
570 JSBinOp "==" (translateReg lhs) (translateReg rhs)
571 )
572 | otherwise =
573 JSAssign (
574 translateReg reg
575 ) (
576 JSFFI n (map generateWrapper args)
577 )
578 where
579 generateWrapper :: (FType, Reg) -> JS
580 generateWrapper (ty, reg)
581 | FFunction <- ty =
582 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
583 , JSIdent "oldbase"
584 , JSIdent "myoldbase"
585 ]
586 | FFunctionIO <- ty =
587 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
588 , JSIdent "oldbase"
589 , JSIdent "myoldbase"
590 ]
592 generateWrapper (_, reg) =
593 translateReg reg
595jsREBASE :: CompileInfo -> JS
596jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
598jsSTOREOLD :: CompileInfo ->JS
599jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
601jsADDTOP :: CompileInfo -> Int -> JS
602jsADDTOP info n
603 | 0 <- n = JSNoop
604 | otherwise =
605 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
607jsTOPBASE :: CompileInfo -> Int -> JS
608jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
609jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
612jsBASETOP :: CompileInfo -> Int -> JS
613jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
614jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
616jsNULL :: CompileInfo -> Reg -> JS
617jsNULL _ r = JSClear (translateReg r)
619jsERROR :: CompileInfo -> String -> JS
620jsERROR _ = JSError
622jsSLIDE :: CompileInfo -> Int -> JS
623jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
624jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
626jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
627jsMKCON info r t rs =
628 JSAssign (translateReg r) (
629 JSNew "i$CON" [ JSNum (JSInt t)
630 , JSArray (map translateReg rs)
631 , if t `elem` compileInfoApplyCases info
632 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
633 else JSNull
634 , if t `elem` compileInfoEvalCases info
635 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
636 else JSNull
637 ]
638 )
640jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
641jsCASE info safe reg cases def =
642 JSSwitch (tag safe $ translateReg reg) (
643 map ((JSNum . JSInt) *** prepBranch) cases
644 ) (fmap prepBranch def)
645 where
646 tag :: Bool -> JS -> JS
647 tag True = jsCTAG
648 tag False = jsTAG
650 prepBranch :: [BC] -> JS
651 prepBranch bc = JSSeq $ map (translateBC info) bc
653 jsTAG :: JS -> JS
654 jsTAG js =
655 (JSTernary (js `jsInstanceOf` "i$CON") (
656 JSProj js "tag"
657 ) (JSNum (JSInt $ negate 1)))
659 jsCTAG :: JS -> JS
660 jsCTAG js = JSProj js "tag"
663jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
664jsCONSTCASE info reg cases def =
665 JSCond $ (
666 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
667 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
668 where
669 prepBranch :: [BC] -> JS
670 prepBranch bc = JSSeq $ map (translateBC info) bc
672jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
673jsPROJECT _ reg loc 0 = JSNoop
674jsPROJECT _ reg loc 1 =
675 JSAssign (jsLOC loc) (
676 JSIndex (
677 JSProj (translateReg reg) "args"
678 ) (
679 JSNum (JSInt 0)
680 )
681 )
682jsPROJECT _ reg loc ar =
683 JSApp (JSIdent "i$PROJECT") [ translateReg reg
684 , JSNum (JSInt loc)
685 , JSNum (JSInt ar)
686 ]
688jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
689jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
690 where
691 jsOP' :: JS
692 jsOP'
693 | LNoOp <- op = translateReg (last args)
695 | LWriteStr <- op,
696 (_:str:_) <- args = JSApp (JSIdent "i$putStr") [translateReg str]
698 | LReadStr <- op = JSApp (JSIdent "i$getLine") []
700 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
701 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
702 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
704 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
705 | (LPlus (ATInt ITBig)) <- op
706 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
707 | (LMinus (ATInt ITBig)) <- op
708 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
709 | (LTimes (ATInt ITBig)) <- op
710 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
711 | (LSDiv (ATInt ITBig)) <- op
712 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
713 | (LSRem (ATInt ITBig)) <- op
714 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
715 | (LEq (ATInt ITBig)) <- op
716 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
717 | (LSLt (ATInt ITBig)) <- op
718 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
719 | (LSLe (ATInt ITBig)) <- op
720 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
721 | (LSGt (ATInt ITBig)) <- op
722 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
723 | (LSGe (ATInt ITBig)) <- op
724 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
726 | (LPlus ATFloat) <- op
727 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
728 | (LMinus ATFloat) <- op
729 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
730 | (LTimes ATFloat) <- op
731 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
732 | (LSDiv ATFloat) <- op
733 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
734 | (LEq ATFloat) <- op
735 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
736 | (LSLt ATFloat) <- op
737 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
738 | (LSLe ATFloat) <- op
739 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
740 | (LSGt ATFloat) <- op
741 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
742 | (LSGe ATFloat) <- op
743 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
745 | (LPlus (ATInt ITChar)) <- op
746 , (lhs:rhs:_) <- args =
747 jsCall "i$fromCharCode" [
748 JSBinOp "+" (
749 jsCall "i$charCode" [translateReg lhs]
750 ) (
751 jsCall "i$charCode" [translateReg rhs]
752 )
753 ]
755 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
756 , (arg:_) <- args =
757 jsPackUBits8 (
758 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
759 )
761 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
762 , (arg:_) <- args =
763 jsPackUBits16 (
764 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
765 )
767 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
768 , (arg:_) <- args =
769 jsPackUBits32 (
770 jsMeth (jsMeth (translateReg arg) "and" [
771 jsBigInt (JSString $ show 0xFFFFFFFF)
772 ]) "intValue" []
773 )
775 | (LTrunc ITBig (ITFixed IT64)) <- op
776 , (arg:_) <- args =
777 jsMeth (translateReg arg) "and" [
778 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
779 ]
781 | (LLSHR (ITFixed IT8)) <- op
782 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs
784 | (LLSHR (ITFixed IT16)) <- op
785 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs
787 | (LLSHR (ITFixed IT32)) <- op
788 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs
790 | (LLSHR (ITFixed IT64)) <- op
791 , (lhs:rhs:_) <- args =
792 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
794 | (LSHL (ITFixed IT8)) <- op
795 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs
797 | (LSHL (ITFixed IT16)) <- op
798 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs
800 | (LSHL (ITFixed IT32)) <- op
801 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs
803 | (LSHL (ITFixed IT64)) <- op
804 , (lhs:rhs:_) <- args =
805 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
806 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
807 ]
809 | (LAnd (ITFixed IT8)) <- op
810 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs
812 | (LAnd (ITFixed IT16)) <- op
813 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs
815 | (LAnd (ITFixed IT32)) <- op
816 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs
818 | (LAnd (ITFixed IT64)) <- op
819 , (lhs:rhs:_) <- args =
820 jsMeth (translateReg lhs) "and" [translateReg rhs]
822 | (LOr (ITFixed IT8)) <- op
823 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs
825 | (LOr (ITFixed IT16)) <- op
826 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs
828 | (LOr (ITFixed IT32)) <- op
829 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs
831 | (LOr (ITFixed IT64)) <- op
832 , (lhs:rhs:_) <- args =
833 jsMeth (translateReg lhs) "or" [translateReg rhs]
835 | (LXOr (ITFixed IT8)) <- op
836 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs
838 | (LXOr (ITFixed IT16)) <- op
839 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs
841 | (LXOr (ITFixed IT32)) <- op
842 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs
844 | (LXOr (ITFixed IT64)) <- op
845 , (lhs:rhs:_) <- args =
846 jsMeth (translateReg lhs) "xor" [translateReg rhs]
848 | (LPlus (ATInt (ITFixed IT8))) <- op
849 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs
851 | (LPlus (ATInt (ITFixed IT16))) <- op
852 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs
854 | (LPlus (ATInt (ITFixed IT32))) <- op
855 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs
857 | (LPlus (ATInt (ITFixed IT64))) <- op
858 , (lhs:rhs:_) <- args =
859 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
860 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
861 ]
863 | (LMinus (ATInt (ITFixed IT8))) <- op
864 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs
866 | (LMinus (ATInt (ITFixed IT16))) <- op
867 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs
869 | (LMinus (ATInt (ITFixed IT32))) <- op
870 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs
872 | (LMinus (ATInt (ITFixed IT64))) <- op
873 , (lhs:rhs:_) <- args =
874 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
875 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
876 ]
878 | (LTimes (ATInt (ITFixed IT8))) <- op
879 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs
881 | (LTimes (ATInt (ITFixed IT16))) <- op
882 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs
884 | (LTimes (ATInt (ITFixed IT32))) <- op
885 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs
887 | (LTimes (ATInt (ITFixed IT64))) <- op
888 , (lhs:rhs:_) <- args =
889 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
890 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
891 ]
893 | (LEq (ATInt (ITFixed IT8))) <- op
894 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
896 | (LEq (ATInt (ITFixed IT16))) <- op
897 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
899 | (LEq (ATInt (ITFixed IT32))) <- op
900 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
902 | (LEq (ATInt (ITFixed IT64))) <- op
903 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
905 | (LLt (ITFixed IT8)) <- op
906 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
908 | (LLt (ITFixed IT16)) <- op
909 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
911 | (LLt (ITFixed IT32)) <- op
912 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
914 | (LLt (ITFixed IT64)) <- op
915 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
917 | (LLe (ITFixed IT8)) <- op
918 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
920 | (LLe (ITFixed IT16)) <- op
921 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
923 | (LLe (ITFixed IT32)) <- op
924 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
926 | (LLe (ITFixed IT64)) <- op
927 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
929 | (LGt (ITFixed IT8)) <- op
930 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
932 | (LGt (ITFixed IT16)) <- op
933 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
934 | (LGt (ITFixed IT32)) <- op
935 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
937 | (LGt (ITFixed IT64)) <- op
938 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
940 | (LGe (ITFixed IT8)) <- op
941 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
943 | (LGe (ITFixed IT16)) <- op
944 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
945 | (LGe (ITFixed IT32)) <- op
946 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
948 | (LGe (ITFixed IT64)) <- op
949 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
951 | (LUDiv (ITFixed IT8)) <- op
952 , (lhs:rhs:_) <- args =
953 jsPackUBits8 (
954 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
955 )
957 | (LUDiv (ITFixed IT16)) <- op
958 , (lhs:rhs:_) <- args =
959 jsPackUBits16 (
960 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
961 )
963 | (LUDiv (ITFixed IT32)) <- op
964 , (lhs:rhs:_) <- args =
965 jsPackUBits32 (
966 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
967 )
969 | (LUDiv (ITFixed IT64)) <- op
970 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
972 | (LSDiv (ATInt (ITFixed IT8))) <- op
973 , (lhs:rhs:_) <- args =
974 jsPackSBits8 (
975 JSBinOp "/" (
976 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
977 ) (
978 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
979 )
980 )
982 | (LSDiv (ATInt (ITFixed IT16))) <- op
983 , (lhs:rhs:_) <- args =
984 jsPackSBits16 (
985 JSBinOp "/" (
986 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
987 ) (
988 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
989 )
990 )
992 | (LSDiv (ATInt (ITFixed IT32))) <- op
993 , (lhs:rhs:_) <- args =
994 jsPackSBits32 (
995 JSBinOp "/" (
996 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
997 ) (
998 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
999 )
1002 | (LSDiv (ATInt (ITFixed IT64))) <- op
1003 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1005 | (LSRem (ATInt (ITFixed IT8))) <- op
1006 , (lhs:rhs:_) <- args =
1007 jsPackSBits8 (
1008 JSBinOp "%" (
1009 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1010 ) (
1011 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1015 | (LSRem (ATInt (ITFixed IT16))) <- op
1016 , (lhs:rhs:_) <- args =
1017 jsPackSBits16 (
1018 JSBinOp "%" (
1019 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1020 ) (
1021 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1025 | (LSRem (ATInt (ITFixed IT32))) <- op
1026 , (lhs:rhs:_) <- args =
1027 jsPackSBits32 (
1028 JSBinOp "%" (
1029 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1030 ) (
1031 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1035 | (LSRem (ATInt (ITFixed IT64))) <- op
1036 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1038 | (LCompl (ITFixed IT8)) <- op
1039 , (arg:_) <- args =
1040 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1042 | (LCompl (ITFixed IT16)) <- op
1043 , (arg:_) <- args =
1044 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1046 | (LCompl (ITFixed IT32)) <- op
1047 , (arg:_) <- args =
1048 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1050 | (LCompl (ITFixed IT64)) <- op
1051 , (arg:_) <- args = invokeMeth arg "not" []
1053 | (LPlus _) <- op
1054 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1055 | (LMinus _) <- op
1056 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1057 | (LTimes _) <- op
1058 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1059 | (LSDiv _) <- op
1060 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1061 | (LSRem _) <- op
1062 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1063 | (LEq _) <- op
1064 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1065 | (LSLt _) <- op
1066 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1067 | (LSLe _) <- op
1068 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
1069 | (LSGt _) <- op
1070 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
1071 | (LSGe _) <- op
1072 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
1073 | (LAnd _) <- op
1074 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1075 | (LOr _) <- op
1076 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1077 | (LXOr _) <- op
1078 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1079 | (LSHL _) <- op
1080 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1081 | (LASHR _) <- op
1082 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1083 | (LCompl _) <- op
1084 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1086 | LStrConcat <- op
1087 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1088 | LStrEq <- op
1089 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1090 | LStrLt <- op
1091 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1092 | LStrLen <- op
1093 , (arg:_) <- args = JSProj (translateReg arg) "length"
1094 | (LStrInt ITNative) <- op
1095 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1096 | (LIntStr ITNative) <- op
1097 , (arg:_) <- args = jsCall "String" [translateReg arg]
1098 | (LSExt ITNative ITBig) <- op
1099 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1100 | (LTrunc ITBig ITNative) <- op
1101 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1102 | (LIntStr ITBig) <- op
1103 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1104 | (LStrInt ITBig) <- op
1105 , (arg:_) <- args = jsBigInt $ translateReg arg
1106 | LFloatStr <- op
1107 , (arg:_) <- args = jsCall "String" [translateReg arg]
1108 | LStrFloat <- op
1109 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1110 | (LIntFloat ITNative) <- op
1111 , (arg:_) <- args = translateReg arg
1112 | (LIntFloat ITBig) <- op
1113 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1114 | (LFloatInt ITNative) <- op
1115 , (arg:_) <- args = translateReg arg
1116 | (LChInt ITNative) <- op
1117 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1118 | (LIntCh ITNative) <- op
1119 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1121 | LFExp <- op
1122 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1123 | LFLog <- op
1124 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1125 | LFSin <- op
1126 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1127 | LFCos <- op
1128 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1129 | LFTan <- op
1130 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1131 | LFASin <- op
1132 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1133 | LFACos <- op
1134 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1135 | LFATan <- op
1136 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1137 | LFSqrt <- op
1138 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1139 | LFFloor <- op
1140 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1141 | LFCeil <- op
1142 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1143 | LFNegate <- op
1144 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1146 | LStrCons <- op
1147 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1148 | LStrHead <- op
1149 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1150 | LStrRev <- op
1151 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1152 | LStrIndex <- op
1153 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1154 | LStrTail <- op
1155 , (arg:_) <- args =
1156 let v = translateReg arg in
1157 JSApp (JSProj v "substr") [
1158 JSNum (JSInt 1),
1159 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1161 | LStrSubstr <- op
1162 , (offset:length:string:_) <- args =
1163 let off = translateReg offset
1164 len = translateReg length
1165 str = translateReg string
1166 in JSApp (JSProj str "substr") [
1167 jsCall "Math.max" [JSNum (JSInt 0), off],
1168 jsCall "Math.max" [JSNum (JSInt 0), len]
1171 | LSystemInfo <- op
1172 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1173 | LExternal nul <- op
1174 , nul == sUN "prim__null"
1175 , _ <- args = JSNull
1176 | LExternal ex <- op
1177 , ex == sUN "prim__eqPtr"
1178 , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs
1179 | otherwise = JSError $ "Not implemented: " ++ show op
1180 where
1181 translateBinaryOp :: String -> Reg -> Reg -> JS
1182 translateBinaryOp op lhs rhs =
1183 JSBinOp op (translateReg lhs) (translateReg rhs)
1185 translateCompareOp :: String -> Reg -> Reg -> JS
1186 translateCompareOp op lhs rhs =
1187 JSPreOp "+" $ translateBinaryOp op lhs rhs
1189 bitsBinaryOp :: String -> Reg -> Reg -> JS
1190 bitsBinaryOp op lhs rhs =
1191 JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1193 bitsCompareOp :: String -> Reg -> Reg -> JS
1194 bitsCompareOp op lhs rhs =
1195 JSPreOp "+" $ bitsBinaryOp op lhs rhs
1197 invokeMeth :: Reg -> String -> [Reg] -> JS
1198 invokeMeth obj meth args =
1199 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1202jsRESERVE :: CompileInfo -> Int -> JS
1203jsRESERVE _ _ = JSNoop
1205jsSTACK :: JS
1206jsSTACK = JSIdent "i$valstack"
1208jsCALLSTACK :: JS
1209jsCALLSTACK = JSIdent "i$callstack"
1211jsSTACKBASE :: JS
1212jsSTACKBASE = JSIdent "i$valstack_base"
1214jsSTACKTOP :: JS
1215jsSTACKTOP = JSIdent "i$valstack_top"
1217jsOLDBASE :: JS
1218jsOLDBASE = JSIdent "oldbase"
1220jsMYOLDBASE :: JS
1221jsMYOLDBASE = JSIdent "myoldbase"
1223jsRET :: JS
1224jsRET = JSIdent "i$ret"
1226jsLOC :: Int -> JS
1227jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1228jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1230jsTOP :: Int -> JS
1231jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1232jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1234jsPUSH :: [JS] -> JS
1235jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1237jsPOP :: JS
1238jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1240translateBC :: CompileInfo -> BC -> JS
1241translateBC info bc
1242 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1243 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1244 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1245 | ADDTOP n <- bc = jsADDTOP info n
1246 | NULL r <- bc = jsNULL info r
1247 | CALL n <- bc = jsCALL info n
1248 | TAILCALL n <- bc = jsTAILCALL info n
1249 | FOREIGNCALL r _ (FStr n) args
1250 <- bc = jsFOREIGN info r n (map fcall args)
1251 | FOREIGNCALL _ _ _ _ <- bc = error "JS FFI call not statically known"
1252 | TOPBASE n <- bc = jsTOPBASE info n
1253 | BASETOP n <- bc = jsBASETOP info n
1254 | STOREOLD <- bc = jsSTOREOLD info
1255 | SLIDE n <- bc = jsSLIDE info n
1256 | REBASE <- bc = jsREBASE info
1257 | RESERVE n <- bc = jsRESERVE info n
1258 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1259 | CASE s r c d <- bc = jsCASE info s r c d
1260 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1261 | PROJECT r l a <- bc = jsPROJECT info r l a
1262 | OP r o a <- bc = jsOP info r o a
1263 | ERROR e <- bc = jsERROR info e
1264 | otherwise = JSRaw $ "//" ++ show bc
1265 where fcall (t, arg) = (toFType t, arg)
1267toAType (FCon i)
1268 | i == sUN "JS_IntChar" = ATInt ITChar
1269 | i == sUN "JS_IntNative" = ATInt ITNative
1270toAType t = error (show t ++ " not defined in toAType")
1272toFnType (FApp c [_,_,s,t])
1273 | c == sUN "JS_Fn" = toFnType t
1274toFnType (FApp c [_,_,r])
1275 | c == sUN "JS_FnIO" = FFunctionIO
1276toFnType (FApp c [_,r])
1277 | c == sUN "JS_FnBase" = FFunction
1278toFnType t = error (show t ++ " not defined in toFnType")
1280toFType (FCon c)
1281 | c == sUN "JS_Str" = FString
1282 | c == sUN "JS_Float" = FArith ATFloat
1283 | c == sUN "JS_Ptr" = FPtr
1284 | c == sUN "JS_Unit" = FUnit
1285toFType (FApp c [_,ity])
1286 | c == sUN "JS_IntT" = FArith (toAType ity)
1287toFType (FApp c [_,fty])
1288 | c == sUN "JS_FnT" = toFnType fty
1289toFType t = error (show t ++ " not yet defined in toFType")