git.iko.soy/Idris-dev
on cf47310 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1263 lines 46 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 = any 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 || any (needsBigInt . snd) c
59 || any (testConstForBigInt . fst) c
61 testBCForBigInt (CASE _ _ c d) =
62 maybe False needsBigInt d
63 || any (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 writeSourceText 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 , JSApp (JSIdent "i$RUN") []
254 ]
256 invokeMain :: T.Text
257 invokeMain = compileJS $ JSApp (JSIdent "main") []
259optimizeConstructors :: [JS] -> ([JS], [JS])
260optimizeConstructors js =
261 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
262 (map (allocCon . snd) (M.toList cons), js')
263 where
264 allocCon :: (String, JS) -> JS
265 allocCon (name, con) = JSAlloc name (Just con)
267 newConstructor :: Int -> String
268 newConstructor n = "i$CON$" ++ show n
270 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
271 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
272 , JSArray []
273 , a
274 , e
275 ]) = do
276 s <- get
277 case M.lookup tag s of
278 Just (i, c) -> return $ JSIdent i
279 Nothing -> do let n = newConstructor tag
280 put $ M.insert tag (n, js) s
281 return $ JSIdent n
283 optimizeConstructor' (JSSeq seq) =
284 JSSeq <$> traverse optimizeConstructor' seq
286 optimizeConstructor' (JSSwitch reg cond def) = do
287 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
288 def' <- traverse optimizeConstructor' def
289 return $ JSSwitch reg cond' def'
291 optimizeConstructor' (JSCond cond) =
292 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
294 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
295 body' <- optimizeConstructor' body
296 return $ JSAlloc fun (Just (JSFunction args body'))
298 optimizeConstructor' (JSAssign lhs rhs) = do
299 lhs' <- optimizeConstructor' lhs
300 rhs' <- optimizeConstructor' rhs
301 return $ JSAssign lhs' rhs'
303 optimizeConstructor' js = return js
305collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
306collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
307 where
308 generateSplitFunction :: (Int,JS) -> JS
309 generateSplitFunction (depth, JSAlloc name fun) =
310 JSAlloc (name ++ "$" ++ show depth) fun
312splitFunction :: JS -> RWS () [(Int,JS)] Int JS
313splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
314 body' <- splitSequence body
315 return $ JSAlloc name (Just (JSFunction args body'))
316 where
317 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
318 splitCondition js
319 | JSCond branches <- js =
320 JSCond <$> processBranches branches
321 | JSSwitch cond branches def <- js =
322 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
323 | otherwise = return js
324 where
325 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
326 processBranches =
327 traverse (runKleisli (arr id *** Kleisli splitSequence))
329 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
330 splitSequence js@(JSSeq seq) =
331 let (pre,post) = break isBranch seq in
332 case post of
333 [_] -> JSSeq <$> traverse splitCondition seq
334 [call@(JSCond _),rest@(JSApp _ _)] -> do
335 rest' <- splitCondition rest
336 call' <- splitCondition call
337 return $ JSSeq (pre ++ [rest', call'])
338 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
339 rest' <- splitCondition rest
340 call' <- splitCondition call
341 return $ JSSeq (pre ++ [rest', call'])
342 (call:rest) -> do
343 depth <- get
344 put (depth + 1)
345 new <- splitFunction (newFun rest)
346 tell [(depth, new)]
347 call' <- splitCondition call
348 return $ JSSeq (pre ++ (newCall depth : [call']))
349 _ -> JSSeq <$> traverse splitCondition seq
351 splitSequence js = return js
353 isBranch :: JS -> Bool
354 isBranch (JSApp (JSIdent "i$CALL") _) = True
355 isBranch (JSCond _) = True
356 isBranch (JSSwitch _ _ _) = True
357 isBranch _ = False
359 newCall :: Int -> JS
360 newCall depth =
361 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
362 , JSArray [jsOLDBASE, jsMYOLDBASE]
363 ]
365 newFun :: [JS] -> JS
366 newFun seq =
367 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
369splitFunction js = return js
371translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
372translateDecl info (name@(MN 0 fun), bc)
373 | txt "APPLY" == fun =
374 allocCaseFunctions (snd body)
375 ++ [ JSAlloc (
376 translateName name
377 ) (Just $ JSFunction ["oldbase"] (
378 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
379 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
380 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
381 )
382 , ( JSNoop
383 , JSSeq $ map (translateBC info) (defaultCase (snd body))
384 )
385 ]
386 ]
387 )
388 )
389 ]
391 | txt "EVAL" == fun =
392 allocCaseFunctions (snd body)
393 ++ [ JSAlloc (
394 translateName name
395 ) (Just $ JSFunction ["oldbase"] (
396 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
397 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
398 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
399 )
400 , ( JSNoop
401 , JSSeq $ map (translateBC info) (defaultCase (snd body))
402 )
403 ]
404 ]
405 )
406 )
407 ]
408 where
409 body :: ([BC], [BC])
410 body = break isCase bc
412 isCase :: BC -> Bool
413 isCase bc
414 | CASE {} <- bc = True
415 | otherwise = False
417 defaultCase :: [BC] -> [BC]
418 defaultCase ((CASE _ _ _ (Just d)):_) = d
420 caseReg :: [BC] -> Reg
421 caseReg ((CASE _ r _ _):_) = r
423 allocCaseFunctions :: [BC] -> [JS]
424 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
425 allocCaseFunctions _ = []
427 splitBranches :: [(Int, [BC])] -> [JS]
428 splitBranches = map prepBranch
430 prepBranch :: (Int, [BC]) -> JS
431 prepBranch (tag, code) =
432 JSAlloc (
433 translateName name ++ "$" ++ show tag
434 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
435 JSSeq $ map (translateBC info) code
436 )
437 )
439translateDecl info (name, bc) =
440 [ JSAlloc (
441 translateName name
442 ) (Just $ JSFunction ["oldbase"] (
443 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
444 )
445 )
446 ]
448jsFUNPRELUDE :: [JS]
449jsFUNPRELUDE = [jsALLOCMYOLDBASE]
451jsALLOCMYOLDBASE :: JS
452jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
454translateReg :: Reg -> JS
455translateReg reg
456 | RVal <- reg = jsRET
457 | Tmp <- reg = JSRaw "//TMPREG"
458 | L n <- reg = jsLOC n
459 | T n <- reg = jsTOP n
461translateConstant :: Const -> JS
462translateConstant (I i) = JSNum (JSInt i)
463translateConstant (Fl f) = JSNum (JSFloat f)
464translateConstant (Ch c) = JSString $ translateChar c
465translateConstant (Str s) = JSString $ concatMap translateChar s
466translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
467translateConstant StrType = JSType JSStringTy
468translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
469translateConstant (AType ATFloat) = JSType JSFloatTy
470translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
471translateConstant Forgot = JSType JSForgotTy
472translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
473translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
474translateConstant (BI i) = jsBigInt (JSString $ show i)
475translateConstant (B8 b) = JSWord (JSWord8 b)
476translateConstant (B16 b) = JSWord (JSWord16 b)
477translateConstant (B32 b) = JSWord (JSWord32 b)
478translateConstant (B64 b) = JSWord (JSWord64 b)
479translateConstant c =
480 JSError $ "Unimplemented Constant: " ++ show c
483translateChar :: Char -> String
484translateChar ch
485 | '\a' <- ch = "\\u0007"
486 | '\b' <- ch = "\\b"
487 | '\f' <- ch = "\\f"
488 | '\n' <- ch = "\\n"
489 | '\r' <- ch = "\\r"
490 | '\t' <- ch = "\\t"
491 | '\v' <- ch = "\\v"
492 | '\SO' <- ch = "\\u000E"
493 | '\DEL' <- ch = "\\u007F"
494 | '\\' <- ch = "\\\\"
495 | '\"' <- ch = "\\\""
496 | '\'' <- ch = "\\\'"
497 | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
498 | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
499 | otherwise = [ch]
500 where
501 fill :: String -> String
502 fill s = case length s of
503 1 -> "000" ++ s
504 2 -> "00" ++ s
505 3 -> "0" ++ s
506 _ -> s
508 asciiTab =
509 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
510 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
511 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
512 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
514translateName :: Name -> String
515translateName n = "_idris_" ++ concatMap cchar (showCG n)
516 where cchar x | isAlphaNum x = [x]
517 | otherwise = "_" ++ show (fromEnum x) ++ "_"
519jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
520jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
522jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
523jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
525jsCALL :: CompileInfo -> Name -> JS
526jsCALL _ n =
527 JSApp (
528 JSIdent "i$CALL"
529 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
531jsTAILCALL :: CompileInfo -> Name -> JS
532jsTAILCALL _ n =
533 JSApp (
534 JSIdent "i$CALL"
535 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
537jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
538jsFOREIGN _ reg n args
539 | n == "isNull"
540 , [(FPtr, arg)] <- args =
541 JSAssign (
542 translateReg reg
543 ) (
544 JSBinOp "==" (translateReg arg) JSNull
545 )
547 | n == "idris_eqPtr"
548 , [(_, lhs),(_, rhs)] <- args =
549 JSAssign (
550 translateReg reg
551 ) (
552 JSBinOp "==" (translateReg lhs) (translateReg rhs)
553 )
554 | otherwise =
555 JSAssign (
556 translateReg reg
557 ) (
558 JSFFI n (map generateWrapper args)
559 )
560 where
561 generateWrapper :: (FType, Reg) -> JS
562 generateWrapper (ty, reg)
563 | FFunction <- ty =
564 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
565 , JSIdent "oldbase"
566 , JSIdent "myoldbase"
567 ]
568 | FFunctionIO <- ty =
569 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
570 , JSIdent "oldbase"
571 , JSIdent "myoldbase"
572 ]
574 generateWrapper (_, reg) =
575 translateReg reg
577jsREBASE :: CompileInfo -> JS
578jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
580jsSTOREOLD :: CompileInfo ->JS
581jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
583jsADDTOP :: CompileInfo -> Int -> JS
584jsADDTOP info n
585 | 0 <- n = JSNoop
586 | otherwise =
587 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
589jsTOPBASE :: CompileInfo -> Int -> JS
590jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
591jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
594jsBASETOP :: CompileInfo -> Int -> JS
595jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
596jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
598jsNULL :: CompileInfo -> Reg -> JS
599jsNULL _ r = JSDelete (translateReg r)
601jsERROR :: CompileInfo -> String -> JS
602jsERROR _ = JSError
604jsSLIDE :: CompileInfo -> Int -> JS
605jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
606jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
608jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
609jsMKCON info r t rs =
610 JSAssign (translateReg r) (
611 JSNew "i$CON" [ JSNum (JSInt t)
612 , JSArray (map translateReg rs)
613 , if t `elem` compileInfoApplyCases info
614 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
615 else JSNull
616 , if t `elem` compileInfoEvalCases info
617 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
618 else JSNull
619 ]
620 )
622jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
623jsCASE info safe reg cases def =
624 JSSwitch (tag safe $ translateReg reg) (
625 map ((JSNum . JSInt) *** prepBranch) cases
626 ) (fmap prepBranch def)
627 where
628 tag :: Bool -> JS -> JS
629 tag True = jsCTAG
630 tag False = jsTAG
632 prepBranch :: [BC] -> JS
633 prepBranch bc = JSSeq $ map (translateBC info) bc
635 jsTAG :: JS -> JS
636 jsTAG js =
637 (JSTernary (js `jsInstanceOf` "i$CON") (
638 JSProj js "tag"
639 ) (JSNum (JSInt $ negate 1)))
641 jsCTAG :: JS -> JS
642 jsCTAG js = JSProj js "tag"
645jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
646jsCONSTCASE info reg cases def =
647 JSCond $ (
648 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
649 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
650 where
651 prepBranch :: [BC] -> JS
652 prepBranch bc = JSSeq $ map (translateBC info) bc
654jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
655jsPROJECT _ reg loc 0 = JSNoop
656jsPROJECT _ reg loc 1 =
657 JSAssign (jsLOC loc) (
658 JSIndex (
659 JSProj (translateReg reg) "args"
660 ) (
661 JSNum (JSInt 0)
662 )
663 )
664jsPROJECT _ reg loc ar =
665 JSApp (JSIdent "i$PROJECT") [ translateReg reg
666 , JSNum (JSInt loc)
667 , JSNum (JSInt ar)
668 ]
670jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
671jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
672 where
673 jsOP' :: JS
674 jsOP'
675 | LNoOp <- op = translateReg (last args)
677 | LWriteStr <- op,
678 (_:str:_) <- args = JSApp (JSIdent "i$putStr") [translateReg str]
680 | LReadStr <- op = JSApp (JSIdent "i$getLine") []
682 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
683 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
684 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
686 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
687 | (LPlus (ATInt ITBig)) <- op
688 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
689 | (LMinus (ATInt ITBig)) <- op
690 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
691 | (LTimes (ATInt ITBig)) <- op
692 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
693 | (LSDiv (ATInt ITBig)) <- op
694 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
695 | (LSRem (ATInt ITBig)) <- op
696 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
697 | (LEq (ATInt ITBig)) <- op
698 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
699 | (LSLt (ATInt ITBig)) <- op
700 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
701 | (LSLe (ATInt ITBig)) <- op
702 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
703 | (LSGt (ATInt ITBig)) <- op
704 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
705 | (LSGe (ATInt ITBig)) <- op
706 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
708 | (LPlus ATFloat) <- op
709 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
710 | (LMinus ATFloat) <- op
711 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
712 | (LTimes ATFloat) <- op
713 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
714 | (LSDiv ATFloat) <- op
715 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
716 | (LEq ATFloat) <- op
717 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
718 | (LSLt ATFloat) <- op
719 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
720 | (LSLe ATFloat) <- op
721 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
722 | (LSGt ATFloat) <- op
723 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
724 | (LSGe ATFloat) <- op
725 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
727 | (LPlus (ATInt ITChar)) <- op
728 , (lhs:rhs:_) <- args =
729 jsCall "i$fromCharCode" [
730 JSBinOp "+" (
731 jsCall "i$charCode" [translateReg lhs]
732 ) (
733 jsCall "i$charCode" [translateReg rhs]
734 )
735 ]
737 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
738 , (arg:_) <- args =
739 jsPackUBits8 (
740 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
741 )
743 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
744 , (arg:_) <- args =
745 jsPackUBits16 (
746 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
747 )
749 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
750 , (arg:_) <- args =
751 jsPackUBits32 (
752 jsMeth (jsMeth (translateReg arg) "and" [
753 jsBigInt (JSString $ show 0xFFFFFFFF)
754 ]) "intValue" []
755 )
757 | (LTrunc ITBig (ITFixed IT64)) <- op
758 , (arg:_) <- args =
759 jsMeth (translateReg arg) "and" [
760 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
761 ]
763 | (LLSHR (ITFixed IT8)) <- op
764 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs
766 | (LLSHR (ITFixed IT16)) <- op
767 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs
769 | (LLSHR (ITFixed IT32)) <- op
770 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs
772 | (LLSHR (ITFixed IT64)) <- op
773 , (lhs:rhs:_) <- args =
774 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
776 | (LSHL (ITFixed IT8)) <- op
777 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs
779 | (LSHL (ITFixed IT16)) <- op
780 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs
782 | (LSHL (ITFixed IT32)) <- op
783 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs
785 | (LSHL (ITFixed IT64)) <- op
786 , (lhs:rhs:_) <- args =
787 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
788 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
789 ]
791 | (LAnd (ITFixed IT8)) <- op
792 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs
794 | (LAnd (ITFixed IT16)) <- op
795 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs
797 | (LAnd (ITFixed IT32)) <- op
798 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs
800 | (LAnd (ITFixed IT64)) <- op
801 , (lhs:rhs:_) <- args =
802 jsMeth (translateReg lhs) "and" [translateReg rhs]
804 | (LOr (ITFixed IT8)) <- op
805 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs
807 | (LOr (ITFixed IT16)) <- op
808 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs
810 | (LOr (ITFixed IT32)) <- op
811 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs
813 | (LOr (ITFixed IT64)) <- op
814 , (lhs:rhs:_) <- args =
815 jsMeth (translateReg lhs) "or" [translateReg rhs]
817 | (LXOr (ITFixed IT8)) <- op
818 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs
820 | (LXOr (ITFixed IT16)) <- op
821 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs
823 | (LXOr (ITFixed IT32)) <- op
824 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs
826 | (LXOr (ITFixed IT64)) <- op
827 , (lhs:rhs:_) <- args =
828 jsMeth (translateReg lhs) "xor" [translateReg rhs]
830 | (LPlus (ATInt (ITFixed IT8))) <- op
831 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs
833 | (LPlus (ATInt (ITFixed IT16))) <- op
834 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs
836 | (LPlus (ATInt (ITFixed IT32))) <- op
837 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs
839 | (LPlus (ATInt (ITFixed IT64))) <- op
840 , (lhs:rhs:_) <- args =
841 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
842 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
843 ]
845 | (LMinus (ATInt (ITFixed IT8))) <- op
846 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs
848 | (LMinus (ATInt (ITFixed IT16))) <- op
849 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs
851 | (LMinus (ATInt (ITFixed IT32))) <- op
852 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs
854 | (LMinus (ATInt (ITFixed IT64))) <- op
855 , (lhs:rhs:_) <- args =
856 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
857 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
858 ]
860 | (LTimes (ATInt (ITFixed IT8))) <- op
861 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs
863 | (LTimes (ATInt (ITFixed IT16))) <- op
864 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs
866 | (LTimes (ATInt (ITFixed IT32))) <- op
867 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs
869 | (LTimes (ATInt (ITFixed IT64))) <- op
870 , (lhs:rhs:_) <- args =
871 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
872 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
873 ]
875 | (LEq (ATInt (ITFixed IT8))) <- op
876 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
878 | (LEq (ATInt (ITFixed IT16))) <- op
879 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
881 | (LEq (ATInt (ITFixed IT32))) <- op
882 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
884 | (LEq (ATInt (ITFixed IT64))) <- op
885 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
887 | (LLt (ITFixed IT8)) <- op
888 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
890 | (LLt (ITFixed IT16)) <- op
891 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
893 | (LLt (ITFixed IT32)) <- op
894 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
896 | (LLt (ITFixed IT64)) <- op
897 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
899 | (LLe (ITFixed IT8)) <- op
900 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
902 | (LLe (ITFixed IT16)) <- op
903 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
905 | (LLe (ITFixed IT32)) <- op
906 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
908 | (LLe (ITFixed IT64)) <- op
909 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
911 | (LGt (ITFixed IT8)) <- op
912 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
914 | (LGt (ITFixed IT16)) <- op
915 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
916 | (LGt (ITFixed IT32)) <- op
917 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
919 | (LGt (ITFixed IT64)) <- op
920 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
922 | (LGe (ITFixed IT8)) <- op
923 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
925 | (LGe (ITFixed IT16)) <- op
926 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
927 | (LGe (ITFixed IT32)) <- op
928 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
930 | (LGe (ITFixed IT64)) <- op
931 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
933 | (LUDiv (ITFixed IT8)) <- op
934 , (lhs:rhs:_) <- args =
935 jsPackUBits8 (
936 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
937 )
939 | (LUDiv (ITFixed IT16)) <- op
940 , (lhs:rhs:_) <- args =
941 jsPackUBits16 (
942 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
943 )
945 | (LUDiv (ITFixed IT32)) <- op
946 , (lhs:rhs:_) <- args =
947 jsPackUBits32 (
948 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
949 )
951 | (LUDiv (ITFixed IT64)) <- op
952 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
954 | (LSDiv (ATInt (ITFixed IT8))) <- op
955 , (lhs:rhs:_) <- args =
956 jsPackSBits8 (
957 JSBinOp "/" (
958 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
959 ) (
960 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
961 )
962 )
964 | (LSDiv (ATInt (ITFixed IT16))) <- op
965 , (lhs:rhs:_) <- args =
966 jsPackSBits16 (
967 JSBinOp "/" (
968 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
969 ) (
970 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
971 )
972 )
974 | (LSDiv (ATInt (ITFixed IT32))) <- op
975 , (lhs:rhs:_) <- args =
976 jsPackSBits32 (
977 JSBinOp "/" (
978 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
979 ) (
980 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
981 )
982 )
984 | (LSDiv (ATInt (ITFixed IT64))) <- op
985 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
987 | (LSRem (ATInt (ITFixed IT8))) <- op
988 , (lhs:rhs:_) <- args =
989 jsPackSBits8 (
990 JSBinOp "%" (
991 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
992 ) (
993 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
994 )
995 )
997 | (LSRem (ATInt (ITFixed IT16))) <- op
998 , (lhs:rhs:_) <- args =
999 jsPackSBits16 (
1000 JSBinOp "%" (
1001 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1002 ) (
1003 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1007 | (LSRem (ATInt (ITFixed IT32))) <- op
1008 , (lhs:rhs:_) <- args =
1009 jsPackSBits32 (
1010 JSBinOp "%" (
1011 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1012 ) (
1013 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1017 | (LSRem (ATInt (ITFixed IT64))) <- op
1018 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1020 | (LCompl (ITFixed IT8)) <- op
1021 , (arg:_) <- args =
1022 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1024 | (LCompl (ITFixed IT16)) <- op
1025 , (arg:_) <- args =
1026 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1028 | (LCompl (ITFixed IT32)) <- op
1029 , (arg:_) <- args =
1030 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1032 | (LCompl (ITFixed IT64)) <- op
1033 , (arg:_) <- args = invokeMeth arg "not" []
1035 | (LPlus _) <- op
1036 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1037 | (LMinus _) <- op
1038 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1039 | (LTimes _) <- op
1040 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1041 | (LSDiv _) <- op
1042 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1043 | (LSRem _) <- op
1044 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1045 | (LEq _) <- op
1046 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1047 | (LSLt _) <- op
1048 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1049 | (LSLe _) <- op
1050 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
1051 | (LSGt _) <- op
1052 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
1053 | (LSGe _) <- op
1054 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
1055 | (LAnd _) <- op
1056 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1057 | (LOr _) <- op
1058 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1059 | (LXOr _) <- op
1060 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1061 | (LSHL _) <- op
1062 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1063 | (LASHR _) <- op
1064 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1065 | (LCompl _) <- op
1066 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1068 | LStrConcat <- op
1069 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1070 | LStrEq <- op
1071 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1072 | LStrLt <- op
1073 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1074 | LStrLen <- op
1075 , (arg:_) <- args = JSProj (translateReg arg) "length"
1076 | (LStrInt ITNative) <- op
1077 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1078 | (LIntStr ITNative) <- op
1079 , (arg:_) <- args = jsCall "String" [translateReg arg]
1080 | (LSExt ITNative ITBig) <- op
1081 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1082 | (LTrunc ITBig ITNative) <- op
1083 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1084 | (LIntStr ITBig) <- op
1085 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1086 | (LStrInt ITBig) <- op
1087 , (arg:_) <- args = jsBigInt $ translateReg arg
1088 | LFloatStr <- op
1089 , (arg:_) <- args = jsCall "String" [translateReg arg]
1090 | LStrFloat <- op
1091 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1092 | (LIntFloat ITNative) <- op
1093 , (arg:_) <- args = translateReg arg
1094 | (LIntFloat ITBig) <- op
1095 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1096 | (LFloatInt ITNative) <- op
1097 , (arg:_) <- args = translateReg arg
1098 | (LChInt ITNative) <- op
1099 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1100 | (LIntCh ITNative) <- op
1101 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1103 | LFExp <- op
1104 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1105 | LFLog <- op
1106 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1107 | LFSin <- op
1108 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1109 | LFCos <- op
1110 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1111 | LFTan <- op
1112 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1113 | LFASin <- op
1114 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1115 | LFACos <- op
1116 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1117 | LFATan <- op
1118 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1119 | LFSqrt <- op
1120 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1121 | LFFloor <- op
1122 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1123 | LFCeil <- op
1124 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1125 | LFNegate <- op
1126 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1128 | LStrCons <- op
1129 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1130 | LStrHead <- op
1131 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1132 | LStrRev <- op
1133 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1134 | LStrIndex <- op
1135 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1136 | LStrTail <- op
1137 , (arg:_) <- args =
1138 let v = translateReg arg in
1139 JSApp (JSProj v "substr") [
1140 JSNum (JSInt 1),
1141 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1144 | LSystemInfo <- op
1145 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1146 | LExternal nul <- op
1147 , nul == sUN "prim__null"
1148 , _ <- args = JSNull
1149 | LExternal ex <- op
1150 , ex == sUN "prim__eqPtr"
1151 , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs
1152 | otherwise = JSError $ "Not implemented: " ++ show op
1153 where
1154 translateBinaryOp :: String -> Reg -> Reg -> JS
1155 translateBinaryOp op lhs rhs =
1156 JSBinOp op (translateReg lhs) (translateReg rhs)
1158 translateCompareOp :: String -> Reg -> Reg -> JS
1159 translateCompareOp op lhs rhs =
1160 JSPreOp "+" $ translateBinaryOp op lhs rhs
1162 bitsBinaryOp :: String -> Reg -> Reg -> JS
1163 bitsBinaryOp op lhs rhs =
1164 JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1166 bitsCompareOp :: String -> Reg -> Reg -> JS
1167 bitsCompareOp op lhs rhs =
1168 JSPreOp "+" $ bitsBinaryOp op lhs rhs
1170 invokeMeth :: Reg -> String -> [Reg] -> JS
1171 invokeMeth obj meth args =
1172 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1175jsRESERVE :: CompileInfo -> Int -> JS
1176jsRESERVE _ _ = JSNoop
1178jsSTACK :: JS
1179jsSTACK = JSIdent "i$valstack"
1181jsCALLSTACK :: JS
1182jsCALLSTACK = JSIdent "i$callstack"
1184jsSTACKBASE :: JS
1185jsSTACKBASE = JSIdent "i$valstack_base"
1187jsSTACKTOP :: JS
1188jsSTACKTOP = JSIdent "i$valstack_top"
1190jsOLDBASE :: JS
1191jsOLDBASE = JSIdent "oldbase"
1193jsMYOLDBASE :: JS
1194jsMYOLDBASE = JSIdent "myoldbase"
1196jsRET :: JS
1197jsRET = JSIdent "i$ret"
1199jsLOC :: Int -> JS
1200jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1201jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1203jsTOP :: Int -> JS
1204jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1205jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1207jsPUSH :: [JS] -> JS
1208jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1210jsPOP :: JS
1211jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1213translateBC :: CompileInfo -> BC -> JS
1214translateBC info bc
1215 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1216 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1217 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1218 | ADDTOP n <- bc = jsADDTOP info n
1219 | NULL r <- bc = jsNULL info r
1220 | CALL n <- bc = jsCALL info n
1221 | TAILCALL n <- bc = jsTAILCALL info n
1222 | FOREIGNCALL r _ (FStr n) args
1223 <- bc = jsFOREIGN info r n (map fcall args)
1224 | FOREIGNCALL _ _ _ _ <- bc = error "JS FFI call not statically known"
1225 | TOPBASE n <- bc = jsTOPBASE info n
1226 | BASETOP n <- bc = jsBASETOP info n
1227 | STOREOLD <- bc = jsSTOREOLD info
1228 | SLIDE n <- bc = jsSLIDE info n
1229 | REBASE <- bc = jsREBASE info
1230 | RESERVE n <- bc = jsRESERVE info n
1231 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1232 | CASE s r c d <- bc = jsCASE info s r c d
1233 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1234 | PROJECT r l a <- bc = jsPROJECT info r l a
1235 | OP r o a <- bc = jsOP info r o a
1236 | ERROR e <- bc = jsERROR info e
1237 | otherwise = JSRaw $ "//" ++ show bc
1238 where fcall (t, arg) = (toFType t, arg)
1240toAType (FCon i)
1241 | i == sUN "JS_IntChar" = ATInt ITChar
1242 | i == sUN "JS_IntNative" = ATInt ITNative
1243toAType t = error (show t ++ " not defined in toAType")
1245toFnType (FApp c [_,_,s,t])
1246 | c == sUN "JS_Fn" = toFnType t
1247toFnType (FApp c [_,_,r])
1248 | c == sUN "JS_FnIO" = FFunctionIO
1249toFnType (FApp c [_,r])
1250 | c == sUN "JS_FnBase" = FFunction
1251toFnType t = error (show t ++ " not defined in toFnType")
1253toFType (FCon c)
1254 | c == sUN "JS_Str" = FString
1255 | c == sUN "JS_Float" = FArith ATFloat
1256 | c == sUN "JS_Ptr" = FPtr
1257 | c == sUN "JS_Unit" = FUnit
1258toFType (FApp c [_,ity])
1259 | c == sUN "JS_IntT" = FArith (toAType ity)
1260toFType (FApp c [_,fty])
1261 | c == sUN "JS_FnT" = toFnType fty
1262toFType t = error (show t ++ " not yet defined in toFType")