git.iko.soy/Idris-dev
on 735fbd2 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1321 lines 49 kB history raw
1{-|
2Module : IRTS.CodegenJavaScript
3Description : The JavaScript code generator.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE OverloadedStrings, PatternGuards #-}
9module IRTS.CodegenJavaScript (codegenJavaScript
10 , codegenNode
11 , JSTarget(..)
12 ) where
14import Idris.AbsSyntax hiding (TypeCase)
15import Idris.Core.TT
16import IRTS.Bytecode
17import IRTS.CodegenCommon
18import IRTS.Defunctionalise
19import IRTS.Exports
20import IRTS.JavaScript.AST
21import IRTS.Lang
22import IRTS.Simplified
23import IRTS.System
24import Util.System
26import Control.Applicative (pure, (<$>), (<*>))
27import Control.Arrow
28import Control.Monad (mapM)
29import Control.Monad.RWS hiding (mapM)
30import Control.Monad.State
31import Data.Char
32import Data.List
33import qualified Data.Map.Strict as M
34import Data.Maybe
35import qualified Data.Text as T
36import qualified Data.Text.IO as TIO
37import Data.Traversable hiding (mapM)
38import Data.Word
39import Numeric
40import System.Directory
41import System.FilePath
42import System.IO
45data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
46 , compileInfoEvalCases :: [Int]
47 , compileInfoNeedsBigInt :: Bool
48 }
51initCompileInfo :: [(Name, [BC])] -> CompileInfo
52initCompileInfo bc =
53 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
54 where
55 lookupBigInt :: [(Name, [BC])] -> Bool
56 lookupBigInt = any (needsBigInt . snd)
57 where
58 needsBigInt :: [BC] -> Bool
59 needsBigInt bc = any testBCForBigInt bc
60 where
61 testBCForBigInt :: BC -> Bool
62 testBCForBigInt (ASSIGNCONST _ c) =
63 testConstForBigInt c
65 testBCForBigInt (CONSTCASE _ c d) =
66 maybe False needsBigInt d
67 || any (needsBigInt . snd) c
68 || any (testConstForBigInt . fst) c
70 testBCForBigInt (CASE _ _ c d) =
71 maybe False needsBigInt d
72 || any (needsBigInt . snd) c
74 testBCForBigInt _ = False
76 testConstForBigInt :: Const -> Bool
77 testConstForBigInt (BI _) = True
78 testConstForBigInt (B64 _) = True
79 testConstForBigInt _ = False
82 collectCases :: String -> [(Name, [BC])] -> [Int]
83 collectCases fun bc = getCases $ findFunction fun bc
85 findFunction :: String -> [(Name, [BC])] -> [BC]
86 findFunction f ((MN 0 fun, bc):_)
87 | fun == txt f = bc
88 findFunction f (_:bc) = findFunction f bc
90 getCases :: [BC] -> [Int]
91 getCases = concatMap analyze
92 where
93 analyze :: BC -> [Int]
94 analyze (CASE _ _ b _) = map fst b
95 analyze _ = []
98data JSTarget = Node | JavaScript deriving Eq
101codegenJavaScript :: CodeGenerator
102codegenJavaScript ci =
103 codegenJS_all JavaScript (simpleDecls ci)
104 (includes ci) [] (outputFile ci) (exportDecls ci) (outputType ci)
106codegenNode :: CodeGenerator
107codegenNode ci =
108 codegenJS_all Node (simpleDecls ci)
109 (includes ci) (compileLibs ci) (outputFile ci) (exportDecls ci) (outputType ci)
111codegenJS_all
112 :: JSTarget
113 -> [(Name, SDecl)]
114 -> [FilePath]
115 -> [String]
116 -> FilePath
117 -> [ExportIFace]
118 -> OutputType
119 -> IO ()
120codegenJS_all target definitions includes libs filename exports outputType = do
121 let bytecode = map toBC definitions
122 let info = initCompileInfo bytecode
123 let js = concatMap (translateDecl info) bytecode
124 let full = concatMap processFunction js
125 let exportedNames = map translateName ((getExpNames exports) ++ [sUN "call__IO"])
126 let code = deadCodeElim exportedNames 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 <- getIdrisJSRTSDir
138 idrRuntime <- readFile $ path </> "Runtime-common.js"
139 tgtRuntime <- readFile $ path </> concat ["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` T.concat (map compileJS (map genInterface (concatMap getExps exports)))
154 `T.append` main
155 `T.append` invokeMain
156 let source = if isHtml
157 then htmlPrologue `T.append` jsSource `T.append` htmlEpilogue
158 else jsSource
159 writeSourceText filename source
160 setPermissions filename (emptyPermissions { readable = True
161 , executable = target == Node
162 , writable = True
163 })
164 where
165 deadCodeElim :: [String] -> [JS] -> [JS]
166 deadCodeElim exports js = concatMap (collectFunctions exports) js
167 where
168 collectFunctions :: [String] -> JS -> [JS]
169 collectFunctions _ fun@(JSAlloc name _)
170 | name == translateName (sMN 0 "runMain") = [fun]
172 collectFunctions exports fun@(JSAlloc name _)
173 | name `elem` exports = [fun]
175 collectFunctions _ fun@(JSAlloc name (Just (JSFunction _ body))) =
176 let invokations = sum $ map (
177 \x -> execState (countInvokations name x) 0
178 ) js
179 in if invokations == 0
180 then []
181 else [fun]
183 countInvokations :: String -> JS -> State Int ()
184 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
185 countInvokations name body
187 countInvokations name (JSSeq seq) =
188 void $ traverse (countInvokations name) seq
190 countInvokations name (JSAssign _ rhs) =
191 countInvokations name rhs
193 countInvokations name (JSCond conds) =
194 void $ traverse (
195 runKleisli $ arr id *** Kleisli (countInvokations name)
196 ) conds
198 countInvokations name (JSSwitch _ conds def) =
199 void $ traverse (
200 runKleisli $ arr id *** Kleisli (countInvokations name)
201 ) conds >> traverse (countInvokations name) def
203 countInvokations name (JSApp lhs rhs) =
204 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
206 countInvokations name (JSNew _ args) =
207 void $ traverse (countInvokations name) args
209 countInvokations name (JSArray args) =
210 void $ traverse (countInvokations name) args
212 countInvokations name (JSIdent name')
213 | name == name' = get >>= put . (+1)
214 | otherwise = return ()
216 countInvokations _ _ = return ()
218 processFunction :: JS -> [JS]
219 processFunction =
220 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
222 includeLibs :: [String] -> String
223 includeLibs =
224 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
226 getIncludes :: [FilePath] -> IO [String]
227 getIncludes = mapM readFile
229 main :: T.Text
230 main =
231 compileJS $ JSAlloc "main" (Just $
232 JSFunction [] (
233 case target of
234 Node -> mainFun
235 JavaScript -> jsMain
236 )
237 )
239 jsMain :: JS
240 jsMain =
241 JSCond [ (exists document `jsAnd` isReady, mainFun)
242 , (exists window, windowMainFun)
243 , (JSTrue, mainFun)
244 ]
245 where
246 exists :: JS -> JS
247 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
249 window :: JS
250 window = JSIdent "window"
252 document :: JS
253 document = JSIdent "document"
255 windowMainFun :: JS
256 windowMainFun =
257 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
258 , JSFunction [] ( mainFun )
259 , JSFalse
260 ]
262 isReady :: JS
263 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
265 readyState :: JS
266 readyState = JSProj (JSIdent "document") "readyState"
268 mainFun :: JS
269 mainFun =
270 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
271 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
272 , JSApp (
273 JSIdent (translateName (sMN 0 "runMain"))
274 ) [JSNew "i$POINTER" [JSNum (JSInt 0)]]
275 , JSApp (JSIdent "i$RUN") []
276 ]
278 invokeMain :: T.Text
279 invokeMain = compileJS $ JSApp (JSIdent "main") []
280 getExps (Export _ _ exp) = exp
282optimizeConstructors :: [JS] -> ([JS], [JS])
283optimizeConstructors js =
284 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
285 (map (allocCon . snd) (M.toList cons), js')
286 where
287 allocCon :: (String, JS) -> JS
288 allocCon (name, con) = JSAlloc name (Just con)
290 newConstructor :: Int -> String
291 newConstructor n = "i$CON$" ++ show n
293 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
294 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
295 , JSArray []
296 , a
297 , e
298 ]) = do
299 s <- get
300 case M.lookup tag s of
301 Just (i, c) -> return $ JSIdent i
302 Nothing -> do let n = newConstructor tag
303 put $ M.insert tag (n, js) s
304 return $ JSIdent n
306 optimizeConstructor' (JSSeq seq) =
307 JSSeq <$> traverse optimizeConstructor' seq
309 optimizeConstructor' (JSSwitch reg cond def) = do
310 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
311 def' <- traverse optimizeConstructor' def
312 return $ JSSwitch reg cond' def'
314 optimizeConstructor' (JSCond cond) =
315 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
317 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
318 body' <- optimizeConstructor' body
319 return $ JSAlloc fun (Just (JSFunction args body'))
321 optimizeConstructor' (JSAssign lhs rhs) = do
322 lhs' <- optimizeConstructor' lhs
323 rhs' <- optimizeConstructor' rhs
324 return $ JSAssign lhs' rhs'
326 optimizeConstructor' js = return js
328collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
329collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
330 where
331 generateSplitFunction :: (Int,JS) -> JS
332 generateSplitFunction (depth, JSAlloc name fun) =
333 JSAlloc (name ++ "$" ++ show depth) fun
335splitFunction :: JS -> RWS () [(Int,JS)] Int JS
336splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
337 body' <- splitSequence body
338 return $ JSAlloc name (Just (JSFunction args body'))
339 where
340 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
341 splitCondition js
342 | JSCond branches <- js =
343 JSCond <$> processBranches branches
344 | JSSwitch cond branches def <- js =
345 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
346 | otherwise = return js
347 where
348 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
349 processBranches =
350 traverse (runKleisli (arr id *** Kleisli splitSequence))
352 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
353 splitSequence js@(JSSeq seq) =
354 let (pre,post) = break isBranch seq in
355 case post of
356 [_] -> JSSeq <$> traverse splitCondition seq
357 [call@(JSCond _),rest@(JSApp _ _)] -> do
358 rest' <- splitCondition rest
359 call' <- splitCondition call
360 return $ JSSeq (pre ++ [rest', call'])
361 [call@(JSSwitch _ _ _),rest@(JSApp _ _)] -> do
362 rest' <- splitCondition rest
363 call' <- splitCondition call
364 return $ JSSeq (pre ++ [rest', call'])
365 (call:rest) -> do
366 depth <- get
367 put (depth + 1)
368 new <- splitFunction (newFun rest)
369 tell [(depth, new)]
370 call' <- splitCondition call
371 return $ JSSeq (pre ++ (newCall depth : [call']))
372 _ -> JSSeq <$> traverse splitCondition seq
374 splitSequence js = return js
376 isBranch :: JS -> Bool
377 isBranch (JSApp (JSIdent "i$CALL") _) = True
378 isBranch (JSCond _) = True
379 isBranch (JSSwitch _ _ _) = True
380 isBranch _ = False
382 newCall :: Int -> JS
383 newCall depth =
384 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
385 , JSArray [jsOLDBASE, jsMYOLDBASE]
386 ]
388 newFun :: [JS] -> JS
389 newFun seq =
390 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
392splitFunction js = return js
394translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
395translateDecl info (name@(MN 0 fun), bc)
396 | txt "APPLY" == fun =
397 allocCaseFunctions (snd body)
398 ++ [ JSAlloc (
399 translateName name
400 ) (Just $ JSFunction ["oldbase"] (
401 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
402 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
403 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
404 )
405 , ( JSNoop
406 , JSSeq $ map (translateBC info) (defaultCase (snd body))
407 )
408 ]
409 ]
410 )
411 )
412 ]
414 | txt "EVAL" == fun =
415 allocCaseFunctions (snd body)
416 ++ [ JSAlloc (
417 translateName name
418 ) (Just $ JSFunction ["oldbase"] (
419 JSSeq $ jsFUNPRELUDE ++ map (translateBC info) (fst body) ++ [
420 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
421 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
422 )
423 , ( JSNoop
424 , JSSeq $ map (translateBC info) (defaultCase (snd body))
425 )
426 ]
427 ]
428 )
429 )
430 ]
431 where
432 body :: ([BC], [BC])
433 body = break isCase bc
435 isCase :: BC -> Bool
436 isCase bc
437 | CASE {} <- bc = True
438 | otherwise = False
440 defaultCase :: [BC] -> [BC]
441 defaultCase ((CASE _ _ _ (Just d)):_) = d
443 caseReg :: [BC] -> Reg
444 caseReg ((CASE _ r _ _):_) = r
446 allocCaseFunctions :: [BC] -> [JS]
447 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
448 allocCaseFunctions _ = []
450 splitBranches :: [(Int, [BC])] -> [JS]
451 splitBranches = map prepBranch
453 prepBranch :: (Int, [BC]) -> JS
454 prepBranch (tag, code) =
455 JSAlloc (
456 translateName name ++ "$" ++ show tag
457 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
458 JSSeq $ map (translateBC info) code
459 )
460 )
462translateDecl info (name, bc) =
463 [ JSAlloc (
464 translateName name
465 ) (Just $ JSFunction ["oldbase"] (
466 JSSeq $ jsFUNPRELUDE ++ map (translateBC info)bc
467 )
468 )
469 ]
471jsFUNPRELUDE :: [JS]
472jsFUNPRELUDE = [jsALLOCMYOLDBASE]
474jsALLOCMYOLDBASE :: JS
475jsALLOCMYOLDBASE = JSAlloc "myoldbase" (Just $ JSNew "i$POINTER" [])
477translateReg :: Reg -> JS
478translateReg reg
479 | RVal <- reg = jsRET
480 | Tmp <- reg = JSRaw "//TMPREG"
481 | L n <- reg = jsLOC n
482 | T n <- reg = jsTOP n
484translateConstant :: Const -> JS
485translateConstant (I i) = JSNum (JSInt i)
486translateConstant (Fl f) = JSNum (JSFloat f)
487translateConstant (Ch c) = JSString $ translateChar c
488translateConstant (Str s) = JSString $ concatMap translateChar s
489translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
490translateConstant StrType = JSType JSStringTy
491translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
492translateConstant (AType ATFloat) = JSType JSFloatTy
493translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
494translateConstant Forgot = JSType JSForgotTy
495translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
496translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
497translateConstant (BI i) = jsBigInt (JSString $ show i)
498translateConstant (B8 b) = JSWord (JSWord8 b)
499translateConstant (B16 b) = JSWord (JSWord16 b)
500translateConstant (B32 b) = JSWord (JSWord32 b)
501translateConstant (B64 b) = JSWord (JSWord64 b)
502translateConstant c =
503 JSError $ "Unimplemented Constant: " ++ show c
506translateChar :: Char -> String
507translateChar ch
508 | '\a' <- ch = "\\u0007"
509 | '\b' <- ch = "\\b"
510 | '\f' <- ch = "\\f"
511 | '\n' <- ch = "\\n"
512 | '\r' <- ch = "\\r"
513 | '\t' <- ch = "\\t"
514 | '\v' <- ch = "\\v"
515 | '\SO' <- ch = "\\u000E"
516 | '\DEL' <- ch = "\\u007F"
517 | '\\' <- ch = "\\\\"
518 | '\"' <- ch = "\\\""
519 | '\'' <- ch = "\\\'"
520 | ch `elem` asciiTab = "\\u" ++ fill (showHex (ord ch) "")
521 | ord ch > 255 = "\\u" ++ fill (showHex (ord ch) "")
522 | otherwise = [ch]
523 where
524 fill :: String -> String
525 fill s = case length s of
526 1 -> "000" ++ s
527 2 -> "00" ++ s
528 3 -> "0" ++ s
529 _ -> s
531 asciiTab =
532 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
533 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
534 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
535 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
537translateName :: Name -> String
538translateName n = "_idris_" ++ concatMap cchar (showCG n)
539 where cchar x | isAlphaNum x = [x]
540 | otherwise = "_" ++ show (fromEnum x) ++ "_"
542jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
543jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
545jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
546jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
548jsCALL :: CompileInfo -> Name -> JS
549jsCALL _ n =
550 JSApp (
551 JSIdent "i$CALL"
552 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
554jsTAILCALL :: CompileInfo -> Name -> JS
555jsTAILCALL _ n =
556 JSApp (
557 JSIdent "i$CALL"
558 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
560jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
561jsFOREIGN _ reg n args
562 | n == "isNull"
563 , [(FPtr, arg)] <- args =
564 JSAssign (
565 translateReg reg
566 ) (
567 JSBinOp "==" (translateReg arg) JSNull
568 )
570 | n == "idris_eqPtr"
571 , [(_, lhs),(_, rhs)] <- args =
572 JSAssign (
573 translateReg reg
574 ) (
575 JSBinOp "==" (translateReg lhs) (translateReg rhs)
576 )
577 | otherwise =
578 JSAssign (
579 translateReg reg
580 ) (
581 JSFFI n (map generateWrapper args)
582 )
583 where
584 generateWrapper :: (FType, Reg) -> JS
585 generateWrapper (ty, reg)
586 | FFunction <- ty =
587 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
588 , JSIdent "oldbase"
589 , JSIdent "myoldbase"
590 ]
591 | FFunctionIO <- ty =
592 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
593 , JSIdent "oldbase"
594 , JSIdent "myoldbase"
595 ]
597 generateWrapper (_, reg) =
598 translateReg reg
600jsREBASE :: CompileInfo -> JS
601jsREBASE _ = JSAssign jsSTACKBASE (JSProj jsOLDBASE "addr")
603jsSTOREOLD :: CompileInfo ->JS
604jsSTOREOLD _ = JSAssign (JSProj jsMYOLDBASE "addr") jsSTACKBASE
606jsADDTOP :: CompileInfo -> Int -> JS
607jsADDTOP info n
608 | 0 <- n = JSNoop
609 | otherwise =
610 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
612jsTOPBASE :: CompileInfo -> Int -> JS
613jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
614jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
617jsBASETOP :: CompileInfo -> Int -> JS
618jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
619jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
621jsNULL :: CompileInfo -> Reg -> JS
622jsNULL _ r = JSClear (translateReg r)
624jsERROR :: CompileInfo -> String -> JS
625jsERROR _ = JSError
627jsSLIDE :: CompileInfo -> Int -> JS
628jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
629jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
631jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
632jsMKCON info r t rs =
633 JSAssign (translateReg r) (
634 JSNew "i$CON" [ JSNum (JSInt t)
635 , JSArray (map translateReg rs)
636 , if t `elem` compileInfoApplyCases info
637 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
638 else JSNull
639 , if t `elem` compileInfoEvalCases info
640 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
641 else JSNull
642 ]
643 )
645jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
646jsCASE info safe reg cases def =
647 JSSwitch (tag safe $ translateReg reg) (
648 map ((JSNum . JSInt) *** prepBranch) cases
649 ) (fmap prepBranch def)
650 where
651 tag :: Bool -> JS -> JS
652 tag True = jsCTAG
653 tag False = jsTAG
655 prepBranch :: [BC] -> JS
656 prepBranch bc = JSSeq $ map (translateBC info) bc
658 jsTAG :: JS -> JS
659 jsTAG js =
660 (JSTernary (js `jsInstanceOf` "i$CON") (
661 JSProj js "tag"
662 ) (JSNum (JSInt $ negate 1)))
664 jsCTAG :: JS -> JS
665 jsCTAG js = JSProj js "tag"
668jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
669jsCONSTCASE info reg cases def =
670 JSCond $ (
671 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
672 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
673 where
674 prepBranch :: [BC] -> JS
675 prepBranch bc = JSSeq $ map (translateBC info) bc
677jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
678jsPROJECT _ reg loc 0 = JSNoop
679jsPROJECT _ reg loc 1 =
680 JSAssign (jsLOC loc) (
681 JSIndex (
682 JSProj (translateReg reg) "args"
683 ) (
684 JSNum (JSInt 0)
685 )
686 )
687jsPROJECT _ reg loc ar =
688 JSApp (JSIdent "i$PROJECT") [ translateReg reg
689 , JSNum (JSInt loc)
690 , JSNum (JSInt ar)
691 ]
693jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
694jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
695 where
696 jsOP' :: JS
697 jsOP'
698 | LNoOp <- op = translateReg (last args)
700 | LWriteStr <- op,
701 (_:str:_) <- args = JSApp (JSIdent "i$putStr") [translateReg str]
703 | LReadStr <- op = JSApp (JSIdent "i$getLine") []
705 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
706 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
707 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
709 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
710 | (LPlus (ATInt ITBig)) <- op
711 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
712 | (LMinus (ATInt ITBig)) <- op
713 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
714 | (LTimes (ATInt ITBig)) <- op
715 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
716 | (LSDiv (ATInt ITBig)) <- op
717 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
718 | (LSRem (ATInt ITBig)) <- op
719 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
720 | (LEq (ATInt ITBig)) <- op
721 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
722 | (LSLt (ATInt ITBig)) <- op
723 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
724 | (LSLe (ATInt ITBig)) <- op
725 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
726 | (LSGt (ATInt ITBig)) <- op
727 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
728 | (LSGe (ATInt ITBig)) <- op
729 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
731 | (LPlus ATFloat) <- op
732 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
733 | (LMinus ATFloat) <- op
734 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
735 | (LTimes ATFloat) <- op
736 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
737 | (LSDiv ATFloat) <- op
738 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
739 | (LEq ATFloat) <- op
740 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
741 | (LSLt ATFloat) <- op
742 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
743 | (LSLe ATFloat) <- op
744 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
745 | (LSGt ATFloat) <- op
746 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
747 | (LSGe ATFloat) <- op
748 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
750 | (LPlus (ATInt ITChar)) <- op
751 , (lhs:rhs:_) <- args =
752 jsCall "i$fromCharCode" [
753 JSBinOp "+" (
754 jsCall "i$charCode" [translateReg lhs]
755 ) (
756 jsCall "i$charCode" [translateReg rhs]
757 )
758 ]
760 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
761 , (arg:_) <- args =
762 jsPackUBits8 (
763 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
764 )
766 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
767 , (arg:_) <- args =
768 jsPackUBits16 (
769 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
770 )
772 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
773 , (arg:_) <- args =
774 jsPackUBits32 (
775 jsMeth (jsMeth (translateReg arg) "and" [
776 jsBigInt (JSString $ show 0xFFFFFFFF)
777 ]) "intValue" []
778 )
780 | (LTrunc ITBig (ITFixed IT64)) <- op
781 , (arg:_) <- args =
782 jsMeth (translateReg arg) "and" [
783 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
784 ]
786 | (LLSHR (ITFixed IT8)) <- op
787 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp ">>" lhs rhs
789 | (LLSHR (ITFixed IT16)) <- op
790 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp ">>" lhs rhs
792 | (LLSHR (ITFixed IT32)) <- op
793 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp ">>" lhs rhs
795 | (LLSHR (ITFixed IT64)) <- op
796 , (lhs:rhs:_) <- args =
797 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
799 | (LSHL (ITFixed IT8)) <- op
800 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "<<" lhs rhs
802 | (LSHL (ITFixed IT16)) <- op
803 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "<<" lhs rhs
805 | (LSHL (ITFixed IT32)) <- op
806 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "<<" lhs rhs
808 | (LSHL (ITFixed IT64)) <- op
809 , (lhs:rhs:_) <- args =
810 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
811 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
812 ]
814 | (LAnd (ITFixed IT8)) <- op
815 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "&" lhs rhs
817 | (LAnd (ITFixed IT16)) <- op
818 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "&" lhs rhs
820 | (LAnd (ITFixed IT32)) <- op
821 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "&" lhs rhs
823 | (LAnd (ITFixed IT64)) <- op
824 , (lhs:rhs:_) <- args =
825 jsMeth (translateReg lhs) "and" [translateReg rhs]
827 | (LOr (ITFixed IT8)) <- op
828 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "|" lhs rhs
830 | (LOr (ITFixed IT16)) <- op
831 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "|" lhs rhs
833 | (LOr (ITFixed IT32)) <- op
834 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "|" lhs rhs
836 | (LOr (ITFixed IT64)) <- op
837 , (lhs:rhs:_) <- args =
838 jsMeth (translateReg lhs) "or" [translateReg rhs]
840 | (LXOr (ITFixed IT8)) <- op
841 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "^" lhs rhs
843 | (LXOr (ITFixed IT16)) <- op
844 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "^" lhs rhs
846 | (LXOr (ITFixed IT32)) <- op
847 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "^" lhs rhs
849 | (LXOr (ITFixed IT64)) <- op
850 , (lhs:rhs:_) <- args =
851 jsMeth (translateReg lhs) "xor" [translateReg rhs]
853 | (LPlus (ATInt (ITFixed IT8))) <- op
854 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "+" lhs rhs
856 | (LPlus (ATInt (ITFixed IT16))) <- op
857 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "+" lhs rhs
859 | (LPlus (ATInt (ITFixed IT32))) <- op
860 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "+" lhs rhs
862 | (LPlus (ATInt (ITFixed IT64))) <- op
863 , (lhs:rhs:_) <- args =
864 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
865 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
866 ]
868 | (LMinus (ATInt (ITFixed IT8))) <- op
869 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "-" lhs rhs
871 | (LMinus (ATInt (ITFixed IT16))) <- op
872 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "-" lhs rhs
874 | (LMinus (ATInt (ITFixed IT32))) <- op
875 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "-" lhs rhs
877 | (LMinus (ATInt (ITFixed IT64))) <- op
878 , (lhs:rhs:_) <- args =
879 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
880 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
881 ]
883 | (LTimes (ATInt (ITFixed IT8))) <- op
884 , (lhs:rhs:_) <- args = jsPackUBits8 $ bitsBinaryOp "*" lhs rhs
886 | (LTimes (ATInt (ITFixed IT16))) <- op
887 , (lhs:rhs:_) <- args = jsPackUBits16 $ bitsBinaryOp "*" lhs rhs
889 | (LTimes (ATInt (ITFixed IT32))) <- op
890 , (lhs:rhs:_) <- args = jsPackUBits32 $ bitsBinaryOp "*" lhs rhs
892 | (LTimes (ATInt (ITFixed IT64))) <- op
893 , (lhs:rhs:_) <- args =
894 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
895 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
896 ]
898 | (LEq (ATInt (ITFixed IT8))) <- op
899 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
901 | (LEq (ATInt (ITFixed IT16))) <- op
902 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
904 | (LEq (ATInt (ITFixed IT32))) <- op
905 , (lhs:rhs:_) <- args = bitsCompareOp "==" lhs rhs
907 | (LEq (ATInt (ITFixed IT64))) <- op
908 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "equals" [rhs]
910 | (LLt (ITFixed IT8)) <- op
911 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
913 | (LLt (ITFixed IT16)) <- op
914 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
916 | (LLt (ITFixed IT32)) <- op
917 , (lhs:rhs:_) <- args = bitsCompareOp "<" lhs rhs
919 | (LLt (ITFixed IT64)) <- op
920 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesser" [rhs]
922 | (LLe (ITFixed IT8)) <- op
923 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
925 | (LLe (ITFixed IT16)) <- op
926 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
928 | (LLe (ITFixed IT32)) <- op
929 , (lhs:rhs:_) <- args = bitsCompareOp "<=" lhs rhs
931 | (LLe (ITFixed IT64)) <- op
932 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "lesserOrEquals" [rhs]
934 | (LGt (ITFixed IT8)) <- op
935 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
937 | (LGt (ITFixed IT16)) <- op
938 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
939 | (LGt (ITFixed IT32)) <- op
940 , (lhs:rhs:_) <- args = bitsCompareOp ">" lhs rhs
942 | (LGt (ITFixed IT64)) <- op
943 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greater" [rhs]
945 | (LGe (ITFixed IT8)) <- op
946 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
948 | (LGe (ITFixed IT16)) <- op
949 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
950 | (LGe (ITFixed IT32)) <- op
951 , (lhs:rhs:_) <- args = bitsCompareOp ">=" lhs rhs
953 | (LGe (ITFixed IT64)) <- op
954 , (lhs:rhs:_) <- args = JSPreOp "+" $ invokeMeth lhs "greaterOrEquals" [rhs]
956 | (LUDiv (ITFixed IT8)) <- op
957 , (lhs:rhs:_) <- args =
958 jsPackUBits8 (
959 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
960 )
962 | (LUDiv (ITFixed IT16)) <- op
963 , (lhs:rhs:_) <- args =
964 jsPackUBits16 (
965 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
966 )
968 | (LUDiv (ITFixed IT32)) <- op
969 , (lhs:rhs:_) <- args =
970 jsPackUBits32 (
971 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
972 )
974 | (LUDiv (ITFixed IT64)) <- op
975 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
977 | (LSDiv (ATInt (ITFixed IT8))) <- op
978 , (lhs:rhs:_) <- args =
979 jsPackSBits8 (
980 JSBinOp "/" (
981 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
982 ) (
983 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
984 )
985 )
987 | (LSDiv (ATInt (ITFixed IT16))) <- op
988 , (lhs:rhs:_) <- args =
989 jsPackSBits16 (
990 JSBinOp "/" (
991 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
992 ) (
993 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
994 )
995 )
997 | (LSDiv (ATInt (ITFixed IT32))) <- op
998 , (lhs:rhs:_) <- args =
999 jsPackSBits32 (
1000 JSBinOp "/" (
1001 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1002 ) (
1003 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1007 | (LSDiv (ATInt (ITFixed IT64))) <- op
1008 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1010 | (LSRem (ATInt (ITFixed IT8))) <- op
1011 , (lhs:rhs:_) <- args =
1012 jsPackSBits8 (
1013 JSBinOp "%" (
1014 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1015 ) (
1016 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1020 | (LSRem (ATInt (ITFixed IT16))) <- op
1021 , (lhs:rhs:_) <- args =
1022 jsPackSBits16 (
1023 JSBinOp "%" (
1024 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1025 ) (
1026 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1030 | (LSRem (ATInt (ITFixed IT32))) <- op
1031 , (lhs:rhs:_) <- args =
1032 jsPackSBits32 (
1033 JSBinOp "%" (
1034 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1035 ) (
1036 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1040 | (LSRem (ATInt (ITFixed IT64))) <- op
1041 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1043 | (LCompl (ITFixed IT8)) <- op
1044 , (arg:_) <- args =
1045 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1047 | (LCompl (ITFixed IT16)) <- op
1048 , (arg:_) <- args =
1049 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1051 | (LCompl (ITFixed IT32)) <- op
1052 , (arg:_) <- args =
1053 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1055 | (LCompl (ITFixed IT64)) <- op
1056 , (arg:_) <- args = invokeMeth arg "not" []
1058 | (LPlus _) <- op
1059 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1060 | (LMinus _) <- op
1061 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1062 | (LTimes _) <- op
1063 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1064 | (LSDiv _) <- op
1065 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1066 | (LSRem _) <- op
1067 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1068 | (LEq _) <- op
1069 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1070 | (LSLt _) <- op
1071 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1072 | (LSLe _) <- op
1073 , (lhs:rhs:_) <- args = translateCompareOp "<=" lhs rhs
1074 | (LSGt _) <- op
1075 , (lhs:rhs:_) <- args = translateCompareOp ">" lhs rhs
1076 | (LSGe _) <- op
1077 , (lhs:rhs:_) <- args = translateCompareOp ">=" lhs rhs
1078 | (LAnd _) <- op
1079 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1080 | (LOr _) <- op
1081 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1082 | (LXOr _) <- op
1083 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1084 | (LSHL _) <- op
1085 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1086 | (LASHR _) <- op
1087 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1088 | (LCompl _) <- op
1089 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1091 | LStrConcat <- op
1092 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1093 | LStrEq <- op
1094 , (lhs:rhs:_) <- args = translateCompareOp "==" lhs rhs
1095 | LStrLt <- op
1096 , (lhs:rhs:_) <- args = translateCompareOp "<" lhs rhs
1097 | LStrLen <- op
1098 , (arg:_) <- args = JSProj (translateReg arg) "length"
1099 | (LStrInt ITNative) <- op
1100 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1101 | (LIntStr ITNative) <- op
1102 , (arg:_) <- args = jsCall "String" [translateReg arg]
1103 | (LSExt ITNative ITBig) <- op
1104 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1105 | (LTrunc ITBig ITNative) <- op
1106 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1107 | (LIntStr ITBig) <- op
1108 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1109 | (LStrInt ITBig) <- op
1110 , (arg:_) <- args = jsBigInt $ translateReg arg
1111 | LFloatStr <- op
1112 , (arg:_) <- args = jsCall "String" [translateReg arg]
1113 | LStrFloat <- op
1114 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1115 | (LIntFloat ITNative) <- op
1116 , (arg:_) <- args = translateReg arg
1117 | (LIntFloat ITBig) <- op
1118 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1119 | (LFloatInt ITNative) <- op
1120 , (arg:_) <- args = translateReg arg
1121 | (LChInt ITNative) <- op
1122 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1123 | (LIntCh ITNative) <- op
1124 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1126 | LFExp <- op
1127 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1128 | LFLog <- op
1129 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1130 | LFSin <- op
1131 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1132 | LFCos <- op
1133 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1134 | LFTan <- op
1135 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1136 | LFASin <- op
1137 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1138 | LFACos <- op
1139 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1140 | LFATan <- op
1141 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1142 | LFSqrt <- op
1143 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1144 | LFFloor <- op
1145 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1146 | LFCeil <- op
1147 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1148 | LFNegate <- op
1149 , (arg:_) <- args = JSPreOp "-" (translateReg arg)
1151 | LStrCons <- op
1152 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1153 | LStrHead <- op
1154 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1155 | LStrRev <- op
1156 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1157 | LStrIndex <- op
1158 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1159 | LStrTail <- op
1160 , (arg:_) <- args =
1161 let v = translateReg arg in
1162 JSApp (JSProj v "substr") [
1163 JSNum (JSInt 1),
1164 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1166 | LStrSubstr <- op
1167 , (offset:length:string:_) <- args =
1168 let off = translateReg offset
1169 len = translateReg length
1170 str = translateReg string
1171 in JSApp (JSProj str "substr") [
1172 jsCall "Math.max" [JSNum (JSInt 0), off],
1173 jsCall "Math.max" [JSNum (JSInt 0), len]
1176 | LSystemInfo <- op
1177 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1178 | LExternal nul <- op
1179 , nul == sUN "prim__null"
1180 , _ <- args = JSNull
1181 | LExternal ex <- op
1182 , ex == sUN "prim__eqPtr"
1183 , [lhs, rhs] <- args = translateCompareOp "==" lhs rhs
1184 | otherwise = JSError $ "Not implemented: " ++ show op
1185 where
1186 translateBinaryOp :: String -> Reg -> Reg -> JS
1187 translateBinaryOp op lhs rhs =
1188 JSBinOp op (translateReg lhs) (translateReg rhs)
1190 translateCompareOp :: String -> Reg -> Reg -> JS
1191 translateCompareOp op lhs rhs =
1192 JSPreOp "+" $ translateBinaryOp op lhs rhs
1194 bitsBinaryOp :: String -> Reg -> Reg -> JS
1195 bitsBinaryOp op lhs rhs =
1196 JSBinOp op (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1198 bitsCompareOp :: String -> Reg -> Reg -> JS
1199 bitsCompareOp op lhs rhs =
1200 JSPreOp "+" $ bitsBinaryOp op lhs rhs
1202 invokeMeth :: Reg -> String -> [Reg] -> JS
1203 invokeMeth obj meth args =
1204 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1207jsRESERVE :: CompileInfo -> Int -> JS
1208jsRESERVE _ _ = JSNoop
1210jsSTACK :: JS
1211jsSTACK = JSIdent "i$valstack"
1213jsCALLSTACK :: JS
1214jsCALLSTACK = JSIdent "i$callstack"
1216jsSTACKBASE :: JS
1217jsSTACKBASE = JSIdent "i$valstack_base"
1219jsSTACKTOP :: JS
1220jsSTACKTOP = JSIdent "i$valstack_top"
1222jsOLDBASE :: JS
1223jsOLDBASE = JSIdent "oldbase"
1225jsMYOLDBASE :: JS
1226jsMYOLDBASE = JSIdent "myoldbase"
1228jsRET :: JS
1229jsRET = JSIdent "i$ret"
1231jsLOC :: Int -> JS
1232jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1233jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1235jsTOP :: Int -> JS
1236jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1237jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1239jsPUSH :: [JS] -> JS
1240jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1242jsPOP :: JS
1243jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1245genInterface :: Export -> JS
1246genInterface (ExportData name) = JSNoop
1247genInterface (ExportFun name (FStr jsName) ret args) = JSAlloc jsName
1248 (Just (JSFunction [] (JSSeq $
1249 jsFUNPRELUDE ++
1250 pushArgs nargs ++
1251 [jsSTOREOLD d,
1252 jsBASETOP d 0,
1253 jsADDTOP d nargs,
1254 jsCALL d name] ++
1255 retval ret)))
1256 where
1257 nargs = length args
1258 d = CompileInfo [] [] False
1259 pushArg n = JSAssign (jsTOP n) (JSIndex (JSIdent "arguments") (JSNum (JSInt n)))
1260 pushArgs 0 = []
1261 pushArgs n = (pushArg (n-1)):pushArgs (n-1)
1262 retval (FIO t) = [JSApp (JSIdent "i$RUN") [],
1263 JSAssign (jsTOP 0) JSNull,
1264 JSAssign (jsTOP 1) JSNull,
1265 JSAssign (jsTOP 2) (translateReg RVal),
1266 jsSTOREOLD d,
1267 jsBASETOP d 0,
1268 jsADDTOP d 3,
1269 jsCALL d (sUN "call__IO")] ++ retval t
1270 retval t = [JSApp (JSIdent "i$RUN") [], JSReturn (translateReg RVal)]
1272translateBC :: CompileInfo -> BC -> JS
1273translateBC info bc
1274 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1275 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1276 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1277 | ADDTOP n <- bc = jsADDTOP info n
1278 | NULL r <- bc = jsNULL info r
1279 | CALL n <- bc = jsCALL info n
1280 | TAILCALL n <- bc = jsTAILCALL info n
1281 | FOREIGNCALL r _ (FStr n) args
1282 <- bc = jsFOREIGN info r n (map fcall args)
1283 | FOREIGNCALL _ _ _ _ <- bc = error "JS FFI call not statically known"
1284 | TOPBASE n <- bc = jsTOPBASE info n
1285 | BASETOP n <- bc = jsBASETOP info n
1286 | STOREOLD <- bc = jsSTOREOLD info
1287 | SLIDE n <- bc = jsSLIDE info n
1288 | REBASE <- bc = jsREBASE info
1289 | RESERVE n <- bc = jsRESERVE info n
1290 | MKCON r _ t rs <- bc = jsMKCON info r t rs
1291 | CASE s r c d <- bc = jsCASE info s r c d
1292 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1293 | PROJECT r l a <- bc = jsPROJECT info r l a
1294 | OP r o a <- bc = jsOP info r o a
1295 | ERROR e <- bc = jsERROR info e
1296 | otherwise = JSRaw $ "//" ++ show bc
1297 where fcall (t, arg) = (toFType t, arg)
1299toAType (FCon i)
1300 | i == sUN "JS_IntChar" = ATInt ITChar
1301 | i == sUN "JS_IntNative" = ATInt ITNative
1302toAType t = error (show t ++ " not defined in toAType")
1304toFnType (FApp c [_,_,s,t])
1305 | c == sUN "JS_Fn" = toFnType t
1306toFnType (FApp c [_,_,r])
1307 | c == sUN "JS_FnIO" = FFunctionIO
1308toFnType (FApp c [_,r])
1309 | c == sUN "JS_FnBase" = FFunction
1310toFnType t = error (show t ++ " not defined in toFnType")
1312toFType (FCon c)
1313 | c == sUN "JS_Str" = FString
1314 | c == sUN "JS_Float" = FArith ATFloat
1315 | c == sUN "JS_Ptr" = FPtr
1316 | c == sUN "JS_Unit" = FUnit
1317toFType (FApp c [_,ity])
1318 | c == sUN "JS_IntT" = FArith (toAType ity)
1319toFType (FApp c [_,fty])
1320 | c == sUN "JS_FnT" = toFnType fty
1321toFType t = error (show t ++ " not yet defined in toFType")