git.iko.soy/Idris-dev
on ee11033 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1504 lines 52 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
4import Idris.AbsSyntax hiding (TypeCase)
5import IRTS.Bytecode
6import IRTS.Lang
7import IRTS.Simplified
8import IRTS.CodegenCommon
9import Idris.Core.TT
10import Paths_idris
11import Util.System
13import Control.Arrow
14import Control.Monad (mapM)
15import Control.Applicative ((<$>), (<*>), pure)
16import Control.Monad.RWS hiding (mapM)
17import Data.Char
18import Numeric
19import Data.List
20import Data.Maybe
21import Data.Word
22import Data.Traversable hiding (mapM)
23import System.IO
24import System.Directory
27idrNamespace :: String
28idrNamespace = "__IDR__"
29idrRTNamespace = "__IDRRT__"
30idrLTNamespace = "__IDRLT__"
31idrCTRNamespace = "__IDRCTR__"
33data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
34 , compileInfoEvalCases :: [Int]
35 }
38initCompileInfo :: [(Name, [BC])] -> CompileInfo
39initCompileInfo bc =
40 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc)
41 where
42 collectCases :: String -> [(Name, [BC])] -> [Int]
43 collectCases fun bc = getCases $ findFunction fun bc
45 findFunction :: String -> [(Name, [BC])] -> [BC]
46 findFunction f ((MN 0 fun, bc):_)
47 | fun == txt f = bc
48 findFunction f (_:bc) = findFunction f bc
50 getCases :: [BC] -> [Int]
51 getCases = concatMap analyze
52 where
53 analyze :: BC -> [Int]
54 analyze (CASE _ _ b _) = map fst b
55 analyze _ = []
58data JSTarget = Node | JavaScript deriving Eq
61data JSType = JSIntTy
62 | JSStringTy
63 | JSIntegerTy
64 | JSFloatTy
65 | JSCharTy
66 | JSPtrTy
67 | JSForgotTy
68 deriving Eq
71data JSInteger = JSBigZero
72 | JSBigOne
73 | JSBigInt Integer
74 | JSBigIntExpr JS
75 deriving Eq
78data JSNum = JSInt Int
79 | JSFloat Double
80 | JSInteger JSInteger
81 deriving Eq
84data JSWord = JSWord8 Word8
85 | JSWord16 Word16
86 | JSWord32 Word32
87 | JSWord64 Word64
88 deriving Eq
91data JSAnnotation = JSConstructor deriving Eq
94instance Show JSAnnotation where
95 show JSConstructor = "constructor"
98data JS = JSRaw String
99 | JSIdent String
100 | JSFunction [String] JS
101 | JSType JSType
102 | JSSeq [JS]
103 | JSReturn JS
104 | JSApp JS [JS]
105 | JSNew String [JS]
106 | JSError String
107 | JSBinOp String JS JS
108 | JSPreOp String JS
109 | JSPostOp String JS
110 | JSProj JS String
111 | JSNull
112 | JSUndefined
113 | JSThis
114 | JSTrue
115 | JSFalse
116 | JSArray [JS]
117 | JSString String
118 | JSNum JSNum
119 | JSWord JSWord
120 | JSAssign JS JS
121 | JSAlloc String (Maybe JS)
122 | JSIndex JS JS
123 | JSSwitch JS [(JS, JS)] (Maybe JS)
124 | JSCond [(JS, JS)]
125 | JSTernary JS JS JS
126 | JSParens JS
127 | JSWhile JS JS
128 | JSFFI String [JS]
129 | JSAnnotation JSAnnotation JS
130 | JSNoop
131 deriving Eq
134data FFI = FFICode Char | FFIArg Int | FFIError String
136ffi :: String -> [String] -> String
137ffi code args = let parsed = ffiParse code in
138 case ffiError parsed of
139 Just err -> error err
140 Nothing -> renderFFI parsed args
141 where
142 ffiParse :: String -> [FFI]
143 ffiParse "" = []
144 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
145 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
146 ffiParse ('%':s:ss)
147 | isDigit s =
148 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
149 | otherwise =
150 [FFIError $ "FFI - Invalid positional argument"]
151 ffiParse (s:ss) = FFICode s : ffiParse ss
154 ffiError :: [FFI] -> Maybe String
155 ffiError [] = Nothing
156 ffiError ((FFIError s):xs) = Just s
157 ffiError (x:xs) = ffiError xs
160 renderFFI :: [FFI] -> [String] -> String
161 renderFFI [] _ = ""
162 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
163 renderFFI ((FFIArg i) : fs) args
164 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
165 | otherwise = error "FFI - Argument index out of bounds"
167compileJS :: JS -> String
168compileJS = compileJS' 0
170compileJS' :: Int -> JS -> String
171compileJS' indent JSNoop = ""
173compileJS' indent (JSAnnotation annotation js) =
174 "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
176compileJS' indent (JSFFI raw args) =
177 ffi raw (map (compileJS' indent) args)
179compileJS' indent (JSRaw code) =
180 code
182compileJS' indent (JSIdent ident) =
183 ident
185compileJS' indent (JSFunction args body) =
186 replicate indent ' ' ++ "function("
187 ++ intercalate "," args
188 ++ "){\n"
189 ++ compileJS' (indent + 2) body
190 ++ "\n}\n"
192compileJS' indent (JSType ty)
193 | JSIntTy <- ty = idrRTNamespace ++ "Int"
194 | JSStringTy <- ty = idrRTNamespace ++ "String"
195 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
196 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
197 | JSCharTy <- ty = idrRTNamespace ++ "Char"
198 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
199 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
201compileJS' indent (JSSeq seq) =
202 intercalate ";\n" (
203 map (
204 ((replicate indent ' ') ++) . (compileJS' indent)
205 ) $ filter (/= JSNoop) seq
206 ) ++ ";"
208compileJS' indent (JSReturn val) =
209 "return " ++ compileJS' indent val
211compileJS' indent (JSApp lhs rhs)
212 | JSFunction {} <- lhs =
213 concat ["(", compileJS' indent lhs, ")(", args, ")"]
214 | otherwise =
215 concat [compileJS' indent lhs, "(", args, ")"]
216 where args :: String
217 args = intercalate "," $ map (compileJS' 0) rhs
219compileJS' indent (JSNew name args) =
220 "new " ++ name ++ "(" ++ intercalate "," (map (compileJS' 0) args) ++ ")"
222compileJS' indent (JSError exc) =
223 "throw new Error(\"" ++ exc ++ "\")"
225compileJS' indent (JSBinOp op lhs rhs) =
226 compileJS' indent lhs ++ " " ++ op ++ " " ++ compileJS' indent rhs
228compileJS' indent (JSPreOp op val) =
229 op ++ compileJS' indent val
231compileJS' indent (JSProj obj field)
232 | JSFunction {} <- obj =
233 concat ["(", compileJS' indent obj, ").", field]
234 | JSAssign {} <- obj =
235 concat ["(", compileJS' indent obj, ").", field]
236 | otherwise =
237 compileJS' indent obj ++ '.' : field
239compileJS' indent JSNull =
240 "null"
242compileJS' indent JSUndefined =
243 "undefined"
245compileJS' indent JSThis =
246 "this"
248compileJS' indent JSTrue =
249 "true"
251compileJS' indent JSFalse =
252 "false"
254compileJS' indent (JSArray elems) =
255 "[" ++ intercalate "," (map (compileJS' 0) elems) ++ "]"
257compileJS' indent (JSString str) =
258 "\"" ++ str ++ "\""
260compileJS' indent (JSNum num)
261 | JSInt i <- num = show i
262 | JSFloat f <- num = show f
263 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
264 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
265 | JSInteger (JSBigInt i) <- num = show i
266 | JSInteger (JSBigIntExpr e) <- num = "__IDRRT__bigInt(" ++ compileJS' indent e ++ ")"
268compileJS' indent (JSAssign lhs rhs) =
269 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
271compileJS' indent (JSAlloc name val) =
272 "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val
274compileJS' indent (JSIndex lhs rhs) =
275 compileJS' indent lhs ++ "[" ++ compileJS' indent rhs ++ "]"
277compileJS' indent (JSCond branches) =
278 intercalate " else " $ map createIfBlock branches
279 where
280 createIfBlock (JSNoop, e@(JSSeq _)) =
281 "{\n"
282 ++ compileJS' (indent + 2) e
283 ++ "\n" ++ replicate indent ' ' ++ "}"
284 createIfBlock (JSNoop, e) =
285 "{\n"
286 ++ compileJS' (indent + 2) e
287 ++ ";\n" ++ replicate indent ' ' ++ "}"
288 createIfBlock (cond, e@(JSSeq _)) =
289 "if (" ++ compileJS' indent cond ++") {\n"
290 ++ compileJS' (indent + 2) e
291 ++ "\n" ++ replicate indent ' ' ++ "}"
292 createIfBlock (cond, e) =
293 "if (" ++ compileJS' indent cond ++") {\n"
294 ++ replicate (indent + 2) ' ' ++ compileJS' (indent + 2) e
295 ++ ";\n" ++ replicate indent ' ' ++ "}"
297compileJS' indent (JSSwitch val [(_,seq)] Nothing) =
298 compileJS' indent seq
300compileJS' indent (JSSwitch val branches def) =
301 "switch(" ++ compileJS' indent val ++ "){\n"
302 ++ concatMap mkBranch branches
303 ++ mkDefault def
304 ++ (replicate indent ' ') ++ "}"
305 where
306 mkBranch :: (JS, JS) -> String
307 mkBranch (tag, code) =
308 replicate (indent + 2) ' ' ++ "case " ++ compileJS' indent tag ++ ":\n"
309 ++ compileJS' (indent + 4) code
310 ++ "\n" ++ (replicate (indent + 4) ' ' ++ "break;\n")
312 mkDefault :: Maybe JS -> String
313 mkDefault Nothing = ""
314 mkDefault (Just def) =
315 replicate (indent + 2) ' ' ++ "default:\n"
316 ++ compileJS' (indent + 4)def
317 ++ "\n"
320compileJS' indent (JSTernary cond true false) =
321 let c = compileJS' indent cond
322 t = compileJS' indent true
323 f = compileJS' indent false in
324 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
326compileJS' indent (JSParens js) =
327 "(" ++ compileJS' indent js ++ ")"
329compileJS' indent (JSWhile cond body) =
330 "while (" ++ compileJS' indent cond ++ ") {\n"
331 ++ compileJS' (indent + 2) body
332 ++ "\n" ++ replicate indent ' ' ++ "}"
334compileJS' indent (JSWord word)
335 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
336 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
337 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
338 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
340codegenJavaScript :: CodeGenerator
341codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
342 (includes ci) (outputFile ci) (outputType ci)
344codegenNode :: CodeGenerator
345codegenNode ci = codegenJS_all Node (simpleDecls ci)
346 (includes ci) (outputFile ci) (outputType ci)
348codegenJS_all
349 :: JSTarget
350 -> [(Name, SDecl)]
351 -> [FilePath]
352 -> FilePath
353 -> OutputType
354 -> IO ()
355codegenJS_all target definitions includes filename outputType = do
356 let bytecode = map toBC definitions
357 let info = initCompileInfo bytecode
358 let js = concatMap (translateDecl info) bytecode
359 let code = concatMap ((map compileJS) . collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)) js
360 let (header, rt) = case target of
361 Node -> ("#!/usr/bin/env node\n", "-node")
362 JavaScript -> ("", "-browser")
364 included <- concat <$> getIncludes includes
365 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
366 idrRuntime <- readFile $ path ++ "Runtime-common.js"
367 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
368 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
369 let runtime = header ++ included ++ jsbn ++ idrRuntime ++ tgtRuntime
370 writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
371 setPermissions filename (emptyPermissions { readable = True
372 , executable = target == Node
373 , writable = True
374 })
375 where
376 getIncludes :: [FilePath] -> IO [String]
377 getIncludes = mapM readFile
379 main :: String
380 main =
381 compileJS $ JSAlloc "main" (Just $
382 JSFunction [] (
383 case target of
384 Node -> mainFun
385 JavaScript -> jsMain
386 )
387 )
389 jsMain :: JS
390 jsMain =
391 JSCond [ (exists document `jsAnd` isReady, mainFun)
392 , (exists window, windowMainFun)
393 , (JSTrue, mainFun)
394 ]
395 where
396 exists :: JS -> JS
397 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
399 window :: JS
400 window = JSIdent "window"
402 document :: JS
403 document = JSIdent "document"
405 windowMainFun :: JS
406 windowMainFun =
407 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
408 , JSFunction [] ( mainFun )
409 , JSFalse
410 ]
412 isReady :: JS
413 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
415 readyState :: JS
416 readyState = JSProj (JSIdent "document") "readyState"
418 mainFun :: JS
419 mainFun =
420 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
421 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
422 , JSApp (
423 JSIdent (translateName (sMN 0 "runMain"))
424 ) [JSNum (JSInt 0)]
425 , JSWhile (JSProj jsCALLSTACK "length") (
426 JSSeq [ JSAlloc "func" (Just jsPOP)
427 , JSAlloc "args" (Just jsPOP)
428 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
429 ]
430 )
431 ]
433 invokeMain :: String
434 invokeMain = compileJS $ JSApp (JSIdent "main") []
436collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
437collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
438 where
439 generateSplitFunction :: (Int,JS) -> JS
440 generateSplitFunction (depth, JSAlloc name fun) =
441 JSAlloc (name ++ "$" ++ show depth) fun
443splitFunction :: JS -> RWS () [(Int,JS)] Int JS
444splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
445 body' <- splitSequence body
446 return $ JSAlloc name (Just (JSFunction args body'))
447 where
448 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
449 splitCondition js
450 | JSCond branches <- js =
451 JSCond <$> processBranches branches
452 | JSSwitch cond branches def <- js =
453 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
454 | otherwise = return js
455 where
456 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
457 processBranches =
458 traverse (runKleisli (arr id *** (Kleisli splitSequence)))
460 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
461 splitSequence js@(JSSeq seq) = do
462 let (pre,post) = break isCall seq in
463 case post of
464 [] -> JSSeq <$> traverse splitCondition seq
465 [js@(JSCond _)] -> splitCondition js
466 [js@(JSSwitch _ _ _)] -> splitCondition js
467 [_] -> return js
468 (call:rest) -> do
469 depth <- get
470 put (depth + 1)
471 new <- splitFunction (newFun rest)
472 tell [(depth, new)]
473 return $ JSSeq (pre ++ (newCall depth : [call]))
475 splitSequence js = return js
477 isCall :: JS -> Bool
478 isCall (JSApp (JSIdent "i$CALL") _) = True
479 isCall _ = False
481 newCall :: Int -> JS
482 newCall depth =
483 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
484 , JSArray [jsOLDBASE, jsMYOLDBASE]
485 ]
487 newFun :: [JS] -> JS
488 newFun seq =
489 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
491splitFunction js = return js
493translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
494translateDecl info (name@(MN 0 fun), bc)
495 | txt "APPLY" == fun =
496 allocCaseFunctions (snd body)
497 ++ [ JSAlloc (
498 translateName name
499 ) (Just $ JSFunction ["oldbase"] (
500 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
501 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
502 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
503 )
504 , ( JSNoop
505 , JSSeq $ map (translateBC info) (defaultCase (snd body))
506 )
507 ]
508 ]
509 )
510 )
511 ]
513 | txt "EVAL" == fun =
514 allocCaseFunctions (snd body)
515 ++ [ JSAlloc (
516 translateName name
517 ) (Just $ JSFunction ["oldbase"] (
518 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
519 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
520 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
521 )
522 , ( JSNoop
523 , JSSeq $ map (translateBC info) (defaultCase (snd body))
524 )
525 ]
526 ]
527 )
528 )
529 ]
530 where
531 body :: ([BC], [BC])
532 body = break isCase bc
534 isCase :: BC -> Bool
535 isCase bc
536 | CASE _ _ _ _ <- bc = True
537 | otherwise = False
539 defaultCase :: [BC] -> [BC]
540 defaultCase ((CASE _ _ _ (Just d)):_) = d
542 caseReg :: [BC] -> Reg
543 caseReg ((CASE _ r _ _):_) = r
545 allocCaseFunctions :: [BC] -> [JS]
546 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
547 allocCaseFunctions _ = []
549 splitBranches :: [(Int, [BC])] -> [JS]
550 splitBranches = map prepBranch
552 prepBranch :: (Int, [BC]) -> JS
553 prepBranch (tag, code) =
554 JSAlloc (
555 translateName name ++ "$" ++ show tag
556 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
557 JSSeq $ map (translateBC info) code
558 )
559 )
561translateDecl info (name, bc) =
562 [ JSAlloc (
563 translateName name
564 ) (Just $ JSFunction ["oldbase"] (
565 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
566 )
567 )
568 ]
571translateReg :: Reg -> JS
572translateReg reg
573 | RVal <- reg = jsRET
574 | Tmp <- reg = JSProj (JSIdent "vm") "reg1"
575 | L n <- reg = jsLOC n
576 | T n <- reg = jsTOP n
578translateConstant :: Const -> JS
579translateConstant (I i) = JSNum (JSInt i)
580translateConstant (Fl f) = JSNum (JSFloat f)
581translateConstant (Ch c) = JSString $ translateChar c
582translateConstant (Str s) = JSString $ concatMap translateChar s
583translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
584translateConstant StrType = JSType JSStringTy
585translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
586translateConstant (AType ATFloat) = JSType JSFloatTy
587translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
588translateConstant PtrType = JSType JSPtrTy
589translateConstant Forgot = JSType JSForgotTy
590translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
591translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
592translateConstant (BI i) = jsBigInt (JSString $ show i)
593translateConstant (B8 b) = JSWord (JSWord8 b)
594translateConstant (B16 b) = JSWord (JSWord16 b)
595translateConstant (B32 b) = JSWord (JSWord32 b)
596translateConstant (B64 b) = JSWord (JSWord64 b)
597translateConstant c =
598 JSError $ "Unimplemented Constant: " ++ show c
601translateChar :: Char -> String
602translateChar ch
603 | '\a' <- ch = "\\u0007"
604 | '\b' <- ch = "\\b"
605 | '\f' <- ch = "\\f"
606 | '\n' <- ch = "\\n"
607 | '\r' <- ch = "\\r"
608 | '\t' <- ch = "\\t"
609 | '\v' <- ch = "\\v"
610 | '\SO' <- ch = "\\u000E"
611 | '\DEL' <- ch = "\\u007F"
612 | '\\' <- ch = "\\\\"
613 | '\"' <- ch = "\\\""
614 | '\'' <- ch = "\\\'"
615 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
616 | otherwise = [ch]
617 where
618 fill :: String -> String
619 fill s = if length s == 1
620 then '0' : s
621 else s
623 asciiTab =
624 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
625 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
626 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
627 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
629translateName :: Name -> String
630translateName n = "_idris_" ++ concatMap cchar (showCG n)
631 where cchar x | isAlpha x || isDigit x = [x]
632 | otherwise = "_" ++ show (fromEnum x) ++ "_"
634jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
635jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
637jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
638jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
640jsCALL :: CompileInfo -> Name -> JS
641jsCALL _ n =
642 JSApp (
643 JSIdent "i$CALL"
644 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
646jsTAILCALL :: CompileInfo -> Name -> JS
647jsTAILCALL _ n =
648 JSApp (
649 JSIdent "i$CALL"
650 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
652jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
653jsFOREIGN _ reg n args
654 | n == "putStr"
655 , [(FString, arg)] <- args =
656 JSAssign (
657 translateReg reg
658 ) (
659 JSApp (JSIdent "i$putStr") [translateReg arg]
660 )
662 | n == "isNull"
663 , [(FPtr, arg)] <- args =
664 JSAssign (
665 translateReg reg
666 ) (
667 JSBinOp "==" (translateReg arg) JSNull
668 )
670 | n == "idris_eqPtr"
671 , [(_, lhs),(_, rhs)] <- args =
672 JSAssign (
673 translateReg reg
674 ) (
675 JSBinOp "==" (translateReg lhs) (translateReg rhs)
676 )
677 | otherwise =
678 JSAssign (
679 translateReg reg
680 ) (
681 JSFFI n (map generateWrapper args)
682 )
683 where
684 generateWrapper :: (FType, Reg) -> JS
685 generateWrapper (ty, reg)
686 | FFunction <- ty =
687 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
688 , JSIdent "oldbase"
689 , JSIdent "myoldbase"
690 ]
691 | FFunctionIO <- ty =
692 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
693 , JSIdent "oldbase"
694 , JSIdent "myoldbase"
695 ]
697 generateWrapper (_, reg) =
698 translateReg reg
700jsREBASE :: CompileInfo -> JS
701jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
703jsSTOREOLD :: CompileInfo ->JS
704jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
706jsADDTOP :: CompileInfo -> Int -> JS
707jsADDTOP info n
708 | 0 <- n = JSNoop
709 | otherwise =
710 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
712jsTOPBASE :: CompileInfo -> Int -> JS
713jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
714jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
717jsBASETOP :: CompileInfo -> Int -> JS
718jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
719jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
721jsNULL :: CompileInfo -> Reg -> JS
722jsNULL _ r = JSAssign (translateReg r) JSNull
724jsERROR :: CompileInfo -> String -> JS
725jsERROR _ = JSError
727jsSLIDE :: CompileInfo -> Int -> JS
728jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
730jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
731jsMKCON info r t rs =
732 JSAssign (translateReg r) (
733 JSNew "i$CON" [ JSNum (JSInt t)
734 , JSArray (map translateReg rs)
735 , if t `elem` compileInfoApplyCases info
736 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
737 else JSNull
738 , if t `elem` compileInfoEvalCases info
739 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
740 else JSNull
741 ]
742 )
744jsInstanceOf :: JS -> String -> JS
745jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
747jsOr :: JS -> JS -> JS
748jsOr lhs rhs = JSBinOp "||" lhs rhs
750jsAnd :: JS -> JS -> JS
751jsAnd lhs rhs = JSBinOp "&&" lhs rhs
753jsMeth :: JS -> String -> [JS] -> JS
754jsMeth obj meth args = JSApp (JSProj obj meth) args
756jsCall :: String -> [JS] -> JS
757jsCall fun args = JSApp (JSIdent fun) args
759jsTypeOf :: JS -> JS
760jsTypeOf js = JSPreOp "typeof " js
762jsEq :: JS -> JS -> JS
763jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
764jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
765jsEq lhs rhs = JSBinOp "==" lhs rhs
767jsNotEq :: JS -> JS -> JS
768jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
770jsIsNumber :: JS -> JS
771jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
773jsIsNull :: JS -> JS
774jsIsNull js = JSBinOp "==" js JSNull
776jsBigInt :: JS -> JS
777jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
778jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
779jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
781jsUnPackBits :: JS -> JS
782jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
784jsPackUBits8 :: JS -> JS
785jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
787jsPackUBits16 :: JS -> JS
788jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
790jsPackUBits32 :: JS -> JS
791jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
793jsPackSBits8 :: JS -> JS
794jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
796jsPackSBits16 :: JS -> JS
797jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
799jsPackSBits32 :: JS -> JS
800jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
802jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
803jsCASE info safe reg cases def =
804 JSSwitch (tag safe $ translateReg reg) (
805 map ((JSNum . JSInt) *** prepBranch) cases
806 ) (fmap prepBranch def)
807 where
808 tag :: Bool -> JS -> JS
809 tag True = jsCTAG
810 tag False = jsTAG
812 prepBranch :: [BC] -> JS
813 prepBranch bc = JSSeq $ map (translateBC info) bc
815 jsTAG :: JS -> JS
816 jsTAG js =
817 (JSTernary (js `jsInstanceOf` "i$CON") (
818 JSProj js "tag"
819 ) (JSNum (JSInt $ negate 1)))
821 jsCTAG :: JS -> JS
822 jsCTAG js = JSProj js "tag"
825jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
826jsCONSTCASE info reg cases def =
827 JSCond $ (
828 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
829 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
830 where
831 prepBranch :: [BC] -> JS
832 prepBranch bc = JSSeq $ map (translateBC info) bc
834jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
835jsPROJECT _ reg loc ar =
836 JSApp (JSIdent "i$PROJECT") [ translateReg reg
837 , JSNum (JSInt loc)
838 , JSNum (JSInt ar)
839 ]
841jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
842jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
843 where
844 jsOP' :: JS
845 jsOP'
846 | LNoOp <- op = translateReg (last args)
848 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
849 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
850 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
852 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
853 | (LPlus (ATInt ITBig)) <- op
854 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
855 | (LMinus (ATInt ITBig)) <- op
856 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
857 | (LTimes (ATInt ITBig)) <- op
858 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
859 | (LSDiv (ATInt ITBig)) <- op
860 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
861 | (LSRem (ATInt ITBig)) <- op
862 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
863 | (LEq (ATInt ITBig)) <- op
864 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
865 | (LSLt (ATInt ITBig)) <- op
866 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
867 | (LSLe (ATInt ITBig)) <- op
868 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
869 | (LSGt (ATInt ITBig)) <- op
870 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
871 | (LSGe (ATInt ITBig)) <- op
872 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
874 | (LPlus ATFloat) <- op
875 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
876 | (LMinus ATFloat) <- op
877 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
878 | (LTimes ATFloat) <- op
879 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
880 | (LSDiv ATFloat) <- op
881 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
882 | (LEq ATFloat) <- op
883 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
884 | (LSLt ATFloat) <- op
885 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
886 | (LSLe ATFloat) <- op
887 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
888 | (LSGt ATFloat) <- op
889 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
890 | (LSGe ATFloat) <- op
891 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
893 | (LPlus (ATInt ITChar)) <- op
894 , (lhs:rhs:_) <- args =
895 jsCall "i$fromCharCode" [
896 JSBinOp "+" (
897 jsCall "i$charCode" [translateReg lhs]
898 ) (
899 jsCall "i$charCode" [translateReg rhs]
900 )
901 ]
903 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
904 , (arg:_) <- args =
905 jsPackUBits8 (
906 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
907 )
909 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
910 , (arg:_) <- args =
911 jsPackUBits16 (
912 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
913 )
915 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
916 , (arg:_) <- args =
917 jsPackUBits32 (
918 jsMeth (jsMeth (translateReg arg) "and" [
919 jsBigInt (JSString $ show 0xFFFFFFFF)
920 ]) "intValue" []
921 )
923 | (LTrunc ITBig (ITFixed IT64)) <- op
924 , (arg:_) <- args =
925 jsMeth (translateReg arg) "and" [
926 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
927 ]
929 | (LLSHR (ITFixed IT8)) <- op
930 , (lhs:rhs:_) <- args =
931 jsPackUBits8 (
932 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
933 )
935 | (LLSHR (ITFixed IT16)) <- op
936 , (lhs:rhs:_) <- args =
937 jsPackUBits16 (
938 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
939 )
941 | (LLSHR (ITFixed IT32)) <- op
942 , (lhs:rhs:_) <- args =
943 jsPackUBits32 (
944 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
945 )
947 | (LLSHR (ITFixed IT64)) <- op
948 , (lhs:rhs:_) <- args =
949 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
951 | (LSHL (ITFixed IT8)) <- op
952 , (lhs:rhs:_) <- args =
953 jsPackUBits8 (
954 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
955 )
957 | (LSHL (ITFixed IT16)) <- op
958 , (lhs:rhs:_) <- args =
959 jsPackUBits16 (
960 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
961 )
963 | (LSHL (ITFixed IT32)) <- op
964 , (lhs:rhs:_) <- args =
965 jsPackUBits32 (
966 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
967 )
969 | (LSHL (ITFixed IT64)) <- op
970 , (lhs:rhs:_) <- args =
971 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
972 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
973 ]
975 | (LAnd (ITFixed IT8)) <- op
976 , (lhs:rhs:_) <- args =
977 jsPackUBits8 (
978 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
979 )
981 | (LAnd (ITFixed IT16)) <- op
982 , (lhs:rhs:_) <- args =
983 jsPackUBits16 (
984 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
985 )
987 | (LAnd (ITFixed IT32)) <- op
988 , (lhs:rhs:_) <- args =
989 jsPackUBits32 (
990 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
991 )
993 | (LAnd (ITFixed IT64)) <- op
994 , (lhs:rhs:_) <- args =
995 jsMeth (translateReg lhs) "and" [translateReg rhs]
997 | (LOr (ITFixed IT8)) <- op
998 , (lhs:rhs:_) <- args =
999 jsPackUBits8 (
1000 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1003 | (LOr (ITFixed IT16)) <- op
1004 , (lhs:rhs:_) <- args =
1005 jsPackUBits16 (
1006 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1009 | (LOr (ITFixed IT32)) <- op
1010 , (lhs:rhs:_) <- args =
1011 jsPackUBits32 (
1012 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1015 | (LOr (ITFixed IT64)) <- op
1016 , (lhs:rhs:_) <- args =
1017 jsMeth (translateReg lhs) "or" [translateReg rhs]
1019 | (LXOr (ITFixed IT8)) <- op
1020 , (lhs:rhs:_) <- args =
1021 jsPackUBits8 (
1022 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1025 | (LXOr (ITFixed IT16)) <- op
1026 , (lhs:rhs:_) <- args =
1027 jsPackUBits16 (
1028 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1031 | (LXOr (ITFixed IT32)) <- op
1032 , (lhs:rhs:_) <- args =
1033 jsPackUBits32 (
1034 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1037 | (LXOr (ITFixed IT64)) <- op
1038 , (lhs:rhs:_) <- args =
1039 jsMeth (translateReg lhs) "xor" [translateReg rhs]
1041 | (LPlus (ATInt (ITFixed IT8))) <- op
1042 , (lhs:rhs:_) <- args =
1043 jsPackUBits8 (
1044 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1047 | (LPlus (ATInt (ITFixed IT16))) <- op
1048 , (lhs:rhs:_) <- args =
1049 jsPackUBits16 (
1050 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1053 | (LPlus (ATInt (ITFixed IT32))) <- op
1054 , (lhs:rhs:_) <- args =
1055 jsPackUBits32 (
1056 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1059 | (LPlus (ATInt (ITFixed IT64))) <- op
1060 , (lhs:rhs:_) <- args =
1061 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
1062 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1065 | (LMinus (ATInt (ITFixed IT8))) <- op
1066 , (lhs:rhs:_) <- args =
1067 jsPackUBits8 (
1068 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1071 | (LMinus (ATInt (ITFixed IT16))) <- op
1072 , (lhs:rhs:_) <- args =
1073 jsPackUBits16 (
1074 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1077 | (LMinus (ATInt (ITFixed IT32))) <- op
1078 , (lhs:rhs:_) <- args =
1079 jsPackUBits32 (
1080 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1083 | (LMinus (ATInt (ITFixed IT64))) <- op
1084 , (lhs:rhs:_) <- args =
1085 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
1086 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1089 | (LTimes (ATInt (ITFixed IT8))) <- op
1090 , (lhs:rhs:_) <- args =
1091 jsPackUBits8 (
1092 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1095 | (LTimes (ATInt (ITFixed IT16))) <- op
1096 , (lhs:rhs:_) <- args =
1097 jsPackUBits16 (
1098 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1101 | (LTimes (ATInt (ITFixed IT32))) <- op
1102 , (lhs:rhs:_) <- args =
1103 jsPackUBits32 (
1104 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1107 | (LTimes (ATInt (ITFixed IT64))) <- op
1108 , (lhs:rhs:_) <- args =
1109 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
1110 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1113 | (LEq (ATInt (ITFixed IT8))) <- op
1114 , (lhs:rhs:_) <- args =
1115 jsPackUBits8 (
1116 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1119 | (LEq (ATInt (ITFixed IT16))) <- op
1120 , (lhs:rhs:_) <- args =
1121 jsPackUBits16 (
1122 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1125 | (LEq (ATInt (ITFixed IT32))) <- op
1126 , (lhs:rhs:_) <- args =
1127 jsPackUBits32 (
1128 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1131 | (LEq (ATInt (ITFixed IT64))) <- op
1132 , (lhs:rhs:_) <- args =
1133 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
1134 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1137 | (LLt (ITFixed IT8)) <- op
1138 , (lhs:rhs:_) <- args =
1139 jsPackUBits8 (
1140 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1143 | (LLt (ITFixed IT16)) <- op
1144 , (lhs:rhs:_) <- args =
1145 jsPackUBits16 (
1146 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1149 | (LLt (ITFixed IT32)) <- op
1150 , (lhs:rhs:_) <- args =
1151 jsPackUBits32 (
1152 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1155 | (LLt (ITFixed IT64)) <- op
1156 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1158 | (LLe (ITFixed IT8)) <- op
1159 , (lhs:rhs:_) <- args =
1160 jsPackUBits8 (
1161 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1164 | (LLe (ITFixed IT16)) <- op
1165 , (lhs:rhs:_) <- args =
1166 jsPackUBits16 (
1167 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1170 | (LLe (ITFixed IT32)) <- op
1171 , (lhs:rhs:_) <- args =
1172 jsPackUBits32 (
1173 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1176 | (LLe (ITFixed IT64)) <- op
1177 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1179 | (LGt (ITFixed IT8)) <- op
1180 , (lhs:rhs:_) <- args =
1181 jsPackUBits8 (
1182 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1185 | (LGt (ITFixed IT16)) <- op
1186 , (lhs:rhs:_) <- args =
1187 jsPackUBits16 (
1188 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1190 | (LGt (ITFixed IT32)) <- op
1191 , (lhs:rhs:_) <- args =
1192 jsPackUBits32 (
1193 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1196 | (LGt (ITFixed IT64)) <- op
1197 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1199 | (LGe (ITFixed IT8)) <- op
1200 , (lhs:rhs:_) <- args =
1201 jsPackUBits8 (
1202 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1205 | (LGe (ITFixed IT16)) <- op
1206 , (lhs:rhs:_) <- args =
1207 jsPackUBits16 (
1208 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1210 | (LGe (ITFixed IT32)) <- op
1211 , (lhs:rhs:_) <- args =
1212 jsPackUBits32 (
1213 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1216 | (LGe (ITFixed IT64)) <- op
1217 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1219 | (LUDiv (ITFixed IT8)) <- op
1220 , (lhs:rhs:_) <- args =
1221 jsPackUBits8 (
1222 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1225 | (LUDiv (ITFixed IT16)) <- op
1226 , (lhs:rhs:_) <- args =
1227 jsPackUBits16 (
1228 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1231 | (LUDiv (ITFixed IT32)) <- op
1232 , (lhs:rhs:_) <- args =
1233 jsPackUBits32 (
1234 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1237 | (LUDiv (ITFixed IT64)) <- op
1238 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1240 | (LSDiv (ATInt (ITFixed IT8))) <- op
1241 , (lhs:rhs:_) <- args =
1242 jsPackSBits8 (
1243 JSBinOp "/" (
1244 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1245 ) (
1246 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1250 | (LSDiv (ATInt (ITFixed IT16))) <- op
1251 , (lhs:rhs:_) <- args =
1252 jsPackSBits16 (
1253 JSBinOp "/" (
1254 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1255 ) (
1256 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1260 | (LSDiv (ATInt (ITFixed IT32))) <- op
1261 , (lhs:rhs:_) <- args =
1262 jsPackSBits32 (
1263 JSBinOp "/" (
1264 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1265 ) (
1266 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1270 | (LSDiv (ATInt (ITFixed IT64))) <- op
1271 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1273 | (LSRem (ATInt (ITFixed IT8))) <- op
1274 , (lhs:rhs:_) <- args =
1275 jsPackSBits8 (
1276 JSBinOp "%" (
1277 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1278 ) (
1279 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1283 | (LSRem (ATInt (ITFixed IT16))) <- op
1284 , (lhs:rhs:_) <- args =
1285 jsPackSBits16 (
1286 JSBinOp "%" (
1287 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1288 ) (
1289 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1293 | (LSRem (ATInt (ITFixed IT32))) <- op
1294 , (lhs:rhs:_) <- args =
1295 jsPackSBits32 (
1296 JSBinOp "%" (
1297 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1298 ) (
1299 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1303 | (LSRem (ATInt (ITFixed IT64))) <- op
1304 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1306 | (LCompl (ITFixed IT8)) <- op
1307 , (arg:_) <- args =
1308 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1310 | (LCompl (ITFixed IT16)) <- op
1311 , (arg:_) <- args =
1312 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1314 | (LCompl (ITFixed IT32)) <- op
1315 , (arg:_) <- args =
1316 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1318 | (LCompl (ITFixed IT64)) <- op
1319 , (arg:_) <- args =
1320 invokeMeth arg "not" []
1322 | (LPlus _) <- op
1323 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1324 | (LMinus _) <- op
1325 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1326 | (LTimes _) <- op
1327 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1328 | (LSDiv _) <- op
1329 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1330 | (LSRem _) <- op
1331 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1332 | (LEq _) <- op
1333 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1334 | (LSLt _) <- op
1335 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1336 | (LSLe _) <- op
1337 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1338 | (LSGt _) <- op
1339 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1340 | (LSGe _) <- op
1341 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1342 | (LAnd _) <- op
1343 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1344 | (LOr _) <- op
1345 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1346 | (LXOr _) <- op
1347 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1348 | (LSHL _) <- op
1349 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1350 | (LASHR _) <- op
1351 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1352 | (LCompl _) <- op
1353 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1355 | LStrConcat <- op
1356 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1357 | LStrEq <- op
1358 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1359 | LStrLt <- op
1360 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1361 | LStrLen <- op
1362 , (arg:_) <- args = JSProj (translateReg arg) "length"
1363 | (LStrInt ITNative) <- op
1364 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1365 | (LIntStr ITNative) <- op
1366 , (arg:_) <- args = jsCall "String" [translateReg arg]
1367 | (LSExt ITNative ITBig) <- op
1368 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1369 | (LTrunc ITBig ITNative) <- op
1370 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1371 | (LIntStr ITBig) <- op
1372 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1373 | (LStrInt ITBig) <- op
1374 , (arg:_) <- args = jsBigInt $ translateReg arg
1375 | LFloatStr <- op
1376 , (arg:_) <- args = jsCall "String" [translateReg arg]
1377 | LStrFloat <- op
1378 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1379 | (LIntFloat ITNative) <- op
1380 , (arg:_) <- args = translateReg arg
1381 | (LFloatInt ITNative) <- op
1382 , (arg:_) <- args = translateReg arg
1383 | (LChInt ITNative) <- op
1384 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1385 | (LIntCh ITNative) <- op
1386 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1388 | LFExp <- op
1389 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1390 | LFLog <- op
1391 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1392 | LFSin <- op
1393 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1394 | LFCos <- op
1395 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1396 | LFTan <- op
1397 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1398 | LFASin <- op
1399 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1400 | LFACos <- op
1401 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1402 | LFATan <- op
1403 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1404 | LFSqrt <- op
1405 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1406 | LFFloor <- op
1407 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1408 | LFCeil <- op
1409 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1411 | LStrCons <- op
1412 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1413 | LStrHead <- op
1414 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1415 | LStrRev <- op
1416 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1417 | LStrIndex <- op
1418 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1419 | LStrTail <- op
1420 , (arg:_) <- args =
1421 let v = translateReg arg in
1422 JSApp (JSProj v "substr") [
1423 JSNum (JSInt 1),
1424 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1427 | LSystemInfo <- op
1428 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1429 | LNullPtr <- op
1430 , (_) <- args = JSNull
1431 | otherwise = JSError $ "Not implemented: " ++ show op
1432 where
1433 translateBinaryOp :: String -> Reg -> Reg -> JS
1434 translateBinaryOp op lhs rhs =
1435 JSBinOp op (translateReg lhs) (translateReg rhs)
1437 invokeMeth :: Reg -> String -> [Reg] -> JS
1438 invokeMeth obj meth args =
1439 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1442jsRESERVE :: CompileInfo -> Int -> JS
1443jsRESERVE _ _ = JSNoop
1445jsSTACK :: JS
1446jsSTACK = JSIdent "i$valstack"
1448jsCALLSTACK :: JS
1449jsCALLSTACK = JSIdent "i$callstack"
1451jsSTACKBASE :: JS
1452jsSTACKBASE = JSIdent "i$valstack_base"
1454jsSTACKTOP :: JS
1455jsSTACKTOP = JSIdent "i$valstack_top"
1457jsOLDBASE :: JS
1458jsOLDBASE = JSIdent "oldbase"
1460jsMYOLDBASE :: JS
1461jsMYOLDBASE = JSIdent "myoldbase"
1463jsRET :: JS
1464jsRET = JSIdent "i$ret"
1466jsLOC :: Int -> JS
1467jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1468jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1470jsTOP :: Int -> JS
1471jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1472jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1474jsPUSH :: [JS] -> JS
1475jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1477jsPOP :: JS
1478jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1480translateBC :: CompileInfo -> BC -> JS
1481translateBC info bc
1482 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1483 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1484 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1485 | ADDTOP n <- bc = jsADDTOP info n
1486 | NULL r <- bc = jsNULL info r
1487 | CALL n <- bc = jsCALL info n
1488 | TAILCALL n <- bc = jsTAILCALL info n
1489 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1490 | TOPBASE n <- bc = jsTOPBASE info n
1491 | BASETOP n <- bc = jsBASETOP info n
1492 | STOREOLD <- bc = jsSTOREOLD info
1493 | SLIDE n <- bc = jsSLIDE info n
1494 | REBASE <- bc = jsREBASE info
1495 | RESERVE n <- bc = jsRESERVE info n
1496 | MKCON r t rs <- bc = jsMKCON info r t rs
1497 | CASE s r c d <- bc = jsCASE info s r c d
1498 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1499 | PROJECT r l a <- bc = jsPROJECT info r l a
1500 | OP r o a <- bc = jsOP info r o a
1501 | ERROR e <- bc = jsERROR info e
1502 | otherwise = JSRaw $ show bc
1503 {- PROJECTINTO _ _ _ <- bc = undefined -}