git.iko.soy/Idris-dev
on 146dda2 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1517 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 =
342 codegenJS_all JavaScript (simpleDecls ci)
343 (includes ci) [] (outputFile ci) (outputType ci)
345codegenNode :: CodeGenerator
346codegenNode ci =
347 codegenJS_all Node (simpleDecls ci)
348 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
350codegenJS_all
351 :: JSTarget
352 -> [(Name, SDecl)]
353 -> [FilePath]
354 -> [String]
355 -> FilePath
356 -> OutputType
357 -> IO ()
358codegenJS_all target definitions includes libs filename outputType = do
359 let bytecode = map toBC definitions
360 let info = initCompileInfo bytecode
361 let js = concatMap (translateDecl info) bytecode
362 let code = concatMap ((map compileJS) . collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)) js
363 let (header, rt) = case target of
364 Node -> ("#!/usr/bin/env node\n", "-node")
365 JavaScript -> ("", "-browser")
367 included <- concat <$> getIncludes includes
368 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
369 idrRuntime <- readFile $ path ++ "Runtime-common.js"
370 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
371 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
372 let runtime = ( header
373 ++ includeLibs libs
374 ++ included
375 ++ jsbn
376 ++ idrRuntime
377 ++ tgtRuntime
378 )
379 writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
380 setPermissions filename (emptyPermissions { readable = True
381 , executable = target == Node
382 , writable = True
383 })
384 where
385 includeLibs :: [String] -> String
386 includeLibs =
387 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
389 getIncludes :: [FilePath] -> IO [String]
390 getIncludes = mapM readFile
392 main :: String
393 main =
394 compileJS $ JSAlloc "main" (Just $
395 JSFunction [] (
396 case target of
397 Node -> mainFun
398 JavaScript -> jsMain
399 )
400 )
402 jsMain :: JS
403 jsMain =
404 JSCond [ (exists document `jsAnd` isReady, mainFun)
405 , (exists window, windowMainFun)
406 , (JSTrue, mainFun)
407 ]
408 where
409 exists :: JS -> JS
410 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
412 window :: JS
413 window = JSIdent "window"
415 document :: JS
416 document = JSIdent "document"
418 windowMainFun :: JS
419 windowMainFun =
420 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
421 , JSFunction [] ( mainFun )
422 , JSFalse
423 ]
425 isReady :: JS
426 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
428 readyState :: JS
429 readyState = JSProj (JSIdent "document") "readyState"
431 mainFun :: JS
432 mainFun =
433 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
434 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
435 , JSApp (
436 JSIdent (translateName (sMN 0 "runMain"))
437 ) [JSNum (JSInt 0)]
438 , JSWhile (JSProj jsCALLSTACK "length") (
439 JSSeq [ JSAlloc "func" (Just jsPOP)
440 , JSAlloc "args" (Just jsPOP)
441 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
442 ]
443 )
444 ]
446 invokeMain :: String
447 invokeMain = compileJS $ JSApp (JSIdent "main") []
449collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
450collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
451 where
452 generateSplitFunction :: (Int,JS) -> JS
453 generateSplitFunction (depth, JSAlloc name fun) =
454 JSAlloc (name ++ "$" ++ show depth) fun
456splitFunction :: JS -> RWS () [(Int,JS)] Int JS
457splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
458 body' <- splitSequence body
459 return $ JSAlloc name (Just (JSFunction args body'))
460 where
461 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
462 splitCondition js
463 | JSCond branches <- js =
464 JSCond <$> processBranches branches
465 | JSSwitch cond branches def <- js =
466 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
467 | otherwise = return js
468 where
469 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
470 processBranches =
471 traverse (runKleisli (arr id *** (Kleisli splitSequence)))
473 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
474 splitSequence js@(JSSeq seq) = do
475 let (pre,post) = break isCall seq in
476 case post of
477 [] -> JSSeq <$> traverse splitCondition seq
478 [js@(JSCond _)] -> splitCondition js
479 [js@(JSSwitch _ _ _)] -> splitCondition js
480 [_] -> return js
481 (call:rest) -> do
482 depth <- get
483 put (depth + 1)
484 new <- splitFunction (newFun rest)
485 tell [(depth, new)]
486 return $ JSSeq (pre ++ (newCall depth : [call]))
488 splitSequence js = return js
490 isCall :: JS -> Bool
491 isCall (JSApp (JSIdent "i$CALL") _) = True
492 isCall _ = False
494 newCall :: Int -> JS
495 newCall depth =
496 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
497 , JSArray [jsOLDBASE, jsMYOLDBASE]
498 ]
500 newFun :: [JS] -> JS
501 newFun seq =
502 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
504splitFunction js = return js
506translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
507translateDecl info (name@(MN 0 fun), bc)
508 | txt "APPLY" == fun =
509 allocCaseFunctions (snd body)
510 ++ [ JSAlloc (
511 translateName name
512 ) (Just $ JSFunction ["oldbase"] (
513 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
514 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
515 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
516 )
517 , ( JSNoop
518 , JSSeq $ map (translateBC info) (defaultCase (snd body))
519 )
520 ]
521 ]
522 )
523 )
524 ]
526 | txt "EVAL" == fun =
527 allocCaseFunctions (snd body)
528 ++ [ JSAlloc (
529 translateName name
530 ) (Just $ JSFunction ["oldbase"] (
531 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
532 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
533 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
534 )
535 , ( JSNoop
536 , JSSeq $ map (translateBC info) (defaultCase (snd body))
537 )
538 ]
539 ]
540 )
541 )
542 ]
543 where
544 body :: ([BC], [BC])
545 body = break isCase bc
547 isCase :: BC -> Bool
548 isCase bc
549 | CASE _ _ _ _ <- bc = True
550 | otherwise = False
552 defaultCase :: [BC] -> [BC]
553 defaultCase ((CASE _ _ _ (Just d)):_) = d
555 caseReg :: [BC] -> Reg
556 caseReg ((CASE _ r _ _):_) = r
558 allocCaseFunctions :: [BC] -> [JS]
559 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
560 allocCaseFunctions _ = []
562 splitBranches :: [(Int, [BC])] -> [JS]
563 splitBranches = map prepBranch
565 prepBranch :: (Int, [BC]) -> JS
566 prepBranch (tag, code) =
567 JSAlloc (
568 translateName name ++ "$" ++ show tag
569 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
570 JSSeq $ map (translateBC info) code
571 )
572 )
574translateDecl info (name, bc) =
575 [ JSAlloc (
576 translateName name
577 ) (Just $ JSFunction ["oldbase"] (
578 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
579 )
580 )
581 ]
584translateReg :: Reg -> JS
585translateReg reg
586 | RVal <- reg = jsRET
587 | Tmp <- reg = JSProj (JSIdent "vm") "reg1"
588 | L n <- reg = jsLOC n
589 | T n <- reg = jsTOP n
591translateConstant :: Const -> JS
592translateConstant (I i) = JSNum (JSInt i)
593translateConstant (Fl f) = JSNum (JSFloat f)
594translateConstant (Ch c) = JSString $ translateChar c
595translateConstant (Str s) = JSString $ concatMap translateChar s
596translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
597translateConstant StrType = JSType JSStringTy
598translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
599translateConstant (AType ATFloat) = JSType JSFloatTy
600translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
601translateConstant PtrType = JSType JSPtrTy
602translateConstant Forgot = JSType JSForgotTy
603translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
604translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
605translateConstant (BI i) = jsBigInt (JSString $ show i)
606translateConstant (B8 b) = JSWord (JSWord8 b)
607translateConstant (B16 b) = JSWord (JSWord16 b)
608translateConstant (B32 b) = JSWord (JSWord32 b)
609translateConstant (B64 b) = JSWord (JSWord64 b)
610translateConstant c =
611 JSError $ "Unimplemented Constant: " ++ show c
614translateChar :: Char -> String
615translateChar ch
616 | '\a' <- ch = "\\u0007"
617 | '\b' <- ch = "\\b"
618 | '\f' <- ch = "\\f"
619 | '\n' <- ch = "\\n"
620 | '\r' <- ch = "\\r"
621 | '\t' <- ch = "\\t"
622 | '\v' <- ch = "\\v"
623 | '\SO' <- ch = "\\u000E"
624 | '\DEL' <- ch = "\\u007F"
625 | '\\' <- ch = "\\\\"
626 | '\"' <- ch = "\\\""
627 | '\'' <- ch = "\\\'"
628 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
629 | otherwise = [ch]
630 where
631 fill :: String -> String
632 fill s = if length s == 1
633 then '0' : s
634 else s
636 asciiTab =
637 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
638 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
639 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
640 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
642translateName :: Name -> String
643translateName n = "_idris_" ++ concatMap cchar (showCG n)
644 where cchar x | isAlpha x || isDigit x = [x]
645 | otherwise = "_" ++ show (fromEnum x) ++ "_"
647jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
648jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
650jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
651jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
653jsCALL :: CompileInfo -> Name -> JS
654jsCALL _ n =
655 JSApp (
656 JSIdent "i$CALL"
657 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
659jsTAILCALL :: CompileInfo -> Name -> JS
660jsTAILCALL _ n =
661 JSApp (
662 JSIdent "i$CALL"
663 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
665jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
666jsFOREIGN _ reg n args
667 | n == "putStr"
668 , [(FString, arg)] <- args =
669 JSAssign (
670 translateReg reg
671 ) (
672 JSApp (JSIdent "i$putStr") [translateReg arg]
673 )
675 | n == "isNull"
676 , [(FPtr, arg)] <- args =
677 JSAssign (
678 translateReg reg
679 ) (
680 JSBinOp "==" (translateReg arg) JSNull
681 )
683 | n == "idris_eqPtr"
684 , [(_, lhs),(_, rhs)] <- args =
685 JSAssign (
686 translateReg reg
687 ) (
688 JSBinOp "==" (translateReg lhs) (translateReg rhs)
689 )
690 | otherwise =
691 JSAssign (
692 translateReg reg
693 ) (
694 JSFFI n (map generateWrapper args)
695 )
696 where
697 generateWrapper :: (FType, Reg) -> JS
698 generateWrapper (ty, reg)
699 | FFunction <- ty =
700 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
701 , JSIdent "oldbase"
702 , JSIdent "myoldbase"
703 ]
704 | FFunctionIO <- ty =
705 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
706 , JSIdent "oldbase"
707 , JSIdent "myoldbase"
708 ]
710 generateWrapper (_, reg) =
711 translateReg reg
713jsREBASE :: CompileInfo -> JS
714jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
716jsSTOREOLD :: CompileInfo ->JS
717jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
719jsADDTOP :: CompileInfo -> Int -> JS
720jsADDTOP info n
721 | 0 <- n = JSNoop
722 | otherwise =
723 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
725jsTOPBASE :: CompileInfo -> Int -> JS
726jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
727jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
730jsBASETOP :: CompileInfo -> Int -> JS
731jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
732jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
734jsNULL :: CompileInfo -> Reg -> JS
735jsNULL _ r = JSAssign (translateReg r) JSNull
737jsERROR :: CompileInfo -> String -> JS
738jsERROR _ = JSError
740jsSLIDE :: CompileInfo -> Int -> JS
741jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
743jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
744jsMKCON info r t rs =
745 JSAssign (translateReg r) (
746 JSNew "i$CON" [ JSNum (JSInt t)
747 , JSArray (map translateReg rs)
748 , if t `elem` compileInfoApplyCases info
749 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
750 else JSNull
751 , if t `elem` compileInfoEvalCases info
752 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
753 else JSNull
754 ]
755 )
757jsInstanceOf :: JS -> String -> JS
758jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
760jsOr :: JS -> JS -> JS
761jsOr lhs rhs = JSBinOp "||" lhs rhs
763jsAnd :: JS -> JS -> JS
764jsAnd lhs rhs = JSBinOp "&&" lhs rhs
766jsMeth :: JS -> String -> [JS] -> JS
767jsMeth obj meth args = JSApp (JSProj obj meth) args
769jsCall :: String -> [JS] -> JS
770jsCall fun args = JSApp (JSIdent fun) args
772jsTypeOf :: JS -> JS
773jsTypeOf js = JSPreOp "typeof " js
775jsEq :: JS -> JS -> JS
776jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
777jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
778jsEq lhs rhs = JSBinOp "==" lhs rhs
780jsNotEq :: JS -> JS -> JS
781jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
783jsIsNumber :: JS -> JS
784jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
786jsIsNull :: JS -> JS
787jsIsNull js = JSBinOp "==" js JSNull
789jsBigInt :: JS -> JS
790jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
791jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
792jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
794jsUnPackBits :: JS -> JS
795jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
797jsPackUBits8 :: JS -> JS
798jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
800jsPackUBits16 :: JS -> JS
801jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
803jsPackUBits32 :: JS -> JS
804jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
806jsPackSBits8 :: JS -> JS
807jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
809jsPackSBits16 :: JS -> JS
810jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
812jsPackSBits32 :: JS -> JS
813jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
815jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
816jsCASE info safe reg cases def =
817 JSSwitch (tag safe $ translateReg reg) (
818 map ((JSNum . JSInt) *** prepBranch) cases
819 ) (fmap prepBranch def)
820 where
821 tag :: Bool -> JS -> JS
822 tag True = jsCTAG
823 tag False = jsTAG
825 prepBranch :: [BC] -> JS
826 prepBranch bc = JSSeq $ map (translateBC info) bc
828 jsTAG :: JS -> JS
829 jsTAG js =
830 (JSTernary (js `jsInstanceOf` "i$CON") (
831 JSProj js "tag"
832 ) (JSNum (JSInt $ negate 1)))
834 jsCTAG :: JS -> JS
835 jsCTAG js = JSProj js "tag"
838jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
839jsCONSTCASE info reg cases def =
840 JSCond $ (
841 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
842 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
843 where
844 prepBranch :: [BC] -> JS
845 prepBranch bc = JSSeq $ map (translateBC info) bc
847jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
848jsPROJECT _ reg loc ar =
849 JSApp (JSIdent "i$PROJECT") [ translateReg reg
850 , JSNum (JSInt loc)
851 , JSNum (JSInt ar)
852 ]
854jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
855jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
856 where
857 jsOP' :: JS
858 jsOP'
859 | LNoOp <- op = translateReg (last args)
861 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
862 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
863 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
865 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
866 | (LPlus (ATInt ITBig)) <- op
867 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
868 | (LMinus (ATInt ITBig)) <- op
869 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
870 | (LTimes (ATInt ITBig)) <- op
871 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
872 | (LSDiv (ATInt ITBig)) <- op
873 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
874 | (LSRem (ATInt ITBig)) <- op
875 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
876 | (LEq (ATInt ITBig)) <- op
877 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
878 | (LSLt (ATInt ITBig)) <- op
879 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
880 | (LSLe (ATInt ITBig)) <- op
881 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
882 | (LSGt (ATInt ITBig)) <- op
883 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
884 | (LSGe (ATInt ITBig)) <- op
885 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
887 | (LPlus ATFloat) <- op
888 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
889 | (LMinus ATFloat) <- op
890 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
891 | (LTimes ATFloat) <- op
892 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
893 | (LSDiv ATFloat) <- op
894 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
895 | (LEq ATFloat) <- op
896 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
897 | (LSLt ATFloat) <- op
898 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
899 | (LSLe ATFloat) <- op
900 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
901 | (LSGt ATFloat) <- op
902 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
903 | (LSGe ATFloat) <- op
904 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
906 | (LPlus (ATInt ITChar)) <- op
907 , (lhs:rhs:_) <- args =
908 jsCall "i$fromCharCode" [
909 JSBinOp "+" (
910 jsCall "i$charCode" [translateReg lhs]
911 ) (
912 jsCall "i$charCode" [translateReg rhs]
913 )
914 ]
916 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
917 , (arg:_) <- args =
918 jsPackUBits8 (
919 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
920 )
922 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
923 , (arg:_) <- args =
924 jsPackUBits16 (
925 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
926 )
928 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
929 , (arg:_) <- args =
930 jsPackUBits32 (
931 jsMeth (jsMeth (translateReg arg) "and" [
932 jsBigInt (JSString $ show 0xFFFFFFFF)
933 ]) "intValue" []
934 )
936 | (LTrunc ITBig (ITFixed IT64)) <- op
937 , (arg:_) <- args =
938 jsMeth (translateReg arg) "and" [
939 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
940 ]
942 | (LLSHR (ITFixed IT8)) <- op
943 , (lhs:rhs:_) <- args =
944 jsPackUBits8 (
945 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
946 )
948 | (LLSHR (ITFixed IT16)) <- op
949 , (lhs:rhs:_) <- args =
950 jsPackUBits16 (
951 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
952 )
954 | (LLSHR (ITFixed IT32)) <- op
955 , (lhs:rhs:_) <- args =
956 jsPackUBits32 (
957 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
958 )
960 | (LLSHR (ITFixed IT64)) <- op
961 , (lhs:rhs:_) <- args =
962 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
964 | (LSHL (ITFixed IT8)) <- op
965 , (lhs:rhs:_) <- args =
966 jsPackUBits8 (
967 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
968 )
970 | (LSHL (ITFixed IT16)) <- op
971 , (lhs:rhs:_) <- args =
972 jsPackUBits16 (
973 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
974 )
976 | (LSHL (ITFixed IT32)) <- op
977 , (lhs:rhs:_) <- args =
978 jsPackUBits32 (
979 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
980 )
982 | (LSHL (ITFixed IT64)) <- op
983 , (lhs:rhs:_) <- args =
984 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
985 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
986 ]
988 | (LAnd (ITFixed IT8)) <- op
989 , (lhs:rhs:_) <- args =
990 jsPackUBits8 (
991 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
992 )
994 | (LAnd (ITFixed IT16)) <- op
995 , (lhs:rhs:_) <- args =
996 jsPackUBits16 (
997 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
998 )
1000 | (LAnd (ITFixed IT32)) <- op
1001 , (lhs:rhs:_) <- args =
1002 jsPackUBits32 (
1003 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1006 | (LAnd (ITFixed IT64)) <- op
1007 , (lhs:rhs:_) <- args =
1008 jsMeth (translateReg lhs) "and" [translateReg rhs]
1010 | (LOr (ITFixed IT8)) <- op
1011 , (lhs:rhs:_) <- args =
1012 jsPackUBits8 (
1013 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1016 | (LOr (ITFixed IT16)) <- op
1017 , (lhs:rhs:_) <- args =
1018 jsPackUBits16 (
1019 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1022 | (LOr (ITFixed IT32)) <- op
1023 , (lhs:rhs:_) <- args =
1024 jsPackUBits32 (
1025 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1028 | (LOr (ITFixed IT64)) <- op
1029 , (lhs:rhs:_) <- args =
1030 jsMeth (translateReg lhs) "or" [translateReg rhs]
1032 | (LXOr (ITFixed IT8)) <- op
1033 , (lhs:rhs:_) <- args =
1034 jsPackUBits8 (
1035 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1038 | (LXOr (ITFixed IT16)) <- op
1039 , (lhs:rhs:_) <- args =
1040 jsPackUBits16 (
1041 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1044 | (LXOr (ITFixed IT32)) <- op
1045 , (lhs:rhs:_) <- args =
1046 jsPackUBits32 (
1047 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1050 | (LXOr (ITFixed IT64)) <- op
1051 , (lhs:rhs:_) <- args =
1052 jsMeth (translateReg lhs) "xor" [translateReg rhs]
1054 | (LPlus (ATInt (ITFixed IT8))) <- op
1055 , (lhs:rhs:_) <- args =
1056 jsPackUBits8 (
1057 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1060 | (LPlus (ATInt (ITFixed IT16))) <- op
1061 , (lhs:rhs:_) <- args =
1062 jsPackUBits16 (
1063 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1066 | (LPlus (ATInt (ITFixed IT32))) <- op
1067 , (lhs:rhs:_) <- args =
1068 jsPackUBits32 (
1069 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1072 | (LPlus (ATInt (ITFixed IT64))) <- op
1073 , (lhs:rhs:_) <- args =
1074 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
1075 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1078 | (LMinus (ATInt (ITFixed IT8))) <- op
1079 , (lhs:rhs:_) <- args =
1080 jsPackUBits8 (
1081 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1084 | (LMinus (ATInt (ITFixed IT16))) <- op
1085 , (lhs:rhs:_) <- args =
1086 jsPackUBits16 (
1087 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1090 | (LMinus (ATInt (ITFixed IT32))) <- op
1091 , (lhs:rhs:_) <- args =
1092 jsPackUBits32 (
1093 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1096 | (LMinus (ATInt (ITFixed IT64))) <- op
1097 , (lhs:rhs:_) <- args =
1098 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
1099 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1102 | (LTimes (ATInt (ITFixed IT8))) <- op
1103 , (lhs:rhs:_) <- args =
1104 jsPackUBits8 (
1105 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1108 | (LTimes (ATInt (ITFixed IT16))) <- op
1109 , (lhs:rhs:_) <- args =
1110 jsPackUBits16 (
1111 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1114 | (LTimes (ATInt (ITFixed IT32))) <- op
1115 , (lhs:rhs:_) <- args =
1116 jsPackUBits32 (
1117 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1120 | (LTimes (ATInt (ITFixed IT64))) <- op
1121 , (lhs:rhs:_) <- args =
1122 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
1123 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1126 | (LEq (ATInt (ITFixed IT8))) <- op
1127 , (lhs:rhs:_) <- args =
1128 jsPackUBits8 (
1129 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1132 | (LEq (ATInt (ITFixed IT16))) <- op
1133 , (lhs:rhs:_) <- args =
1134 jsPackUBits16 (
1135 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1138 | (LEq (ATInt (ITFixed IT32))) <- op
1139 , (lhs:rhs:_) <- args =
1140 jsPackUBits32 (
1141 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1144 | (LEq (ATInt (ITFixed IT64))) <- op
1145 , (lhs:rhs:_) <- args =
1146 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
1147 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1150 | (LLt (ITFixed IT8)) <- op
1151 , (lhs:rhs:_) <- args =
1152 jsPackUBits8 (
1153 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1156 | (LLt (ITFixed IT16)) <- op
1157 , (lhs:rhs:_) <- args =
1158 jsPackUBits16 (
1159 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1162 | (LLt (ITFixed IT32)) <- op
1163 , (lhs:rhs:_) <- args =
1164 jsPackUBits32 (
1165 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1168 | (LLt (ITFixed IT64)) <- op
1169 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1171 | (LLe (ITFixed IT8)) <- op
1172 , (lhs:rhs:_) <- args =
1173 jsPackUBits8 (
1174 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1177 | (LLe (ITFixed IT16)) <- op
1178 , (lhs:rhs:_) <- args =
1179 jsPackUBits16 (
1180 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1183 | (LLe (ITFixed IT32)) <- op
1184 , (lhs:rhs:_) <- args =
1185 jsPackUBits32 (
1186 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1189 | (LLe (ITFixed IT64)) <- op
1190 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1192 | (LGt (ITFixed IT8)) <- op
1193 , (lhs:rhs:_) <- args =
1194 jsPackUBits8 (
1195 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1198 | (LGt (ITFixed IT16)) <- op
1199 , (lhs:rhs:_) <- args =
1200 jsPackUBits16 (
1201 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1203 | (LGt (ITFixed IT32)) <- op
1204 , (lhs:rhs:_) <- args =
1205 jsPackUBits32 (
1206 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1209 | (LGt (ITFixed IT64)) <- op
1210 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1212 | (LGe (ITFixed IT8)) <- op
1213 , (lhs:rhs:_) <- args =
1214 jsPackUBits8 (
1215 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1218 | (LGe (ITFixed IT16)) <- op
1219 , (lhs:rhs:_) <- args =
1220 jsPackUBits16 (
1221 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1223 | (LGe (ITFixed IT32)) <- op
1224 , (lhs:rhs:_) <- args =
1225 jsPackUBits32 (
1226 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1229 | (LGe (ITFixed IT64)) <- op
1230 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1232 | (LUDiv (ITFixed IT8)) <- op
1233 , (lhs:rhs:_) <- args =
1234 jsPackUBits8 (
1235 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1238 | (LUDiv (ITFixed IT16)) <- op
1239 , (lhs:rhs:_) <- args =
1240 jsPackUBits16 (
1241 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1244 | (LUDiv (ITFixed IT32)) <- op
1245 , (lhs:rhs:_) <- args =
1246 jsPackUBits32 (
1247 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1250 | (LUDiv (ITFixed IT64)) <- op
1251 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1253 | (LSDiv (ATInt (ITFixed IT8))) <- op
1254 , (lhs:rhs:_) <- args =
1255 jsPackSBits8 (
1256 JSBinOp "/" (
1257 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1258 ) (
1259 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1263 | (LSDiv (ATInt (ITFixed IT16))) <- op
1264 , (lhs:rhs:_) <- args =
1265 jsPackSBits16 (
1266 JSBinOp "/" (
1267 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1268 ) (
1269 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1273 | (LSDiv (ATInt (ITFixed IT32))) <- op
1274 , (lhs:rhs:_) <- args =
1275 jsPackSBits32 (
1276 JSBinOp "/" (
1277 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1278 ) (
1279 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1283 | (LSDiv (ATInt (ITFixed IT64))) <- op
1284 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1286 | (LSRem (ATInt (ITFixed IT8))) <- op
1287 , (lhs:rhs:_) <- args =
1288 jsPackSBits8 (
1289 JSBinOp "%" (
1290 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1291 ) (
1292 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1296 | (LSRem (ATInt (ITFixed IT16))) <- op
1297 , (lhs:rhs:_) <- args =
1298 jsPackSBits16 (
1299 JSBinOp "%" (
1300 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1301 ) (
1302 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1306 | (LSRem (ATInt (ITFixed IT32))) <- op
1307 , (lhs:rhs:_) <- args =
1308 jsPackSBits32 (
1309 JSBinOp "%" (
1310 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1311 ) (
1312 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1316 | (LSRem (ATInt (ITFixed IT64))) <- op
1317 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1319 | (LCompl (ITFixed IT8)) <- op
1320 , (arg:_) <- args =
1321 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1323 | (LCompl (ITFixed IT16)) <- op
1324 , (arg:_) <- args =
1325 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1327 | (LCompl (ITFixed IT32)) <- op
1328 , (arg:_) <- args =
1329 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1331 | (LCompl (ITFixed IT64)) <- op
1332 , (arg:_) <- args =
1333 invokeMeth arg "not" []
1335 | (LPlus _) <- op
1336 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1337 | (LMinus _) <- op
1338 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1339 | (LTimes _) <- op
1340 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1341 | (LSDiv _) <- op
1342 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1343 | (LSRem _) <- op
1344 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1345 | (LEq _) <- op
1346 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1347 | (LSLt _) <- op
1348 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1349 | (LSLe _) <- op
1350 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1351 | (LSGt _) <- op
1352 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1353 | (LSGe _) <- op
1354 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1355 | (LAnd _) <- op
1356 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1357 | (LOr _) <- op
1358 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1359 | (LXOr _) <- op
1360 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1361 | (LSHL _) <- op
1362 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1363 | (LASHR _) <- op
1364 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1365 | (LCompl _) <- op
1366 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1368 | LStrConcat <- op
1369 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1370 | LStrEq <- op
1371 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1372 | LStrLt <- op
1373 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1374 | LStrLen <- op
1375 , (arg:_) <- args = JSProj (translateReg arg) "length"
1376 | (LStrInt ITNative) <- op
1377 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1378 | (LIntStr ITNative) <- op
1379 , (arg:_) <- args = jsCall "String" [translateReg arg]
1380 | (LSExt ITNative ITBig) <- op
1381 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1382 | (LTrunc ITBig ITNative) <- op
1383 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1384 | (LIntStr ITBig) <- op
1385 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1386 | (LStrInt ITBig) <- op
1387 , (arg:_) <- args = jsBigInt $ translateReg arg
1388 | LFloatStr <- op
1389 , (arg:_) <- args = jsCall "String" [translateReg arg]
1390 | LStrFloat <- op
1391 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1392 | (LIntFloat ITNative) <- op
1393 , (arg:_) <- args = translateReg arg
1394 | (LFloatInt ITNative) <- op
1395 , (arg:_) <- args = translateReg arg
1396 | (LChInt ITNative) <- op
1397 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1398 | (LIntCh ITNative) <- op
1399 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1401 | LFExp <- op
1402 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1403 | LFLog <- op
1404 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1405 | LFSin <- op
1406 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1407 | LFCos <- op
1408 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1409 | LFTan <- op
1410 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1411 | LFASin <- op
1412 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1413 | LFACos <- op
1414 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1415 | LFATan <- op
1416 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1417 | LFSqrt <- op
1418 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1419 | LFFloor <- op
1420 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1421 | LFCeil <- op
1422 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1424 | LStrCons <- op
1425 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1426 | LStrHead <- op
1427 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1428 | LStrRev <- op
1429 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1430 | LStrIndex <- op
1431 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1432 | LStrTail <- op
1433 , (arg:_) <- args =
1434 let v = translateReg arg in
1435 JSApp (JSProj v "substr") [
1436 JSNum (JSInt 1),
1437 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1440 | LSystemInfo <- op
1441 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1442 | LNullPtr <- op
1443 , (_) <- args = JSNull
1444 | otherwise = JSError $ "Not implemented: " ++ show op
1445 where
1446 translateBinaryOp :: String -> Reg -> Reg -> JS
1447 translateBinaryOp op lhs rhs =
1448 JSBinOp op (translateReg lhs) (translateReg rhs)
1450 invokeMeth :: Reg -> String -> [Reg] -> JS
1451 invokeMeth obj meth args =
1452 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1455jsRESERVE :: CompileInfo -> Int -> JS
1456jsRESERVE _ _ = JSNoop
1458jsSTACK :: JS
1459jsSTACK = JSIdent "i$valstack"
1461jsCALLSTACK :: JS
1462jsCALLSTACK = JSIdent "i$callstack"
1464jsSTACKBASE :: JS
1465jsSTACKBASE = JSIdent "i$valstack_base"
1467jsSTACKTOP :: JS
1468jsSTACKTOP = JSIdent "i$valstack_top"
1470jsOLDBASE :: JS
1471jsOLDBASE = JSIdent "oldbase"
1473jsMYOLDBASE :: JS
1474jsMYOLDBASE = JSIdent "myoldbase"
1476jsRET :: JS
1477jsRET = JSIdent "i$ret"
1479jsLOC :: Int -> JS
1480jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1481jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1483jsTOP :: Int -> JS
1484jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1485jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1487jsPUSH :: [JS] -> JS
1488jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1490jsPOP :: JS
1491jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1493translateBC :: CompileInfo -> BC -> JS
1494translateBC info bc
1495 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1496 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1497 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1498 | ADDTOP n <- bc = jsADDTOP info n
1499 | NULL r <- bc = jsNULL info r
1500 | CALL n <- bc = jsCALL info n
1501 | TAILCALL n <- bc = jsTAILCALL info n
1502 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1503 | TOPBASE n <- bc = jsTOPBASE info n
1504 | BASETOP n <- bc = jsBASETOP info n
1505 | STOREOLD <- bc = jsSTOREOLD info
1506 | SLIDE n <- bc = jsSLIDE info n
1507 | REBASE <- bc = jsREBASE info
1508 | RESERVE n <- bc = jsRESERVE info n
1509 | MKCON r t rs <- bc = jsMKCON info r t rs
1510 | CASE s r c d <- bc = jsCASE info s r c d
1511 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1512 | PROJECT r l a <- bc = jsPROJECT info r l a
1513 | OP r o a <- bc = jsOP info r o a
1514 | ERROR e <- bc = jsERROR info e
1515 | otherwise = JSRaw $ show bc
1516 {- PROJECTINTO _ _ _ <- bc = undefined -}