git.iko.soy/Idris-dev
on ded4d17 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1612 lines 55 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 IRTS.System
11import Util.System
13import Control.Arrow
14import Control.Monad (mapM)
15import Control.Applicative ((<$>), (<*>), pure)
16import Control.Monad.RWS hiding (mapM)
17import Control.Monad.State
18import Data.Char
19import Numeric
20import Data.List
21import Data.Maybe
22import Data.Word
23import Data.Traversable hiding (mapM)
24import System.IO
25import System.Directory
27import qualified Data.Map.Strict as M
30data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
31 , compileInfoEvalCases :: [Int]
32 , compileInfoNeedsBigInt :: Bool
33 }
36initCompileInfo :: [(Name, [BC])] -> CompileInfo
37initCompileInfo bc =
38 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
39 where
40 lookupBigInt :: [(Name, [BC])] -> Bool
41 lookupBigInt = any (needsBigInt . snd)
42 where
43 needsBigInt :: [BC] -> Bool
44 needsBigInt bc = or $ map testBCForBigInt bc
45 where
46 testBCForBigInt :: BC -> Bool
47 testBCForBigInt (ASSIGNCONST _ c) =
48 testConstForBigInt c
50 testBCForBigInt (CONSTCASE _ c d) =
51 maybe False needsBigInt d
52 || (or $ map (needsBigInt . snd) c)
53 || (or $ map (testConstForBigInt . fst) c)
55 testBCForBigInt _ = False
57 testConstForBigInt :: Const -> Bool
58 testConstForBigInt (BI _) = True
59 testConstForBigInt (B64 _) = True
60 testConstForBigInt _ = False
63 collectCases :: String -> [(Name, [BC])] -> [Int]
64 collectCases fun bc = getCases $ findFunction fun bc
66 findFunction :: String -> [(Name, [BC])] -> [BC]
67 findFunction f ((MN 0 fun, bc):_)
68 | fun == txt f = bc
69 findFunction f (_:bc) = findFunction f bc
71 getCases :: [BC] -> [Int]
72 getCases = concatMap analyze
73 where
74 analyze :: BC -> [Int]
75 analyze (CASE _ _ b _) = map fst b
76 analyze _ = []
79data JSTarget = Node | JavaScript deriving Eq
82data JSType = JSIntTy
83 | JSStringTy
84 | JSIntegerTy
85 | JSFloatTy
86 | JSCharTy
87 | JSPtrTy
88 | JSForgotTy
89 deriving Eq
92data JSInteger = JSBigZero
93 | JSBigOne
94 | JSBigInt Integer
95 | JSBigIntExpr JS
96 deriving Eq
99data JSNum = JSInt Int
100 | JSFloat Double
101 | JSInteger JSInteger
102 deriving Eq
105data JSWord = JSWord8 Word8
106 | JSWord16 Word16
107 | JSWord32 Word32
108 | JSWord64 Word64
109 deriving Eq
112data JSAnnotation = JSConstructor deriving Eq
115instance Show JSAnnotation where
116 show JSConstructor = "constructor"
119data JS = JSRaw String
120 | JSIdent String
121 | JSFunction [String] JS
122 | JSType JSType
123 | JSSeq [JS]
124 | JSReturn JS
125 | JSApp JS [JS]
126 | JSNew String [JS]
127 | JSError String
128 | JSBinOp String JS JS
129 | JSPreOp String JS
130 | JSPostOp String JS
131 | JSProj JS String
132 | JSNull
133 | JSUndefined
134 | JSThis
135 | JSTrue
136 | JSFalse
137 | JSArray [JS]
138 | JSString String
139 | JSNum JSNum
140 | JSWord JSWord
141 | JSAssign JS JS
142 | JSAlloc String (Maybe JS)
143 | JSIndex JS JS
144 | JSSwitch JS [(JS, JS)] (Maybe JS)
145 | JSCond [(JS, JS)]
146 | JSTernary JS JS JS
147 | JSParens JS
148 | JSWhile JS JS
149 | JSFFI String [JS]
150 | JSAnnotation JSAnnotation JS
151 | JSNoop
152 deriving Eq
155data FFI = FFICode Char | FFIArg Int | FFIError String
157ffi :: String -> [String] -> String
158ffi code args = let parsed = ffiParse code in
159 case ffiError parsed of
160 Just err -> error err
161 Nothing -> renderFFI parsed args
162 where
163 ffiParse :: String -> [FFI]
164 ffiParse "" = []
165 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
166 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
167 ffiParse ('%':s:ss)
168 | isDigit s =
169 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
170 | otherwise =
171 [FFIError "FFI - Invalid positional argument"]
172 ffiParse (s:ss) = FFICode s : ffiParse ss
175 ffiError :: [FFI] -> Maybe String
176 ffiError [] = Nothing
177 ffiError ((FFIError s):xs) = Just s
178 ffiError (x:xs) = ffiError xs
181 renderFFI :: [FFI] -> [String] -> String
182 renderFFI [] _ = ""
183 renderFFI (FFICode c : fs) args = c : renderFFI fs args
184 renderFFI (FFIArg i : fs) args
185 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
186 | otherwise = error "FFI - Argument index out of bounds"
188compileJS :: JS -> String
189compileJS = compileJS' 0
191compileJS' :: Int -> JS -> String
192compileJS' indent JSNoop = ""
194compileJS' indent (JSAnnotation annotation js) =
195 "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
197compileJS' indent (JSFFI raw args) =
198 ffi raw (map (compileJS' indent) args)
200compileJS' indent (JSRaw code) =
201 code
203compileJS' indent (JSIdent ident) =
204 ident
206compileJS' indent (JSFunction args body) =
207 replicate indent ' ' ++ "function("
208 ++ intercalate "," args
209 ++ "){\n"
210 ++ compileJS' (indent + 2) body
211 ++ "\n}\n"
213compileJS' indent (JSType ty)
214 | JSIntTy <- ty = "i$Int"
215 | JSStringTy <- ty = "i$String"
216 | JSIntegerTy <- ty = "i$Integer"
217 | JSFloatTy <- ty = "i$Float"
218 | JSCharTy <- ty = "i$Char"
219 | JSPtrTy <- ty = "i$Ptr"
220 | JSForgotTy <- ty = "i$Forgot"
222compileJS' indent (JSSeq seq) =
223 intercalate ";\n" (
224 map (
225 (replicate indent ' ' ++) . (compileJS' indent)
226 ) $ filter (/= JSNoop) seq
227 ) ++ ";"
229compileJS' indent (JSReturn val) =
230 "return " ++ compileJS' indent val
232compileJS' indent (JSApp lhs rhs)
233 | JSFunction {} <- lhs =
234 concat ["(", compileJS' indent lhs, ")(", args, ")"]
235 | otherwise =
236 concat [compileJS' indent lhs, "(", args, ")"]
237 where args :: String
238 args = intercalate "," $ map (compileJS' 0) rhs
240compileJS' indent (JSNew name args) =
241 "new " ++ name ++ "(" ++ intercalate "," (map (compileJS' 0) args) ++ ")"
243compileJS' indent (JSError exc) =
244 "throw new Error(\"" ++ exc ++ "\")"
246compileJS' indent (JSBinOp op lhs rhs) =
247 compileJS' indent lhs ++ " " ++ op ++ " " ++ compileJS' indent rhs
249compileJS' indent (JSPreOp op val) =
250 op ++ compileJS' indent val
252compileJS' indent (JSProj obj field)
253 | JSFunction {} <- obj =
254 concat ["(", compileJS' indent obj, ").", field]
255 | JSAssign {} <- obj =
256 concat ["(", compileJS' indent obj, ").", field]
257 | otherwise =
258 compileJS' indent obj ++ '.' : field
260compileJS' indent JSNull =
261 "null"
263compileJS' indent JSUndefined =
264 "undefined"
266compileJS' indent JSThis =
267 "this"
269compileJS' indent JSTrue =
270 "true"
272compileJS' indent JSFalse =
273 "false"
275compileJS' indent (JSArray elems) =
276 "[" ++ intercalate "," (map (compileJS' 0) elems) ++ "]"
278compileJS' indent (JSString str) =
279 "\"" ++ str ++ "\""
281compileJS' indent (JSNum num)
282 | JSInt i <- num = show i
283 | JSFloat f <- num = show f
284 | JSInteger JSBigZero <- num = "i$ZERO"
285 | JSInteger JSBigOne <- num = "i$ONE"
286 | JSInteger (JSBigInt i) <- num = show i
287 | JSInteger (JSBigIntExpr e) <- num = "i$bigInt(" ++ compileJS' indent e ++ ")"
289compileJS' indent (JSAssign lhs rhs) =
290 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
292compileJS' 0 (JSAlloc name (Just val@(JSNew _ _))) =
293 "var " ++ name ++ " = " ++ compileJS' 0 val ++ ";\n"
295compileJS' indent (JSAlloc name val) =
296 "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val
298compileJS' indent (JSIndex lhs rhs) =
299 compileJS' indent lhs ++ "[" ++ compileJS' indent rhs ++ "]"
301compileJS' indent (JSCond branches) =
302 intercalate " else " $ map createIfBlock branches
303 where
304 createIfBlock (JSNoop, e@(JSSeq _)) =
305 "{\n"
306 ++ compileJS' (indent + 2) e
307 ++ "\n" ++ replicate indent ' ' ++ "}"
308 createIfBlock (JSNoop, e) =
309 "{\n"
310 ++ compileJS' (indent + 2) e
311 ++ ";\n" ++ replicate indent ' ' ++ "}"
312 createIfBlock (cond, e@(JSSeq _)) =
313 "if (" ++ compileJS' indent cond ++") {\n"
314 ++ compileJS' (indent + 2) e
315 ++ "\n" ++ replicate indent ' ' ++ "}"
316 createIfBlock (cond, e) =
317 "if (" ++ compileJS' indent cond ++") {\n"
318 ++ replicate (indent + 2) ' ' ++ compileJS' (indent + 2) e
319 ++ ";\n" ++ replicate indent ' ' ++ "}"
321compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
322 let (h,t) = splitAt 1 seq in
323 (concatMap (compileJS' indent) h ++ ";\n")
324 ++ (intercalate ";\n" $ map ((replicate indent ' ' ++) . compileJS' indent) t)
326compileJS' indent (JSSwitch val branches def) =
327 "switch(" ++ compileJS' indent val ++ "){\n"
328 ++ concatMap mkBranch branches
329 ++ mkDefault def
330 ++ replicate indent ' ' ++ "}"
331 where
332 mkBranch :: (JS, JS) -> String
333 mkBranch (tag, code) =
334 replicate (indent + 2) ' ' ++ "case " ++ compileJS' indent tag ++ ":\n"
335 ++ compileJS' (indent + 4) code
336 ++ "\n" ++ (replicate (indent + 4) ' ' ++ "break;\n")
338 mkDefault :: Maybe JS -> String
339 mkDefault Nothing = ""
340 mkDefault (Just def) =
341 replicate (indent + 2) ' ' ++ "default:\n"
342 ++ compileJS' (indent + 4)def
343 ++ "\n"
346compileJS' indent (JSTernary cond true false) =
347 let c = compileJS' indent cond
348 t = compileJS' indent true
349 f = compileJS' indent false in
350 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
352compileJS' indent (JSParens js) =
353 "(" ++ compileJS' indent js ++ ")"
355compileJS' indent (JSWhile cond body) =
356 "while (" ++ compileJS' indent cond ++ ") {\n"
357 ++ compileJS' (indent + 2) body
358 ++ "\n" ++ replicate indent ' ' ++ "}"
360compileJS' indent (JSWord word)
361 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
362 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
363 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
364 | JSWord64 b <- word = "i$bigInt(\"" ++ show b ++ "\")"
366codegenJavaScript :: CodeGenerator
367codegenJavaScript ci =
368 codegenJS_all JavaScript (simpleDecls ci)
369 (includes ci) [] (outputFile ci) (outputType ci)
371codegenNode :: CodeGenerator
372codegenNode ci =
373 codegenJS_all Node (simpleDecls ci)
374 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
376codegenJS_all
377 :: JSTarget
378 -> [(Name, SDecl)]
379 -> [FilePath]
380 -> [String]
381 -> FilePath
382 -> OutputType
383 -> IO ()
384codegenJS_all target definitions includes libs filename outputType = do
385 let bytecode = map toBC definitions
386 let info = initCompileInfo bytecode
387 let js = concatMap (translateDecl info) bytecode
388 let code = concatMap processFunction js
389 let (cons, opt) = optimizeConstructors code
390 let (header, rt) = case target of
391 Node -> ("#!/usr/bin/env node\n", "-node")
392 JavaScript -> ("", "-browser")
394 included <- concat <$> getIncludes includes
395 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
396 idrRuntime <- readFile $ path ++ "Runtime-common.js"
397 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
398 jsbn <- if compileInfoNeedsBigInt info
399 then readFile $ path ++ "jsbn/jsbn.js"
400 else return ""
401 let runtime = ( header
402 ++ includeLibs libs
403 ++ included
404 ++ jsbn
405 ++ idrRuntime
406 ++ tgtRuntime
407 )
408 writeFile filename ( runtime
409 ++ concatMap compileJS opt
410 ++ concatMap compileJS cons
411 ++ main
412 ++ invokeMain
413 )
414 setPermissions filename (emptyPermissions { readable = True
415 , executable = target == Node
416 , writable = True
417 })
418 where
419 processFunction :: JS -> [JS]
420 processFunction js =
421 (
422 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
423 ) js
425 includeLibs :: [String] -> String
426 includeLibs =
427 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
429 getIncludes :: [FilePath] -> IO [String]
430 getIncludes = mapM readFile
432 main :: String
433 main =
434 compileJS $ JSAlloc "main" (Just $
435 JSFunction [] (
436 case target of
437 Node -> mainFun
438 JavaScript -> jsMain
439 )
440 )
442 jsMain :: JS
443 jsMain =
444 JSCond [ (exists document `jsAnd` isReady, mainFun)
445 , (exists window, windowMainFun)
446 , (JSTrue, mainFun)
447 ]
448 where
449 exists :: JS -> JS
450 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
452 window :: JS
453 window = JSIdent "window"
455 document :: JS
456 document = JSIdent "document"
458 windowMainFun :: JS
459 windowMainFun =
460 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
461 , JSFunction [] ( mainFun )
462 , JSFalse
463 ]
465 isReady :: JS
466 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
468 readyState :: JS
469 readyState = JSProj (JSIdent "document") "readyState"
471 mainFun :: JS
472 mainFun =
473 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
474 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
475 , JSApp (
476 JSIdent (translateName (sMN 0 "runMain"))
477 ) [JSNum (JSInt 0)]
478 , JSWhile (JSProj jsCALLSTACK "length") (
479 JSSeq [ JSAlloc "func" (Just jsPOP)
480 , JSAlloc "args" (Just jsPOP)
481 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
482 ]
483 )
484 ]
486 invokeMain :: String
487 invokeMain = compileJS $ JSApp (JSIdent "main") []
489optimizeConstructors :: [JS] -> ([JS], [JS])
490optimizeConstructors js =
491 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
492 (map (allocCon . snd) (M.toList cons), js')
493 where
494 allocCon :: (String, JS) -> JS
495 allocCon (name, con) = JSAlloc name (Just con)
497 newConstructor :: Int -> String
498 newConstructor n = "i$CON$" ++ show n
500 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
501 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
502 , JSArray []
503 , a
504 , e
505 ]) = do
506 s <- get
507 case M.lookup tag s of
508 Just (i, c) -> return $ JSIdent i
509 Nothing -> do let n = newConstructor tag
510 put $ M.insert tag (n, js) s
511 return $ JSIdent n
513 optimizeConstructor' (JSSeq seq) =
514 JSSeq <$> traverse optimizeConstructor' seq
516 optimizeConstructor' (JSSwitch reg cond def) = do
517 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
518 def' <- traverse optimizeConstructor' def
519 return $ JSSwitch reg cond' def'
521 optimizeConstructor' (JSCond cond) =
522 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
524 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
525 body' <- optimizeConstructor' body
526 return $ JSAlloc fun (Just (JSFunction args body'))
528 optimizeConstructor' (JSAssign lhs rhs) = do
529 lhs' <- optimizeConstructor' lhs
530 rhs' <- optimizeConstructor' rhs
531 return $ JSAssign lhs' rhs'
533 optimizeConstructor' js = return js
535collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
536collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
537 where
538 generateSplitFunction :: (Int,JS) -> JS
539 generateSplitFunction (depth, JSAlloc name fun) =
540 JSAlloc (name ++ "$" ++ show depth) fun
542splitFunction :: JS -> RWS () [(Int,JS)] Int JS
543splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
544 body' <- splitSequence body
545 return $ JSAlloc name (Just (JSFunction args body'))
546 where
547 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
548 splitCondition js
549 | JSCond branches <- js =
550 JSCond <$> processBranches branches
551 | JSSwitch cond branches def <- js =
552 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
553 | otherwise = return js
554 where
555 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
556 processBranches =
557 traverse (runKleisli (arr id *** Kleisli splitSequence))
559 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
560 splitSequence js@(JSSeq seq) =
561 let (pre,post) = break isCall seq in
562 case post of
563 [] -> JSSeq <$> traverse splitCondition seq
564 [js@(JSCond _)] -> splitCondition js
565 [js@(JSSwitch {})] -> splitCondition js
566 [_] -> return js
567 (call:rest) -> do
568 depth <- get
569 put (depth + 1)
570 new <- splitFunction (newFun rest)
571 tell [(depth, new)]
572 return $ JSSeq (pre ++ (newCall depth : [call]))
574 splitSequence js = return js
576 isCall :: JS -> Bool
577 isCall (JSApp (JSIdent "i$CALL") _) = True
578 isCall _ = False
580 newCall :: Int -> JS
581 newCall depth =
582 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
583 , JSArray [jsOLDBASE, jsMYOLDBASE]
584 ]
586 newFun :: [JS] -> JS
587 newFun seq =
588 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
590splitFunction js = return js
592translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
593translateDecl info (name@(MN 0 fun), bc)
594 | txt "APPLY" == fun =
595 allocCaseFunctions (snd body)
596 ++ [ JSAlloc (
597 translateName name
598 ) (Just $ JSFunction ["oldbase"] (
599 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
600 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
601 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
602 )
603 , ( JSNoop
604 , JSSeq $ map (translateBC info) (defaultCase (snd body))
605 )
606 ]
607 ]
608 )
609 )
610 ]
612 | txt "EVAL" == fun =
613 allocCaseFunctions (snd body)
614 ++ [ JSAlloc (
615 translateName name
616 ) (Just $ JSFunction ["oldbase"] (
617 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
618 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
619 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
620 )
621 , ( JSNoop
622 , JSSeq $ map (translateBC info) (defaultCase (snd body))
623 )
624 ]
625 ]
626 )
627 )
628 ]
629 where
630 body :: ([BC], [BC])
631 body = break isCase bc
633 isCase :: BC -> Bool
634 isCase bc
635 | CASE {} <- bc = True
636 | otherwise = False
638 defaultCase :: [BC] -> [BC]
639 defaultCase ((CASE _ _ _ (Just d)):_) = d
641 caseReg :: [BC] -> Reg
642 caseReg ((CASE _ r _ _):_) = r
644 allocCaseFunctions :: [BC] -> [JS]
645 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
646 allocCaseFunctions _ = []
648 splitBranches :: [(Int, [BC])] -> [JS]
649 splitBranches = map prepBranch
651 prepBranch :: (Int, [BC]) -> JS
652 prepBranch (tag, code) =
653 JSAlloc (
654 translateName name ++ "$" ++ show tag
655 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
656 JSSeq $ map (translateBC info) code
657 )
658 )
660translateDecl info (name, bc) =
661 [ JSAlloc (
662 translateName name
663 ) (Just $ JSFunction ["oldbase"] (
664 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
665 )
666 )
667 ]
670translateReg :: Reg -> JS
671translateReg reg
672 | RVal <- reg = jsRET
673 | Tmp <- reg = JSRaw "//TMPREG"
674 | L n <- reg = jsLOC n
675 | T n <- reg = jsTOP n
677translateConstant :: Const -> JS
678translateConstant (I i) = JSNum (JSInt i)
679translateConstant (Fl f) = JSNum (JSFloat f)
680translateConstant (Ch c) = JSString $ translateChar c
681translateConstant (Str s) = JSString $ concatMap translateChar s
682translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
683translateConstant StrType = JSType JSStringTy
684translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
685translateConstant (AType ATFloat) = JSType JSFloatTy
686translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
687translateConstant PtrType = JSType JSPtrTy
688translateConstant Forgot = JSType JSForgotTy
689translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
690translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
691translateConstant (BI i) = jsBigInt (JSString $ show i)
692translateConstant (B8 b) = JSWord (JSWord8 b)
693translateConstant (B16 b) = JSWord (JSWord16 b)
694translateConstant (B32 b) = JSWord (JSWord32 b)
695translateConstant (B64 b) = JSWord (JSWord64 b)
696translateConstant c =
697 JSError $ "Unimplemented Constant: " ++ show c
700translateChar :: Char -> String
701translateChar ch
702 | '\a' <- ch = "\\u0007"
703 | '\b' <- ch = "\\b"
704 | '\f' <- ch = "\\f"
705 | '\n' <- ch = "\\n"
706 | '\r' <- ch = "\\r"
707 | '\t' <- ch = "\\t"
708 | '\v' <- ch = "\\v"
709 | '\SO' <- ch = "\\u000E"
710 | '\DEL' <- ch = "\\u007F"
711 | '\\' <- ch = "\\\\"
712 | '\"' <- ch = "\\\""
713 | '\'' <- ch = "\\\'"
714 | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")
715 | otherwise = [ch]
716 where
717 fill :: String -> String
718 fill s = if length s == 1
719 then '0' : s
720 else s
722 asciiTab =
723 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
724 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
725 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
726 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
728translateName :: Name -> String
729translateName n = "_idris_" ++ concatMap cchar (showCG n)
730 where cchar x | isAlphaNum x = [x]
731 | otherwise = "_" ++ show (fromEnum x) ++ "_"
733jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
734jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
736jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
737jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
739jsCALL :: CompileInfo -> Name -> JS
740jsCALL _ n =
741 JSApp (
742 JSIdent "i$CALL"
743 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
745jsTAILCALL :: CompileInfo -> Name -> JS
746jsTAILCALL _ n =
747 JSApp (
748 JSIdent "i$CALL"
749 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
751jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
752jsFOREIGN _ reg n args
753 | n == "putStr"
754 , [(FString, arg)] <- args =
755 JSAssign (
756 translateReg reg
757 ) (
758 JSApp (JSIdent "i$putStr") [translateReg arg]
759 )
761 | n == "isNull"
762 , [(FPtr, arg)] <- args =
763 JSAssign (
764 translateReg reg
765 ) (
766 JSBinOp "==" (translateReg arg) JSNull
767 )
769 | n == "idris_eqPtr"
770 , [(_, lhs),(_, rhs)] <- args =
771 JSAssign (
772 translateReg reg
773 ) (
774 JSBinOp "==" (translateReg lhs) (translateReg rhs)
775 )
776 | otherwise =
777 JSAssign (
778 translateReg reg
779 ) (
780 JSFFI n (map generateWrapper args)
781 )
782 where
783 generateWrapper :: (FType, Reg) -> JS
784 generateWrapper (ty, reg)
785 | FFunction <- ty =
786 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
787 , JSIdent "oldbase"
788 , JSIdent "myoldbase"
789 ]
790 | FFunctionIO <- ty =
791 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
792 , JSIdent "oldbase"
793 , JSIdent "myoldbase"
794 ]
796 generateWrapper (_, reg) =
797 translateReg reg
799jsREBASE :: CompileInfo -> JS
800jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
802jsSTOREOLD :: CompileInfo ->JS
803jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
805jsADDTOP :: CompileInfo -> Int -> JS
806jsADDTOP info n
807 | 0 <- n = JSNoop
808 | otherwise =
809 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
811jsTOPBASE :: CompileInfo -> Int -> JS
812jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
813jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
816jsBASETOP :: CompileInfo -> Int -> JS
817jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
818jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
820jsNULL :: CompileInfo -> Reg -> JS
821jsNULL _ r = JSAssign (translateReg r) JSNull
823jsERROR :: CompileInfo -> String -> JS
824jsERROR _ = JSError
826jsSLIDE :: CompileInfo -> Int -> JS
827jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
828jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
830jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
831jsMKCON info r t rs =
832 JSAssign (translateReg r) (
833 JSNew "i$CON" [ JSNum (JSInt t)
834 , JSArray (map translateReg rs)
835 , if t `elem` compileInfoApplyCases info
836 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
837 else JSNull
838 , if t `elem` compileInfoEvalCases info
839 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
840 else JSNull
841 ]
842 )
844jsInstanceOf :: JS -> String -> JS
845jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
847jsOr :: JS -> JS -> JS
848jsOr lhs rhs = JSBinOp "||" lhs rhs
850jsAnd :: JS -> JS -> JS
851jsAnd lhs rhs = JSBinOp "&&" lhs rhs
853jsMeth :: JS -> String -> [JS] -> JS
854jsMeth obj meth args = JSApp (JSProj obj meth) args
856jsCall :: String -> [JS] -> JS
857jsCall fun args = JSApp (JSIdent fun) args
859jsTypeOf :: JS -> JS
860jsTypeOf js = JSPreOp "typeof " js
862jsEq :: JS -> JS -> JS
863jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
864jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
865jsEq lhs rhs = JSBinOp "==" lhs rhs
867jsNotEq :: JS -> JS -> JS
868jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
870jsIsNumber :: JS -> JS
871jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
873jsIsNull :: JS -> JS
874jsIsNull js = JSBinOp "==" js JSNull
876jsBigInt :: JS -> JS
877jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
878jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
879jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
881jsUnPackBits :: JS -> JS
882jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
884jsPackUBits8 :: JS -> JS
885jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
887jsPackUBits16 :: JS -> JS
888jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
890jsPackUBits32 :: JS -> JS
891jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
893jsPackSBits8 :: JS -> JS
894jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
896jsPackSBits16 :: JS -> JS
897jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
899jsPackSBits32 :: JS -> JS
900jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
902jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
903jsCASE info safe reg cases def =
904 JSSwitch (tag safe $ translateReg reg) (
905 map ((JSNum . JSInt) *** prepBranch) cases
906 ) (fmap prepBranch def)
907 where
908 tag :: Bool -> JS -> JS
909 tag True = jsCTAG
910 tag False = jsTAG
912 prepBranch :: [BC] -> JS
913 prepBranch bc = JSSeq $ map (translateBC info) bc
915 jsTAG :: JS -> JS
916 jsTAG js =
917 (JSTernary (js `jsInstanceOf` "i$CON") (
918 JSProj js "tag"
919 ) (JSNum (JSInt $ negate 1)))
921 jsCTAG :: JS -> JS
922 jsCTAG js = JSProj js "tag"
925jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
926jsCONSTCASE info reg cases def =
927 JSCond $ (
928 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
929 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
930 where
931 prepBranch :: [BC] -> JS
932 prepBranch bc = JSSeq $ map (translateBC info) bc
934jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
935jsPROJECT _ reg loc 0 = JSNoop
936jsPROJECT _ reg loc 1 =
937 JSAssign (jsLOC loc) (
938 JSIndex (
939 JSProj (translateReg reg) "args"
940 ) (
941 JSNum (JSInt 0)
942 )
943 )
944jsPROJECT _ reg loc ar =
945 JSApp (JSIdent "i$PROJECT") [ translateReg reg
946 , JSNum (JSInt loc)
947 , JSNum (JSInt ar)
948 ]
950jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
951jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
952 where
953 jsOP' :: JS
954 jsOP'
955 | LNoOp <- op = translateReg (last args)
957 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
958 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
959 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
961 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
962 | (LPlus (ATInt ITBig)) <- op
963 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
964 | (LMinus (ATInt ITBig)) <- op
965 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
966 | (LTimes (ATInt ITBig)) <- op
967 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
968 | (LSDiv (ATInt ITBig)) <- op
969 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
970 | (LSRem (ATInt ITBig)) <- op
971 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
972 | (LEq (ATInt ITBig)) <- op
973 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
974 | (LSLt (ATInt ITBig)) <- op
975 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
976 | (LSLe (ATInt ITBig)) <- op
977 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
978 | (LSGt (ATInt ITBig)) <- op
979 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
980 | (LSGe (ATInt ITBig)) <- op
981 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
983 | (LPlus ATFloat) <- op
984 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
985 | (LMinus ATFloat) <- op
986 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
987 | (LTimes ATFloat) <- op
988 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
989 | (LSDiv ATFloat) <- op
990 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
991 | (LEq ATFloat) <- op
992 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
993 | (LSLt ATFloat) <- op
994 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
995 | (LSLe ATFloat) <- op
996 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
997 | (LSGt ATFloat) <- op
998 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
999 | (LSGe ATFloat) <- op
1000 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1002 | (LPlus (ATInt ITChar)) <- op
1003 , (lhs:rhs:_) <- args =
1004 jsCall "i$fromCharCode" [
1005 JSBinOp "+" (
1006 jsCall "i$charCode" [translateReg lhs]
1007 ) (
1008 jsCall "i$charCode" [translateReg rhs]
1012 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1013 , (arg:_) <- args =
1014 jsPackUBits8 (
1015 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
1018 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1019 , (arg:_) <- args =
1020 jsPackUBits16 (
1021 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
1024 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
1025 , (arg:_) <- args =
1026 jsPackUBits32 (
1027 jsMeth (jsMeth (translateReg arg) "and" [
1028 jsBigInt (JSString $ show 0xFFFFFFFF)
1029 ]) "intValue" []
1032 | (LTrunc ITBig (ITFixed IT64)) <- op
1033 , (arg:_) <- args =
1034 jsMeth (translateReg arg) "and" [
1035 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1038 | (LLSHR (ITFixed IT8)) <- op
1039 , (lhs:rhs:_) <- args =
1040 jsPackUBits8 (
1041 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1044 | (LLSHR (ITFixed IT16)) <- op
1045 , (lhs:rhs:_) <- args =
1046 jsPackUBits16 (
1047 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1050 | (LLSHR (ITFixed IT32)) <- op
1051 , (lhs:rhs:_) <- args =
1052 jsPackUBits32 (
1053 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1056 | (LLSHR (ITFixed IT64)) <- op
1057 , (lhs:rhs:_) <- args =
1058 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
1060 | (LSHL (ITFixed IT8)) <- op
1061 , (lhs:rhs:_) <- args =
1062 jsPackUBits8 (
1063 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1066 | (LSHL (ITFixed IT16)) <- op
1067 , (lhs:rhs:_) <- args =
1068 jsPackUBits16 (
1069 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1072 | (LSHL (ITFixed IT32)) <- op
1073 , (lhs:rhs:_) <- args =
1074 jsPackUBits32 (
1075 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1078 | (LSHL (ITFixed IT64)) <- op
1079 , (lhs:rhs:_) <- args =
1080 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
1081 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1084 | (LAnd (ITFixed IT8)) <- op
1085 , (lhs:rhs:_) <- args =
1086 jsPackUBits8 (
1087 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1090 | (LAnd (ITFixed IT16)) <- op
1091 , (lhs:rhs:_) <- args =
1092 jsPackUBits16 (
1093 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1096 | (LAnd (ITFixed IT32)) <- op
1097 , (lhs:rhs:_) <- args =
1098 jsPackUBits32 (
1099 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1102 | (LAnd (ITFixed IT64)) <- op
1103 , (lhs:rhs:_) <- args =
1104 jsMeth (translateReg lhs) "and" [translateReg rhs]
1106 | (LOr (ITFixed IT8)) <- op
1107 , (lhs:rhs:_) <- args =
1108 jsPackUBits8 (
1109 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1112 | (LOr (ITFixed IT16)) <- op
1113 , (lhs:rhs:_) <- args =
1114 jsPackUBits16 (
1115 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1118 | (LOr (ITFixed IT32)) <- op
1119 , (lhs:rhs:_) <- args =
1120 jsPackUBits32 (
1121 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1124 | (LOr (ITFixed IT64)) <- op
1125 , (lhs:rhs:_) <- args =
1126 jsMeth (translateReg lhs) "or" [translateReg rhs]
1128 | (LXOr (ITFixed IT8)) <- op
1129 , (lhs:rhs:_) <- args =
1130 jsPackUBits8 (
1131 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1134 | (LXOr (ITFixed IT16)) <- op
1135 , (lhs:rhs:_) <- args =
1136 jsPackUBits16 (
1137 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1140 | (LXOr (ITFixed IT32)) <- op
1141 , (lhs:rhs:_) <- args =
1142 jsPackUBits32 (
1143 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1146 | (LXOr (ITFixed IT64)) <- op
1147 , (lhs:rhs:_) <- args =
1148 jsMeth (translateReg lhs) "xor" [translateReg rhs]
1150 | (LPlus (ATInt (ITFixed IT8))) <- op
1151 , (lhs:rhs:_) <- args =
1152 jsPackUBits8 (
1153 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1156 | (LPlus (ATInt (ITFixed IT16))) <- op
1157 , (lhs:rhs:_) <- args =
1158 jsPackUBits16 (
1159 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1162 | (LPlus (ATInt (ITFixed IT32))) <- op
1163 , (lhs:rhs:_) <- args =
1164 jsPackUBits32 (
1165 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1168 | (LPlus (ATInt (ITFixed IT64))) <- op
1169 , (lhs:rhs:_) <- args =
1170 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
1171 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1174 | (LMinus (ATInt (ITFixed IT8))) <- op
1175 , (lhs:rhs:_) <- args =
1176 jsPackUBits8 (
1177 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1180 | (LMinus (ATInt (ITFixed IT16))) <- op
1181 , (lhs:rhs:_) <- args =
1182 jsPackUBits16 (
1183 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1186 | (LMinus (ATInt (ITFixed IT32))) <- op
1187 , (lhs:rhs:_) <- args =
1188 jsPackUBits32 (
1189 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1192 | (LMinus (ATInt (ITFixed IT64))) <- op
1193 , (lhs:rhs:_) <- args =
1194 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
1195 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1198 | (LTimes (ATInt (ITFixed IT8))) <- op
1199 , (lhs:rhs:_) <- args =
1200 jsPackUBits8 (
1201 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1204 | (LTimes (ATInt (ITFixed IT16))) <- op
1205 , (lhs:rhs:_) <- args =
1206 jsPackUBits16 (
1207 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1210 | (LTimes (ATInt (ITFixed IT32))) <- op
1211 , (lhs:rhs:_) <- args =
1212 jsPackUBits32 (
1213 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1216 | (LTimes (ATInt (ITFixed IT64))) <- op
1217 , (lhs:rhs:_) <- args =
1218 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
1219 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1222 | (LEq (ATInt (ITFixed IT8))) <- op
1223 , (lhs:rhs:_) <- args =
1224 jsPackUBits8 (
1225 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1228 | (LEq (ATInt (ITFixed IT16))) <- op
1229 , (lhs:rhs:_) <- args =
1230 jsPackUBits16 (
1231 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1234 | (LEq (ATInt (ITFixed IT32))) <- op
1235 , (lhs:rhs:_) <- args =
1236 jsPackUBits32 (
1237 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1240 | (LEq (ATInt (ITFixed IT64))) <- op
1241 , (lhs:rhs:_) <- args =
1242 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
1243 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1246 | (LLt (ITFixed IT8)) <- op
1247 , (lhs:rhs:_) <- args =
1248 jsPackUBits8 (
1249 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1252 | (LLt (ITFixed IT16)) <- op
1253 , (lhs:rhs:_) <- args =
1254 jsPackUBits16 (
1255 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1258 | (LLt (ITFixed IT32)) <- op
1259 , (lhs:rhs:_) <- args =
1260 jsPackUBits32 (
1261 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1264 | (LLt (ITFixed IT64)) <- op
1265 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1267 | (LLe (ITFixed IT8)) <- op
1268 , (lhs:rhs:_) <- args =
1269 jsPackUBits8 (
1270 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1273 | (LLe (ITFixed IT16)) <- op
1274 , (lhs:rhs:_) <- args =
1275 jsPackUBits16 (
1276 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1279 | (LLe (ITFixed IT32)) <- op
1280 , (lhs:rhs:_) <- args =
1281 jsPackUBits32 (
1282 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1285 | (LLe (ITFixed IT64)) <- op
1286 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1288 | (LGt (ITFixed IT8)) <- op
1289 , (lhs:rhs:_) <- args =
1290 jsPackUBits8 (
1291 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1294 | (LGt (ITFixed IT16)) <- op
1295 , (lhs:rhs:_) <- args =
1296 jsPackUBits16 (
1297 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1299 | (LGt (ITFixed IT32)) <- op
1300 , (lhs:rhs:_) <- args =
1301 jsPackUBits32 (
1302 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1305 | (LGt (ITFixed IT64)) <- op
1306 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1308 | (LGe (ITFixed IT8)) <- op
1309 , (lhs:rhs:_) <- args =
1310 jsPackUBits8 (
1311 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1314 | (LGe (ITFixed IT16)) <- op
1315 , (lhs:rhs:_) <- args =
1316 jsPackUBits16 (
1317 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1319 | (LGe (ITFixed IT32)) <- op
1320 , (lhs:rhs:_) <- args =
1321 jsPackUBits32 (
1322 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1325 | (LGe (ITFixed IT64)) <- op
1326 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1328 | (LUDiv (ITFixed IT8)) <- op
1329 , (lhs:rhs:_) <- args =
1330 jsPackUBits8 (
1331 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1334 | (LUDiv (ITFixed IT16)) <- op
1335 , (lhs:rhs:_) <- args =
1336 jsPackUBits16 (
1337 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1340 | (LUDiv (ITFixed IT32)) <- op
1341 , (lhs:rhs:_) <- args =
1342 jsPackUBits32 (
1343 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1346 | (LUDiv (ITFixed IT64)) <- op
1347 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1349 | (LSDiv (ATInt (ITFixed IT8))) <- op
1350 , (lhs:rhs:_) <- args =
1351 jsPackSBits8 (
1352 JSBinOp "/" (
1353 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1354 ) (
1355 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1359 | (LSDiv (ATInt (ITFixed IT16))) <- op
1360 , (lhs:rhs:_) <- args =
1361 jsPackSBits16 (
1362 JSBinOp "/" (
1363 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1364 ) (
1365 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1369 | (LSDiv (ATInt (ITFixed IT32))) <- op
1370 , (lhs:rhs:_) <- args =
1371 jsPackSBits32 (
1372 JSBinOp "/" (
1373 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1374 ) (
1375 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1379 | (LSDiv (ATInt (ITFixed IT64))) <- op
1380 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1382 | (LSRem (ATInt (ITFixed IT8))) <- op
1383 , (lhs:rhs:_) <- args =
1384 jsPackSBits8 (
1385 JSBinOp "%" (
1386 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1387 ) (
1388 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1392 | (LSRem (ATInt (ITFixed IT16))) <- op
1393 , (lhs:rhs:_) <- args =
1394 jsPackSBits16 (
1395 JSBinOp "%" (
1396 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1397 ) (
1398 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1402 | (LSRem (ATInt (ITFixed IT32))) <- op
1403 , (lhs:rhs:_) <- args =
1404 jsPackSBits32 (
1405 JSBinOp "%" (
1406 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1407 ) (
1408 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1412 | (LSRem (ATInt (ITFixed IT64))) <- op
1413 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1415 | (LCompl (ITFixed IT8)) <- op
1416 , (arg:_) <- args =
1417 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1419 | (LCompl (ITFixed IT16)) <- op
1420 , (arg:_) <- args =
1421 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1423 | (LCompl (ITFixed IT32)) <- op
1424 , (arg:_) <- args =
1425 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1427 | (LCompl (ITFixed IT64)) <- op
1428 , (arg:_) <- args =
1429 invokeMeth arg "not" []
1431 | (LPlus _) <- op
1432 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1433 | (LMinus _) <- op
1434 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1435 | (LTimes _) <- op
1436 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1437 | (LSDiv _) <- op
1438 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1439 | (LSRem _) <- op
1440 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1441 | (LEq _) <- op
1442 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1443 | (LSLt _) <- op
1444 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1445 | (LSLe _) <- op
1446 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1447 | (LSGt _) <- op
1448 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1449 | (LSGe _) <- op
1450 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1451 | (LAnd _) <- op
1452 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1453 | (LOr _) <- op
1454 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1455 | (LXOr _) <- op
1456 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1457 | (LSHL _) <- op
1458 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1459 | (LASHR _) <- op
1460 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1461 | (LCompl _) <- op
1462 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1464 | LStrConcat <- op
1465 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1466 | LStrEq <- op
1467 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1468 | LStrLt <- op
1469 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1470 | LStrLen <- op
1471 , (arg:_) <- args = JSProj (translateReg arg) "length"
1472 | (LStrInt ITNative) <- op
1473 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1474 | (LIntStr ITNative) <- op
1475 , (arg:_) <- args = jsCall "String" [translateReg arg]
1476 | (LSExt ITNative ITBig) <- op
1477 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1478 | (LTrunc ITBig ITNative) <- op
1479 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1480 | (LIntStr ITBig) <- op
1481 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1482 | (LStrInt ITBig) <- op
1483 , (arg:_) <- args = jsBigInt $ translateReg arg
1484 | LFloatStr <- op
1485 , (arg:_) <- args = jsCall "String" [translateReg arg]
1486 | LStrFloat <- op
1487 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1488 | (LIntFloat ITNative) <- op
1489 , (arg:_) <- args = translateReg arg
1490 | (LFloatInt ITNative) <- op
1491 , (arg:_) <- args = translateReg arg
1492 | (LChInt ITNative) <- op
1493 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1494 | (LIntCh ITNative) <- op
1495 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1497 | LFExp <- op
1498 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1499 | LFLog <- op
1500 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1501 | LFSin <- op
1502 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1503 | LFCos <- op
1504 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1505 | LFTan <- op
1506 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1507 | LFASin <- op
1508 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1509 | LFACos <- op
1510 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1511 | LFATan <- op
1512 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1513 | LFSqrt <- op
1514 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1515 | LFFloor <- op
1516 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1517 | LFCeil <- op
1518 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1520 | LStrCons <- op
1521 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1522 | LStrHead <- op
1523 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1524 | LStrRev <- op
1525 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1526 | LStrIndex <- op
1527 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1528 | LStrTail <- op
1529 , (arg:_) <- args =
1530 let v = translateReg arg in
1531 JSApp (JSProj v "substr") [
1532 JSNum (JSInt 1),
1533 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1536 | LSystemInfo <- op
1537 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1538 | LNullPtr <- op
1539 , (_) <- args = JSNull
1540 | otherwise = JSError $ "Not implemented: " ++ show op
1541 where
1542 translateBinaryOp :: String -> Reg -> Reg -> JS
1543 translateBinaryOp op lhs rhs =
1544 JSBinOp op (translateReg lhs) (translateReg rhs)
1546 invokeMeth :: Reg -> String -> [Reg] -> JS
1547 invokeMeth obj meth args =
1548 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1551jsRESERVE :: CompileInfo -> Int -> JS
1552jsRESERVE _ _ = JSNoop
1554jsSTACK :: JS
1555jsSTACK = JSIdent "i$valstack"
1557jsCALLSTACK :: JS
1558jsCALLSTACK = JSIdent "i$callstack"
1560jsSTACKBASE :: JS
1561jsSTACKBASE = JSIdent "i$valstack_base"
1563jsSTACKTOP :: JS
1564jsSTACKTOP = JSIdent "i$valstack_top"
1566jsOLDBASE :: JS
1567jsOLDBASE = JSIdent "oldbase"
1569jsMYOLDBASE :: JS
1570jsMYOLDBASE = JSIdent "myoldbase"
1572jsRET :: JS
1573jsRET = JSIdent "i$ret"
1575jsLOC :: Int -> JS
1576jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1577jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1579jsTOP :: Int -> JS
1580jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1581jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1583jsPUSH :: [JS] -> JS
1584jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1586jsPOP :: JS
1587jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1589translateBC :: CompileInfo -> BC -> JS
1590translateBC info bc
1591 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1592 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1593 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1594 | ADDTOP n <- bc = jsADDTOP info n
1595 | NULL r <- bc = jsNULL info r
1596 | CALL n <- bc = jsCALL info n
1597 | TAILCALL n <- bc = jsTAILCALL info n
1598 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1599 | TOPBASE n <- bc = jsTOPBASE info n
1600 | BASETOP n <- bc = jsBASETOP info n
1601 | STOREOLD <- bc = jsSTOREOLD info
1602 | SLIDE n <- bc = jsSLIDE info n
1603 | REBASE <- bc = jsREBASE info
1604 | RESERVE n <- bc = jsRESERVE info n
1605 | MKCON r t rs <- bc = jsMKCON info r t rs
1606 | CASE s r c d <- bc = jsCASE info s r c d
1607 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1608 | PROJECT r l a <- bc = jsPROJECT info r l a
1609 | OP r o a <- bc = jsOP info r o a
1610 | ERROR e <- bc = jsERROR info e
1611 | otherwise = JSRaw $ "//" ++ show bc