git.iko.soy/Idris-dev
on dccd072 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1369 lines 49 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 = invokeMeth lhs "equals" [rhs]
699 | (LSLt (ATInt ITBig)) <- op
700 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
701 | (LSLe (ATInt ITBig)) <- op
702 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
703 | (LSGt (ATInt ITBig)) <- op
704 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
705 | (LSGe (ATInt ITBig)) <- op
706 , (lhs:rhs:_) <- args = 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 = translateBinaryOp "==" lhs rhs
718 | (LSLt ATFloat) <- op
719 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
720 | (LSLe ATFloat) <- op
721 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
722 | (LSGt ATFloat) <- op
723 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
724 | (LSGe ATFloat) <- op
725 , (lhs:rhs:_) <- args = translateBinaryOp ">=" 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 =
765 jsPackUBits8 (
766 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
767 )
769 | (LLSHR (ITFixed IT16)) <- op
770 , (lhs:rhs:_) <- args =
771 jsPackUBits16 (
772 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
773 )
775 | (LLSHR (ITFixed IT32)) <- op
776 , (lhs:rhs:_) <- args =
777 jsPackUBits32 (
778 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
779 )
781 | (LLSHR (ITFixed IT64)) <- op
782 , (lhs:rhs:_) <- args =
783 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
785 | (LSHL (ITFixed IT8)) <- op
786 , (lhs:rhs:_) <- args =
787 jsPackUBits8 (
788 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
789 )
791 | (LSHL (ITFixed IT16)) <- op
792 , (lhs:rhs:_) <- args =
793 jsPackUBits16 (
794 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
795 )
797 | (LSHL (ITFixed IT32)) <- op
798 , (lhs:rhs:_) <- args =
799 jsPackUBits32 (
800 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
801 )
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 =
811 jsPackUBits8 (
812 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
813 )
815 | (LAnd (ITFixed IT16)) <- op
816 , (lhs:rhs:_) <- args =
817 jsPackUBits16 (
818 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
819 )
821 | (LAnd (ITFixed IT32)) <- op
822 , (lhs:rhs:_) <- args =
823 jsPackUBits32 (
824 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
825 )
827 | (LAnd (ITFixed IT64)) <- op
828 , (lhs:rhs:_) <- args =
829 jsMeth (translateReg lhs) "and" [translateReg rhs]
831 | (LOr (ITFixed IT8)) <- op
832 , (lhs:rhs:_) <- args =
833 jsPackUBits8 (
834 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
835 )
837 | (LOr (ITFixed IT16)) <- op
838 , (lhs:rhs:_) <- args =
839 jsPackUBits16 (
840 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
841 )
843 | (LOr (ITFixed IT32)) <- op
844 , (lhs:rhs:_) <- args =
845 jsPackUBits32 (
846 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
847 )
849 | (LOr (ITFixed IT64)) <- op
850 , (lhs:rhs:_) <- args =
851 jsMeth (translateReg lhs) "or" [translateReg rhs]
853 | (LXOr (ITFixed IT8)) <- op
854 , (lhs:rhs:_) <- args =
855 jsPackUBits8 (
856 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
857 )
859 | (LXOr (ITFixed IT16)) <- op
860 , (lhs:rhs:_) <- args =
861 jsPackUBits16 (
862 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
863 )
865 | (LXOr (ITFixed IT32)) <- op
866 , (lhs:rhs:_) <- args =
867 jsPackUBits32 (
868 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
869 )
871 | (LXOr (ITFixed IT64)) <- op
872 , (lhs:rhs:_) <- args =
873 jsMeth (translateReg lhs) "xor" [translateReg rhs]
875 | (LPlus (ATInt (ITFixed IT8))) <- op
876 , (lhs:rhs:_) <- args =
877 jsPackUBits8 (
878 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
879 )
881 | (LPlus (ATInt (ITFixed IT16))) <- op
882 , (lhs:rhs:_) <- args =
883 jsPackUBits16 (
884 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
885 )
887 | (LPlus (ATInt (ITFixed IT32))) <- op
888 , (lhs:rhs:_) <- args =
889 jsPackUBits32 (
890 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
891 )
893 | (LPlus (ATInt (ITFixed IT64))) <- op
894 , (lhs:rhs:_) <- args =
895 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
896 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
897 ]
899 | (LMinus (ATInt (ITFixed IT8))) <- op
900 , (lhs:rhs:_) <- args =
901 jsPackUBits8 (
902 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
903 )
905 | (LMinus (ATInt (ITFixed IT16))) <- op
906 , (lhs:rhs:_) <- args =
907 jsPackUBits16 (
908 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
909 )
911 | (LMinus (ATInt (ITFixed IT32))) <- op
912 , (lhs:rhs:_) <- args =
913 jsPackUBits32 (
914 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
915 )
917 | (LMinus (ATInt (ITFixed IT64))) <- op
918 , (lhs:rhs:_) <- args =
919 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
920 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
921 ]
923 | (LTimes (ATInt (ITFixed IT8))) <- op
924 , (lhs:rhs:_) <- args =
925 jsPackUBits8 (
926 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
927 )
929 | (LTimes (ATInt (ITFixed IT16))) <- op
930 , (lhs:rhs:_) <- args =
931 jsPackUBits16 (
932 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
933 )
935 | (LTimes (ATInt (ITFixed IT32))) <- op
936 , (lhs:rhs:_) <- args =
937 jsPackUBits32 (
938 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
939 )
941 | (LTimes (ATInt (ITFixed IT64))) <- op
942 , (lhs:rhs:_) <- args =
943 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
944 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
945 ]
947 | (LEq (ATInt (ITFixed IT8))) <- op
948 , (lhs:rhs:_) <- args =
949 jsPackUBits8 (
950 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
951 )
953 | (LEq (ATInt (ITFixed IT16))) <- op
954 , (lhs:rhs:_) <- args =
955 jsPackUBits16 (
956 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
957 )
959 | (LEq (ATInt (ITFixed IT32))) <- op
960 , (lhs:rhs:_) <- args =
961 jsPackUBits32 (
962 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
963 )
965 | (LEq (ATInt (ITFixed IT64))) <- op
966 , (lhs:rhs:_) <- args =
967 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
968 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
969 ]
971 | (LLt (ITFixed IT8)) <- op
972 , (lhs:rhs:_) <- args =
973 jsPackUBits8 (
974 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
975 )
977 | (LLt (ITFixed IT16)) <- op
978 , (lhs:rhs:_) <- args =
979 jsPackUBits16 (
980 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
981 )
983 | (LLt (ITFixed IT32)) <- op
984 , (lhs:rhs:_) <- args =
985 jsPackUBits32 (
986 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
987 )
989 | (LLt (ITFixed IT64)) <- op
990 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
992 | (LLe (ITFixed IT8)) <- op
993 , (lhs:rhs:_) <- args =
994 jsPackUBits8 (
995 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
996 )
998 | (LLe (ITFixed IT16)) <- op
999 , (lhs:rhs:_) <- args =
1000 jsPackUBits16 (
1001 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1004 | (LLe (ITFixed IT32)) <- op
1005 , (lhs:rhs:_) <- args =
1006 jsPackUBits32 (
1007 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1010 | (LLe (ITFixed IT64)) <- op
1011 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1013 | (LGt (ITFixed IT8)) <- op
1014 , (lhs:rhs:_) <- args =
1015 jsPackUBits8 (
1016 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1019 | (LGt (ITFixed IT16)) <- op
1020 , (lhs:rhs:_) <- args =
1021 jsPackUBits16 (
1022 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1024 | (LGt (ITFixed IT32)) <- op
1025 , (lhs:rhs:_) <- args =
1026 jsPackUBits32 (
1027 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1030 | (LGt (ITFixed IT64)) <- op
1031 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1033 | (LGe (ITFixed IT8)) <- op
1034 , (lhs:rhs:_) <- args =
1035 jsPackUBits8 (
1036 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1039 | (LGe (ITFixed IT16)) <- op
1040 , (lhs:rhs:_) <- args =
1041 jsPackUBits16 (
1042 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1044 | (LGe (ITFixed IT32)) <- op
1045 , (lhs:rhs:_) <- args =
1046 jsPackUBits32 (
1047 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1050 | (LGe (ITFixed IT64)) <- op
1051 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1053 | (LUDiv (ITFixed IT8)) <- op
1054 , (lhs:rhs:_) <- args =
1055 jsPackUBits8 (
1056 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1059 | (LUDiv (ITFixed IT16)) <- op
1060 , (lhs:rhs:_) <- args =
1061 jsPackUBits16 (
1062 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1065 | (LUDiv (ITFixed IT32)) <- op
1066 , (lhs:rhs:_) <- args =
1067 jsPackUBits32 (
1068 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1071 | (LUDiv (ITFixed IT64)) <- op
1072 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1074 | (LSDiv (ATInt (ITFixed IT8))) <- op
1075 , (lhs:rhs:_) <- args =
1076 jsPackSBits8 (
1077 JSBinOp "/" (
1078 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1079 ) (
1080 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1084 | (LSDiv (ATInt (ITFixed IT16))) <- op
1085 , (lhs:rhs:_) <- args =
1086 jsPackSBits16 (
1087 JSBinOp "/" (
1088 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1089 ) (
1090 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1094 | (LSDiv (ATInt (ITFixed IT32))) <- op
1095 , (lhs:rhs:_) <- args =
1096 jsPackSBits32 (
1097 JSBinOp "/" (
1098 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1099 ) (
1100 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1104 | (LSDiv (ATInt (ITFixed IT64))) <- op
1105 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1107 | (LSRem (ATInt (ITFixed IT8))) <- op
1108 , (lhs:rhs:_) <- args =
1109 jsPackSBits8 (
1110 JSBinOp "%" (
1111 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1112 ) (
1113 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1117 | (LSRem (ATInt (ITFixed IT16))) <- op
1118 , (lhs:rhs:_) <- args =
1119 jsPackSBits16 (
1120 JSBinOp "%" (
1121 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1122 ) (
1123 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1127 | (LSRem (ATInt (ITFixed IT32))) <- op
1128 , (lhs:rhs:_) <- args =
1129 jsPackSBits32 (
1130 JSBinOp "%" (
1131 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1132 ) (
1133 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1137 | (LSRem (ATInt (ITFixed IT64))) <- op
1138 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1140 | (LCompl (ITFixed IT8)) <- op
1141 , (arg:_) <- args =
1142 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1144 | (LCompl (ITFixed IT16)) <- op
1145 , (arg:_) <- args =
1146 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1148 | (LCompl (ITFixed IT32)) <- op
1149 , (arg:_) <- args =
1150 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1152 | (LCompl (ITFixed IT64)) <- op
1153 , (arg:_) <- args =
1154 invokeMeth arg "not" []
1156 | (LPlus _) <- op
1157 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1158 | (LMinus _) <- op
1159 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1160 | (LTimes _) <- op
1161 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1162 | (LSDiv _) <- op
1163 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1164 | (LSRem _) <- op
1165 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1166 | (LEq _) <- op
1167 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1168 | (LSLt _) <- op
1169 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1170 | (LSLe _) <- op
1171 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1172 | (LSGt _) <- op
1173 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1174 | (LSGe _) <- op
1175 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1176 | (LAnd _) <- op
1177 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1178 | (LOr _) <- op
1179 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1180 | (LXOr _) <- op
1181 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1182 | (LSHL _) <- op
1183 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1184 | (LASHR _) <- op
1185 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1186 | (LCompl _) <- op
1187 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1189 | LStrConcat <- op
1190 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1191 | LStrEq <- op
1192 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1193 | LStrLt <- op
1194 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1195 | LStrLen <- op
1196 , (arg:_) <- args = JSProj (translateReg arg) "length"
1197 | (LStrInt ITNative) <- op
1198 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1199 | (LIntStr ITNative) <- op
1200 , (arg:_) <- args = jsCall "String" [translateReg arg]
1201 | (LSExt ITNative ITBig) <- op
1202 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1203 | (LTrunc ITBig ITNative) <- op
1204 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1205 | (LIntStr ITBig) <- op
1206 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1207 | (LStrInt ITBig) <- op
1208 , (arg:_) <- args = jsBigInt $ translateReg arg
1209 | LFloatStr <- op
1210 , (arg:_) <- args = jsCall "String" [translateReg arg]
1211 | LStrFloat <- op
1212 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1213 | (LIntFloat ITNative) <- op
1214 , (arg:_) <- args = translateReg arg
1215 | (LIntFloat ITBig) <- op
1216 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1217 | (LFloatInt ITNative) <- op
1218 , (arg:_) <- args = translateReg arg
1219 | (LChInt ITNative) <- op
1220 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1221 | (LIntCh ITNative) <- op
1222 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1224 | LFExp <- op
1225 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1226 | LFLog <- op
1227 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1228 | LFSin <- op
1229 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1230 | LFCos <- op
1231 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1232 | LFTan <- op
1233 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1234 | LFASin <- op
1235 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1236 | LFACos <- op
1237 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1238 | LFATan <- op
1239 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1240 | LFSqrt <- op
1241 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1242 | LFFloor <- op
1243 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1244 | LFCeil <- op
1245 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1246 | LFNegate <- op
1247 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1249 | LStrCons <- op
1250 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1251 | LStrHead <- op
1252 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1253 | LStrRev <- op
1254 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1255 | LStrIndex <- op
1256 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1257 | LStrTail <- op
1258 , (arg:_) <- args =
1259 let v = translateReg arg in
1260 JSApp (JSProj v "substr") [
1261 JSNum (JSInt 1),
1262 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1265 | LSystemInfo <- op
1266 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1267 | LExternal nul <- op
1268 , nul == sUN "prim__null"
1269 , (_) <- args = JSNull
1270 | otherwise = JSError $ "Not implemented: " ++ show op
1271 where
1272 translateBinaryOp :: String -> Reg -> Reg -> JS
1273 translateBinaryOp op lhs rhs =
1274 JSBinOp op (translateReg lhs) (translateReg rhs)
1276 invokeMeth :: Reg -> String -> [Reg] -> JS
1277 invokeMeth obj meth args =
1278 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1281jsRESERVE :: CompileInfo -> Int -> JS
1282jsRESERVE _ _ = JSNoop
1284jsSTACK :: JS
1285jsSTACK = JSIdent "i$valstack"
1287jsCALLSTACK :: JS
1288jsCALLSTACK = JSIdent "i$callstack"
1290jsSTACKBASE :: JS
1291jsSTACKBASE = JSIdent "i$valstack_base"
1293jsSTACKTOP :: JS
1294jsSTACKTOP = JSIdent "i$valstack_top"
1296jsOLDBASE :: JS
1297jsOLDBASE = JSIdent "oldbase"
1299jsMYOLDBASE :: JS
1300jsMYOLDBASE = JSIdent "myoldbase"
1302jsRET :: JS
1303jsRET = JSIdent "i$ret"
1305jsLOC :: Int -> JS
1306jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1307jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1309jsTOP :: Int -> JS
1310jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1311jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1313jsPUSH :: [JS] -> JS
1314jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1316jsPOP :: JS
1317jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1319translateBC :: CompileInfo -> BC -> JS
1320translateBC info bc
1321 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1322 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1323 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1324 | ADDTOP n <- bc = jsADDTOP info n
1325 | NULL r <- bc = jsNULL info r
1326 | CALL n <- bc = jsCALL info n
1327 | TAILCALL n <- bc = jsTAILCALL info n
1328 | FOREIGNCALL r _ (FStr n) args
1329 <- bc = jsFOREIGN info r n (map fcall args)
1330 | FOREIGNCALL _ _ _ _ <- bc = error "JS FFI call not statically known"
1331 | TOPBASE n <- bc = jsTOPBASE info n
1332 | BASETOP n <- bc = jsBASETOP info n
1333 | STOREOLD <- bc = jsSTOREOLD info
1334 | SLIDE n <- bc = jsSLIDE info n
1335 | REBASE <- bc = jsREBASE info
1336 | RESERVE n <- bc = jsRESERVE info n
1337 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1338 | CASE s r c d <- bc = jsCASE info s r c d
1339 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1340 | PROJECT r l a <- bc = jsPROJECT info r l a
1341 | OP r o a <- bc = jsOP info r o a
1342 | ERROR e <- bc = jsERROR info e
1343 | otherwise = JSRaw $ "//" ++ show bc
1344 where fcall (t, arg) = (toFType t, arg)
1346toAType (FCon i)
1347 | i == sUN "JS_IntChar" = ATInt ITChar
1348 | i == sUN "JS_IntNative" = ATInt ITNative
1349toAType t = error (show t ++ " not defined in toAType")
1351toFnType (FApp c [_,_,s,t])
1352 | c == sUN "JS_Fn" = toFnType t
1353toFnType (FApp c [_,_,r])
1354 | c == sUN "JS_FnIO" = FFunctionIO
1355toFnType (FApp c [_,r])
1356 | c == sUN "JS_FnBase" = FFunction
1357toFnType t = error (show t ++ " not defined in toFnType")
1359toFType (FCon c)
1360 | c == sUN "JS_Str" = FString
1361 | c == sUN "JS_Float" = FArith ATFloat
1362 | c == sUN "JS_Ptr" = FPtr
1363 | c == sUN "JS_Unit" = FUnit
1364toFType (FApp c [_,ity])
1365 | c == sUN "JS_IntT" = FArith (toAType ity)
1366toFType (FApp c [_,fty])
1367 | c == sUN "JS_FnT" = toFnType fty
1368toFType t = error (show t ++ " not yet defined in toFType")