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