git.iko.soy/Idris-dev
on 6fd4a4e help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1538 lines 53 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 Data.Char
18import Numeric
19import Data.List
20import Data.Maybe
21import Data.Word
22import Data.Traversable hiding (mapM)
23import System.IO
24import System.Directory
27data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
28 , compileInfoEvalCases :: [Int]
29 , compileInfoNeedsBigInt :: Bool
30 }
33initCompileInfo :: [(Name, [BC])] -> CompileInfo
34initCompileInfo bc =
35 CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc) (lookupBigInt bc)
36 where
37 lookupBigInt :: [(Name, [BC])] -> Bool
38 lookupBigInt = any (needsBigInt . snd)
39 where
40 needsBigInt :: [BC] -> Bool
41 needsBigInt bc = or $ map testBCForBigInt bc
42 where
43 testBCForBigInt :: BC -> Bool
44 testBCForBigInt (ASSIGNCONST _ c) =
45 testConstForBigInt c
47 testBCForBigInt (CONSTCASE _ c d) =
48 maybe False needsBigInt d
49 || (or $ map (needsBigInt . snd) c)
50 || (or $ map (testConstForBigInt . fst) c)
52 testBCForBigInt _ = False
54 testConstForBigInt :: Const -> Bool
55 testConstForBigInt (BI _) = True
56 testConstForBigInt (B64 _) = True
57 testConstForBigInt _ = False
60 collectCases :: String -> [(Name, [BC])] -> [Int]
61 collectCases fun bc = getCases $ findFunction fun bc
63 findFunction :: String -> [(Name, [BC])] -> [BC]
64 findFunction f ((MN 0 fun, bc):_)
65 | fun == txt f = bc
66 findFunction f (_:bc) = findFunction f bc
68 getCases :: [BC] -> [Int]
69 getCases = concatMap analyze
70 where
71 analyze :: BC -> [Int]
72 analyze (CASE _ _ b _) = map fst b
73 analyze _ = []
76data JSTarget = Node | JavaScript deriving Eq
79data JSType = JSIntTy
80 | JSStringTy
81 | JSIntegerTy
82 | JSFloatTy
83 | JSCharTy
84 | JSPtrTy
85 | JSForgotTy
86 deriving Eq
89data JSInteger = JSBigZero
90 | JSBigOne
91 | JSBigInt Integer
92 | JSBigIntExpr JS
93 deriving Eq
96data JSNum = JSInt Int
97 | JSFloat Double
98 | JSInteger JSInteger
99 deriving Eq
102data JSWord = JSWord8 Word8
103 | JSWord16 Word16
104 | JSWord32 Word32
105 | JSWord64 Word64
106 deriving Eq
109data JSAnnotation = JSConstructor deriving Eq
112instance Show JSAnnotation where
113 show JSConstructor = "constructor"
116data JS = JSRaw String
117 | JSIdent String
118 | JSFunction [String] JS
119 | JSType JSType
120 | JSSeq [JS]
121 | JSReturn JS
122 | JSApp JS [JS]
123 | JSNew String [JS]
124 | JSError String
125 | JSBinOp String JS JS
126 | JSPreOp String JS
127 | JSPostOp String JS
128 | JSProj JS String
129 | JSNull
130 | JSUndefined
131 | JSThis
132 | JSTrue
133 | JSFalse
134 | JSArray [JS]
135 | JSString String
136 | JSNum JSNum
137 | JSWord JSWord
138 | JSAssign JS JS
139 | JSAlloc String (Maybe JS)
140 | JSIndex JS JS
141 | JSSwitch JS [(JS, JS)] (Maybe JS)
142 | JSCond [(JS, JS)]
143 | JSTernary JS JS JS
144 | JSParens JS
145 | JSWhile JS JS
146 | JSFFI String [JS]
147 | JSAnnotation JSAnnotation JS
148 | JSNoop
149 deriving Eq
152data FFI = FFICode Char | FFIArg Int | FFIError String
154ffi :: String -> [String] -> String
155ffi code args = let parsed = ffiParse code in
156 case ffiError parsed of
157 Just err -> error err
158 Nothing -> renderFFI parsed args
159 where
160 ffiParse :: String -> [FFI]
161 ffiParse "" = []
162 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
163 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
164 ffiParse ('%':s:ss)
165 | isDigit s =
166 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
167 | otherwise =
168 [FFIError "FFI - Invalid positional argument"]
169 ffiParse (s:ss) = FFICode s : ffiParse ss
172 ffiError :: [FFI] -> Maybe String
173 ffiError [] = Nothing
174 ffiError ((FFIError s):xs) = Just s
175 ffiError (x:xs) = ffiError xs
178 renderFFI :: [FFI] -> [String] -> String
179 renderFFI [] _ = ""
180 renderFFI (FFICode c : fs) args = c : renderFFI fs args
181 renderFFI (FFIArg i : fs) args
182 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
183 | otherwise = error "FFI - Argument index out of bounds"
185compileJS :: JS -> String
186compileJS = compileJS' 0
188compileJS' :: Int -> JS -> String
189compileJS' indent JSNoop = ""
191compileJS' indent (JSAnnotation annotation js) =
192 "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
194compileJS' indent (JSFFI raw args) =
195 ffi raw (map (compileJS' indent) args)
197compileJS' indent (JSRaw code) =
198 code
200compileJS' indent (JSIdent ident) =
201 ident
203compileJS' indent (JSFunction args body) =
204 replicate indent ' ' ++ "function("
205 ++ intercalate "," args
206 ++ "){\n"
207 ++ compileJS' (indent + 2) body
208 ++ "\n}\n"
210compileJS' indent (JSType ty)
211 | JSIntTy <- ty = "i$Int"
212 | JSStringTy <- ty = "i$String"
213 | JSIntegerTy <- ty = "i$Integer"
214 | JSFloatTy <- ty = "i$Float"
215 | JSCharTy <- ty = "i$Char"
216 | JSPtrTy <- ty = "i$Ptr"
217 | JSForgotTy <- ty = "i$Forgot"
219compileJS' indent (JSSeq seq) =
220 intercalate ";\n" (
221 map (
222 (replicate indent ' ' ++) . (compileJS' indent)
223 ) $ filter (/= JSNoop) seq
224 ) ++ ";"
226compileJS' indent (JSReturn val) =
227 "return " ++ compileJS' indent val
229compileJS' indent (JSApp lhs rhs)
230 | JSFunction {} <- lhs =
231 concat ["(", compileJS' indent lhs, ")(", args, ")"]
232 | otherwise =
233 concat [compileJS' indent lhs, "(", args, ")"]
234 where args :: String
235 args = intercalate "," $ map (compileJS' 0) rhs
237compileJS' indent (JSNew name args) =
238 "new " ++ name ++ "(" ++ intercalate "," (map (compileJS' 0) args) ++ ")"
240compileJS' indent (JSError exc) =
241 "throw new Error(\"" ++ exc ++ "\")"
243compileJS' indent (JSBinOp op lhs rhs) =
244 compileJS' indent lhs ++ " " ++ op ++ " " ++ compileJS' indent rhs
246compileJS' indent (JSPreOp op val) =
247 op ++ compileJS' indent val
249compileJS' indent (JSProj obj field)
250 | JSFunction {} <- obj =
251 concat ["(", compileJS' indent obj, ").", field]
252 | JSAssign {} <- obj =
253 concat ["(", compileJS' indent obj, ").", field]
254 | otherwise =
255 compileJS' indent obj ++ '.' : field
257compileJS' indent JSNull =
258 "null"
260compileJS' indent JSUndefined =
261 "undefined"
263compileJS' indent JSThis =
264 "this"
266compileJS' indent JSTrue =
267 "true"
269compileJS' indent JSFalse =
270 "false"
272compileJS' indent (JSArray elems) =
273 "[" ++ intercalate "," (map (compileJS' 0) elems) ++ "]"
275compileJS' indent (JSString str) =
276 "\"" ++ str ++ "\""
278compileJS' indent (JSNum num)
279 | JSInt i <- num = show i
280 | JSFloat f <- num = show f
281 | JSInteger JSBigZero <- num = "i$ZERO"
282 | JSInteger JSBigOne <- num = "i$ONE"
283 | JSInteger (JSBigInt i) <- num = show i
284 | JSInteger (JSBigIntExpr e) <- num = "i$bigInt(" ++ compileJS' indent e ++ ")"
286compileJS' indent (JSAssign lhs rhs) =
287 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
289compileJS' indent (JSAlloc name val) =
290 "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val
292compileJS' indent (JSIndex lhs rhs) =
293 compileJS' indent lhs ++ "[" ++ compileJS' indent rhs ++ "]"
295compileJS' indent (JSCond branches) =
296 intercalate " else " $ map createIfBlock branches
297 where
298 createIfBlock (JSNoop, e@(JSSeq _)) =
299 "{\n"
300 ++ compileJS' (indent + 2) e
301 ++ "\n" ++ replicate indent ' ' ++ "}"
302 createIfBlock (JSNoop, e) =
303 "{\n"
304 ++ compileJS' (indent + 2) e
305 ++ ";\n" ++ replicate indent ' ' ++ "}"
306 createIfBlock (cond, e@(JSSeq _)) =
307 "if (" ++ compileJS' indent cond ++") {\n"
308 ++ compileJS' (indent + 2) e
309 ++ "\n" ++ replicate indent ' ' ++ "}"
310 createIfBlock (cond, e) =
311 "if (" ++ compileJS' indent cond ++") {\n"
312 ++ replicate (indent + 2) ' ' ++ compileJS' (indent + 2) e
313 ++ ";\n" ++ replicate indent ' ' ++ "}"
315compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
316 let (h,t) = splitAt 1 seq in
317 (concatMap (compileJS' indent) h ++ ";\n")
318 ++ (intercalate ";\n" $ map ((replicate indent ' ' ++) . compileJS' indent) t)
320compileJS' indent (JSSwitch val branches def) =
321 "switch(" ++ compileJS' indent val ++ "){\n"
322 ++ concatMap mkBranch branches
323 ++ mkDefault def
324 ++ replicate indent ' ' ++ "}"
325 where
326 mkBranch :: (JS, JS) -> String
327 mkBranch (tag, code) =
328 replicate (indent + 2) ' ' ++ "case " ++ compileJS' indent tag ++ ":\n"
329 ++ compileJS' (indent + 4) code
330 ++ "\n" ++ (replicate (indent + 4) ' ' ++ "break;\n")
332 mkDefault :: Maybe JS -> String
333 mkDefault Nothing = ""
334 mkDefault (Just def) =
335 replicate (indent + 2) ' ' ++ "default:\n"
336 ++ compileJS' (indent + 4)def
337 ++ "\n"
340compileJS' indent (JSTernary cond true false) =
341 let c = compileJS' indent cond
342 t = compileJS' indent true
343 f = compileJS' indent false in
344 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
346compileJS' indent (JSParens js) =
347 "(" ++ compileJS' indent js ++ ")"
349compileJS' indent (JSWhile cond body) =
350 "while (" ++ compileJS' indent cond ++ ") {\n"
351 ++ compileJS' (indent + 2) body
352 ++ "\n" ++ replicate indent ' ' ++ "}"
354compileJS' indent (JSWord word)
355 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
356 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
357 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
358 | JSWord64 b <- word = "i$bigInt(\"" ++ show b ++ "\")"
360codegenJavaScript :: CodeGenerator
361codegenJavaScript ci =
362 codegenJS_all JavaScript (simpleDecls ci)
363 (includes ci) [] (outputFile ci) (outputType ci)
365codegenNode :: CodeGenerator
366codegenNode ci =
367 codegenJS_all Node (simpleDecls ci)
368 (includes ci) (compileLibs ci) (outputFile ci) (outputType ci)
370codegenJS_all
371 :: JSTarget
372 -> [(Name, SDecl)]
373 -> [FilePath]
374 -> [String]
375 -> FilePath
376 -> OutputType
377 -> IO ()
378codegenJS_all target definitions includes libs filename outputType = do
379 let bytecode = map toBC definitions
380 let info = initCompileInfo bytecode
381 let js = concatMap (translateDecl info) bytecode
382 let code = concatMap ((map compileJS) . collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)) js
383 let (header, rt) = case target of
384 Node -> ("#!/usr/bin/env node\n", "-node")
385 JavaScript -> ("", "-browser")
387 included <- concat <$> getIncludes includes
388 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
389 idrRuntime <- readFile $ path ++ "Runtime-common.js"
390 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
391 jsbn <- if compileInfoNeedsBigInt info
392 then readFile $ path ++ "jsbn/jsbn.js"
393 else return ""
394 let runtime = ( header
395 ++ includeLibs libs
396 ++ included
397 ++ jsbn
398 ++ idrRuntime
399 ++ tgtRuntime
400 )
401 writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
402 setPermissions filename (emptyPermissions { readable = True
403 , executable = target == Node
404 , writable = True
405 })
406 where
407 includeLibs :: [String] -> String
408 includeLibs =
409 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
411 getIncludes :: [FilePath] -> IO [String]
412 getIncludes = mapM readFile
414 main :: String
415 main =
416 compileJS $ JSAlloc "main" (Just $
417 JSFunction [] (
418 case target of
419 Node -> mainFun
420 JavaScript -> jsMain
421 )
422 )
424 jsMain :: JS
425 jsMain =
426 JSCond [ (exists document `jsAnd` isReady, mainFun)
427 , (exists window, windowMainFun)
428 , (JSTrue, mainFun)
429 ]
430 where
431 exists :: JS -> JS
432 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
434 window :: JS
435 window = JSIdent "window"
437 document :: JS
438 document = JSIdent "document"
440 windowMainFun :: JS
441 windowMainFun =
442 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
443 , JSFunction [] ( mainFun )
444 , JSFalse
445 ]
447 isReady :: JS
448 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
450 readyState :: JS
451 readyState = JSProj (JSIdent "document") "readyState"
453 mainFun :: JS
454 mainFun =
455 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
456 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
457 , JSApp (
458 JSIdent (translateName (sMN 0 "runMain"))
459 ) [JSNum (JSInt 0)]
460 , JSWhile (JSProj jsCALLSTACK "length") (
461 JSSeq [ JSAlloc "func" (Just jsPOP)
462 , JSAlloc "args" (Just jsPOP)
463 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
464 ]
465 )
466 ]
468 invokeMain :: String
469 invokeMain = compileJS $ JSApp (JSIdent "main") []
471collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
472collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
473 where
474 generateSplitFunction :: (Int,JS) -> JS
475 generateSplitFunction (depth, JSAlloc name fun) =
476 JSAlloc (name ++ "$" ++ show depth) fun
478splitFunction :: JS -> RWS () [(Int,JS)] Int JS
479splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
480 body' <- splitSequence body
481 return $ JSAlloc name (Just (JSFunction args body'))
482 where
483 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
484 splitCondition js
485 | JSCond branches <- js =
486 JSCond <$> processBranches branches
487 | JSSwitch cond branches def <- js =
488 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
489 | otherwise = return js
490 where
491 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
492 processBranches =
493 traverse (runKleisli (arr id *** Kleisli splitSequence))
495 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
496 splitSequence js@(JSSeq seq) =
497 let (pre,post) = break isCall seq in
498 case post of
499 [] -> JSSeq <$> traverse splitCondition seq
500 [js@(JSCond _)] -> splitCondition js
501 [js@(JSSwitch {})] -> splitCondition js
502 [_] -> return js
503 (call:rest) -> do
504 depth <- get
505 put (depth + 1)
506 new <- splitFunction (newFun rest)
507 tell [(depth, new)]
508 return $ JSSeq (pre ++ (newCall depth : [call]))
510 splitSequence js = return js
512 isCall :: JS -> Bool
513 isCall (JSApp (JSIdent "i$CALL") _) = True
514 isCall _ = False
516 newCall :: Int -> JS
517 newCall depth =
518 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
519 , JSArray [jsOLDBASE, jsMYOLDBASE]
520 ]
522 newFun :: [JS] -> JS
523 newFun seq =
524 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
526splitFunction js = return js
528translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
529translateDecl info (name@(MN 0 fun), bc)
530 | txt "APPLY" == fun =
531 allocCaseFunctions (snd body)
532 ++ [ JSAlloc (
533 translateName name
534 ) (Just $ JSFunction ["oldbase"] (
535 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
536 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
537 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
538 )
539 , ( JSNoop
540 , JSSeq $ map (translateBC info) (defaultCase (snd body))
541 )
542 ]
543 ]
544 )
545 )
546 ]
548 | txt "EVAL" == fun =
549 allocCaseFunctions (snd body)
550 ++ [ JSAlloc (
551 translateName name
552 ) (Just $ JSFunction ["oldbase"] (
553 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
554 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
555 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
556 )
557 , ( JSNoop
558 , JSSeq $ map (translateBC info) (defaultCase (snd body))
559 )
560 ]
561 ]
562 )
563 )
564 ]
565 where
566 body :: ([BC], [BC])
567 body = break isCase bc
569 isCase :: BC -> Bool
570 isCase bc
571 | CASE {} <- bc = True
572 | otherwise = False
574 defaultCase :: [BC] -> [BC]
575 defaultCase ((CASE _ _ _ (Just d)):_) = d
577 caseReg :: [BC] -> Reg
578 caseReg ((CASE _ r _ _):_) = r
580 allocCaseFunctions :: [BC] -> [JS]
581 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
582 allocCaseFunctions _ = []
584 splitBranches :: [(Int, [BC])] -> [JS]
585 splitBranches = map prepBranch
587 prepBranch :: (Int, [BC]) -> JS
588 prepBranch (tag, code) =
589 JSAlloc (
590 translateName name ++ "$" ++ show tag
591 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
592 JSSeq $ map (translateBC info) code
593 )
594 )
596translateDecl info (name, bc) =
597 [ JSAlloc (
598 translateName name
599 ) (Just $ JSFunction ["oldbase"] (
600 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
601 )
602 )
603 ]
606translateReg :: Reg -> JS
607translateReg reg
608 | RVal <- reg = jsRET
609 | Tmp <- reg = JSRaw "//TMPREG"
610 | L n <- reg = jsLOC n
611 | T n <- reg = jsTOP n
613translateConstant :: Const -> JS
614translateConstant (I i) = JSNum (JSInt i)
615translateConstant (Fl f) = JSNum (JSFloat f)
616translateConstant (Ch c) = JSString $ translateChar c
617translateConstant (Str s) = JSString $ concatMap translateChar s
618translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
619translateConstant StrType = JSType JSStringTy
620translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
621translateConstant (AType ATFloat) = JSType JSFloatTy
622translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
623translateConstant PtrType = JSType JSPtrTy
624translateConstant Forgot = JSType JSForgotTy
625translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
626translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
627translateConstant (BI i) = jsBigInt (JSString $ show i)
628translateConstant (B8 b) = JSWord (JSWord8 b)
629translateConstant (B16 b) = JSWord (JSWord16 b)
630translateConstant (B32 b) = JSWord (JSWord32 b)
631translateConstant (B64 b) = JSWord (JSWord64 b)
632translateConstant c =
633 JSError $ "Unimplemented Constant: " ++ show c
636translateChar :: Char -> String
637translateChar ch
638 | '\a' <- ch = "\\u0007"
639 | '\b' <- ch = "\\b"
640 | '\f' <- ch = "\\f"
641 | '\n' <- ch = "\\n"
642 | '\r' <- ch = "\\r"
643 | '\t' <- ch = "\\t"
644 | '\v' <- ch = "\\v"
645 | '\SO' <- ch = "\\u000E"
646 | '\DEL' <- ch = "\\u007F"
647 | '\\' <- ch = "\\\\"
648 | '\"' <- ch = "\\\""
649 | '\'' <- ch = "\\\'"
650 | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")
651 | otherwise = [ch]
652 where
653 fill :: String -> String
654 fill s = if length s == 1
655 then '0' : s
656 else s
658 asciiTab =
659 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
660 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
661 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
662 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
664translateName :: Name -> String
665translateName n = "_idris_" ++ concatMap cchar (showCG n)
666 where cchar x | isAlphaNum x = [x]
667 | otherwise = "_" ++ show (fromEnum x) ++ "_"
669jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
670jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
672jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
673jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
675jsCALL :: CompileInfo -> Name -> JS
676jsCALL _ n =
677 JSApp (
678 JSIdent "i$CALL"
679 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
681jsTAILCALL :: CompileInfo -> Name -> JS
682jsTAILCALL _ n =
683 JSApp (
684 JSIdent "i$CALL"
685 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
687jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
688jsFOREIGN _ reg n args
689 | n == "putStr"
690 , [(FString, arg)] <- args =
691 JSAssign (
692 translateReg reg
693 ) (
694 JSApp (JSIdent "i$putStr") [translateReg arg]
695 )
697 | n == "isNull"
698 , [(FPtr, arg)] <- args =
699 JSAssign (
700 translateReg reg
701 ) (
702 JSBinOp "==" (translateReg arg) JSNull
703 )
705 | n == "idris_eqPtr"
706 , [(_, lhs),(_, rhs)] <- args =
707 JSAssign (
708 translateReg reg
709 ) (
710 JSBinOp "==" (translateReg lhs) (translateReg rhs)
711 )
712 | otherwise =
713 JSAssign (
714 translateReg reg
715 ) (
716 JSFFI n (map generateWrapper args)
717 )
718 where
719 generateWrapper :: (FType, Reg) -> JS
720 generateWrapper (ty, reg)
721 | FFunction <- ty =
722 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
723 , JSIdent "oldbase"
724 , JSIdent "myoldbase"
725 ]
726 | FFunctionIO <- ty =
727 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
728 , JSIdent "oldbase"
729 , JSIdent "myoldbase"
730 ]
732 generateWrapper (_, reg) =
733 translateReg reg
735jsREBASE :: CompileInfo -> JS
736jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
738jsSTOREOLD :: CompileInfo ->JS
739jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
741jsADDTOP :: CompileInfo -> Int -> JS
742jsADDTOP info n
743 | 0 <- n = JSNoop
744 | otherwise =
745 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
747jsTOPBASE :: CompileInfo -> Int -> JS
748jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
749jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
752jsBASETOP :: CompileInfo -> Int -> JS
753jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
754jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
756jsNULL :: CompileInfo -> Reg -> JS
757jsNULL _ r = JSAssign (translateReg r) JSNull
759jsERROR :: CompileInfo -> String -> JS
760jsERROR _ = JSError
762jsSLIDE :: CompileInfo -> Int -> JS
763jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
765jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
766jsMKCON info r t rs =
767 JSAssign (translateReg r) (
768 JSNew "i$CON" [ JSNum (JSInt t)
769 , JSArray (map translateReg rs)
770 , if t `elem` compileInfoApplyCases info
771 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
772 else JSNull
773 , if t `elem` compileInfoEvalCases info
774 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
775 else JSNull
776 ]
777 )
779jsInstanceOf :: JS -> String -> JS
780jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
782jsOr :: JS -> JS -> JS
783jsOr lhs rhs = JSBinOp "||" lhs rhs
785jsAnd :: JS -> JS -> JS
786jsAnd lhs rhs = JSBinOp "&&" lhs rhs
788jsMeth :: JS -> String -> [JS] -> JS
789jsMeth obj meth args = JSApp (JSProj obj meth) args
791jsCall :: String -> [JS] -> JS
792jsCall fun args = JSApp (JSIdent fun) args
794jsTypeOf :: JS -> JS
795jsTypeOf js = JSPreOp "typeof " js
797jsEq :: JS -> JS -> JS
798jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
799jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
800jsEq lhs rhs = JSBinOp "==" lhs rhs
802jsNotEq :: JS -> JS -> JS
803jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
805jsIsNumber :: JS -> JS
806jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
808jsIsNull :: JS -> JS
809jsIsNull js = JSBinOp "==" js JSNull
811jsBigInt :: JS -> JS
812jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
813jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
814jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
816jsUnPackBits :: JS -> JS
817jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
819jsPackUBits8 :: JS -> JS
820jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
822jsPackUBits16 :: JS -> JS
823jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
825jsPackUBits32 :: JS -> JS
826jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
828jsPackSBits8 :: JS -> JS
829jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
831jsPackSBits16 :: JS -> JS
832jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
834jsPackSBits32 :: JS -> JS
835jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
837jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
838jsCASE info safe reg cases def =
839 JSSwitch (tag safe $ translateReg reg) (
840 map ((JSNum . JSInt) *** prepBranch) cases
841 ) (fmap prepBranch def)
842 where
843 tag :: Bool -> JS -> JS
844 tag True = jsCTAG
845 tag False = jsTAG
847 prepBranch :: [BC] -> JS
848 prepBranch bc = JSSeq $ map (translateBC info) bc
850 jsTAG :: JS -> JS
851 jsTAG js =
852 (JSTernary (js `jsInstanceOf` "i$CON") (
853 JSProj js "tag"
854 ) (JSNum (JSInt $ negate 1)))
856 jsCTAG :: JS -> JS
857 jsCTAG js = JSProj js "tag"
860jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
861jsCONSTCASE info reg cases def =
862 JSCond $ (
863 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
864 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
865 where
866 prepBranch :: [BC] -> JS
867 prepBranch bc = JSSeq $ map (translateBC info) bc
869jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
870jsPROJECT _ reg loc ar =
871 JSApp (JSIdent "i$PROJECT") [ translateReg reg
872 , JSNum (JSInt loc)
873 , JSNum (JSInt ar)
874 ]
876jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
877jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
878 where
879 jsOP' :: JS
880 jsOP'
881 | LNoOp <- op = translateReg (last args)
883 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
884 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
885 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
887 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
888 | (LPlus (ATInt ITBig)) <- op
889 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
890 | (LMinus (ATInt ITBig)) <- op
891 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
892 | (LTimes (ATInt ITBig)) <- op
893 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
894 | (LSDiv (ATInt ITBig)) <- op
895 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
896 | (LSRem (ATInt ITBig)) <- op
897 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
898 | (LEq (ATInt ITBig)) <- op
899 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
900 | (LSLt (ATInt ITBig)) <- op
901 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
902 | (LSLe (ATInt ITBig)) <- op
903 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
904 | (LSGt (ATInt ITBig)) <- op
905 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
906 | (LSGe (ATInt ITBig)) <- op
907 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
909 | (LPlus ATFloat) <- op
910 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
911 | (LMinus ATFloat) <- op
912 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
913 | (LTimes ATFloat) <- op
914 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
915 | (LSDiv ATFloat) <- op
916 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
917 | (LEq ATFloat) <- op
918 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
919 | (LSLt ATFloat) <- op
920 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
921 | (LSLe ATFloat) <- op
922 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
923 | (LSGt ATFloat) <- op
924 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
925 | (LSGe ATFloat) <- op
926 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
928 | (LPlus (ATInt ITChar)) <- op
929 , (lhs:rhs:_) <- args =
930 jsCall "i$fromCharCode" [
931 JSBinOp "+" (
932 jsCall "i$charCode" [translateReg lhs]
933 ) (
934 jsCall "i$charCode" [translateReg rhs]
935 )
936 ]
938 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
939 , (arg:_) <- args =
940 jsPackUBits8 (
941 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
942 )
944 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
945 , (arg:_) <- args =
946 jsPackUBits16 (
947 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
948 )
950 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
951 , (arg:_) <- args =
952 jsPackUBits32 (
953 jsMeth (jsMeth (translateReg arg) "and" [
954 jsBigInt (JSString $ show 0xFFFFFFFF)
955 ]) "intValue" []
956 )
958 | (LTrunc ITBig (ITFixed IT64)) <- op
959 , (arg:_) <- args =
960 jsMeth (translateReg arg) "and" [
961 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
962 ]
964 | (LLSHR (ITFixed IT8)) <- op
965 , (lhs:rhs:_) <- args =
966 jsPackUBits8 (
967 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
968 )
970 | (LLSHR (ITFixed IT16)) <- op
971 , (lhs:rhs:_) <- args =
972 jsPackUBits16 (
973 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
974 )
976 | (LLSHR (ITFixed IT32)) <- op
977 , (lhs:rhs:_) <- args =
978 jsPackUBits32 (
979 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
980 )
982 | (LLSHR (ITFixed IT64)) <- op
983 , (lhs:rhs:_) <- args =
984 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
986 | (LSHL (ITFixed IT8)) <- op
987 , (lhs:rhs:_) <- args =
988 jsPackUBits8 (
989 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
990 )
992 | (LSHL (ITFixed IT16)) <- op
993 , (lhs:rhs:_) <- args =
994 jsPackUBits16 (
995 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
996 )
998 | (LSHL (ITFixed IT32)) <- op
999 , (lhs:rhs:_) <- args =
1000 jsPackUBits32 (
1001 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1004 | (LSHL (ITFixed IT64)) <- op
1005 , (lhs:rhs:_) <- args =
1006 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
1007 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1010 | (LAnd (ITFixed IT8)) <- op
1011 , (lhs:rhs:_) <- args =
1012 jsPackUBits8 (
1013 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1016 | (LAnd (ITFixed IT16)) <- op
1017 , (lhs:rhs:_) <- args =
1018 jsPackUBits16 (
1019 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1022 | (LAnd (ITFixed IT32)) <- op
1023 , (lhs:rhs:_) <- args =
1024 jsPackUBits32 (
1025 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1028 | (LAnd (ITFixed IT64)) <- op
1029 , (lhs:rhs:_) <- args =
1030 jsMeth (translateReg lhs) "and" [translateReg rhs]
1032 | (LOr (ITFixed IT8)) <- op
1033 , (lhs:rhs:_) <- args =
1034 jsPackUBits8 (
1035 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1038 | (LOr (ITFixed IT16)) <- op
1039 , (lhs:rhs:_) <- args =
1040 jsPackUBits16 (
1041 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1044 | (LOr (ITFixed IT32)) <- op
1045 , (lhs:rhs:_) <- args =
1046 jsPackUBits32 (
1047 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1050 | (LOr (ITFixed IT64)) <- op
1051 , (lhs:rhs:_) <- args =
1052 jsMeth (translateReg lhs) "or" [translateReg rhs]
1054 | (LXOr (ITFixed IT8)) <- op
1055 , (lhs:rhs:_) <- args =
1056 jsPackUBits8 (
1057 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1060 | (LXOr (ITFixed IT16)) <- op
1061 , (lhs:rhs:_) <- args =
1062 jsPackUBits16 (
1063 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1066 | (LXOr (ITFixed IT32)) <- op
1067 , (lhs:rhs:_) <- args =
1068 jsPackUBits32 (
1069 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1072 | (LXOr (ITFixed IT64)) <- op
1073 , (lhs:rhs:_) <- args =
1074 jsMeth (translateReg lhs) "xor" [translateReg rhs]
1076 | (LPlus (ATInt (ITFixed IT8))) <- op
1077 , (lhs:rhs:_) <- args =
1078 jsPackUBits8 (
1079 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1082 | (LPlus (ATInt (ITFixed IT16))) <- op
1083 , (lhs:rhs:_) <- args =
1084 jsPackUBits16 (
1085 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1088 | (LPlus (ATInt (ITFixed IT32))) <- op
1089 , (lhs:rhs:_) <- args =
1090 jsPackUBits32 (
1091 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1094 | (LPlus (ATInt (ITFixed IT64))) <- op
1095 , (lhs:rhs:_) <- args =
1096 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
1097 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1100 | (LMinus (ATInt (ITFixed IT8))) <- op
1101 , (lhs:rhs:_) <- args =
1102 jsPackUBits8 (
1103 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1106 | (LMinus (ATInt (ITFixed IT16))) <- op
1107 , (lhs:rhs:_) <- args =
1108 jsPackUBits16 (
1109 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1112 | (LMinus (ATInt (ITFixed IT32))) <- op
1113 , (lhs:rhs:_) <- args =
1114 jsPackUBits32 (
1115 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1118 | (LMinus (ATInt (ITFixed IT64))) <- op
1119 , (lhs:rhs:_) <- args =
1120 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
1121 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1124 | (LTimes (ATInt (ITFixed IT8))) <- op
1125 , (lhs:rhs:_) <- args =
1126 jsPackUBits8 (
1127 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1130 | (LTimes (ATInt (ITFixed IT16))) <- op
1131 , (lhs:rhs:_) <- args =
1132 jsPackUBits16 (
1133 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1136 | (LTimes (ATInt (ITFixed IT32))) <- op
1137 , (lhs:rhs:_) <- args =
1138 jsPackUBits32 (
1139 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1142 | (LTimes (ATInt (ITFixed IT64))) <- op
1143 , (lhs:rhs:_) <- args =
1144 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
1145 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1148 | (LEq (ATInt (ITFixed IT8))) <- op
1149 , (lhs:rhs:_) <- args =
1150 jsPackUBits8 (
1151 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1154 | (LEq (ATInt (ITFixed IT16))) <- op
1155 , (lhs:rhs:_) <- args =
1156 jsPackUBits16 (
1157 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1160 | (LEq (ATInt (ITFixed IT32))) <- op
1161 , (lhs:rhs:_) <- args =
1162 jsPackUBits32 (
1163 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1166 | (LEq (ATInt (ITFixed IT64))) <- op
1167 , (lhs:rhs:_) <- args =
1168 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
1169 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1172 | (LLt (ITFixed IT8)) <- op
1173 , (lhs:rhs:_) <- args =
1174 jsPackUBits8 (
1175 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1178 | (LLt (ITFixed IT16)) <- op
1179 , (lhs:rhs:_) <- args =
1180 jsPackUBits16 (
1181 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1184 | (LLt (ITFixed IT32)) <- op
1185 , (lhs:rhs:_) <- args =
1186 jsPackUBits32 (
1187 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1190 | (LLt (ITFixed IT64)) <- op
1191 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1193 | (LLe (ITFixed IT8)) <- op
1194 , (lhs:rhs:_) <- args =
1195 jsPackUBits8 (
1196 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1199 | (LLe (ITFixed IT16)) <- op
1200 , (lhs:rhs:_) <- args =
1201 jsPackUBits16 (
1202 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1205 | (LLe (ITFixed IT32)) <- op
1206 , (lhs:rhs:_) <- args =
1207 jsPackUBits32 (
1208 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1211 | (LLe (ITFixed IT64)) <- op
1212 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1214 | (LGt (ITFixed IT8)) <- op
1215 , (lhs:rhs:_) <- args =
1216 jsPackUBits8 (
1217 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1220 | (LGt (ITFixed IT16)) <- op
1221 , (lhs:rhs:_) <- args =
1222 jsPackUBits16 (
1223 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1225 | (LGt (ITFixed IT32)) <- op
1226 , (lhs:rhs:_) <- args =
1227 jsPackUBits32 (
1228 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1231 | (LGt (ITFixed IT64)) <- op
1232 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1234 | (LGe (ITFixed IT8)) <- op
1235 , (lhs:rhs:_) <- args =
1236 jsPackUBits8 (
1237 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1240 | (LGe (ITFixed IT16)) <- op
1241 , (lhs:rhs:_) <- args =
1242 jsPackUBits16 (
1243 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1245 | (LGe (ITFixed IT32)) <- op
1246 , (lhs:rhs:_) <- args =
1247 jsPackUBits32 (
1248 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1251 | (LGe (ITFixed IT64)) <- op
1252 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1254 | (LUDiv (ITFixed IT8)) <- op
1255 , (lhs:rhs:_) <- args =
1256 jsPackUBits8 (
1257 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1260 | (LUDiv (ITFixed IT16)) <- op
1261 , (lhs:rhs:_) <- args =
1262 jsPackUBits16 (
1263 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1266 | (LUDiv (ITFixed IT32)) <- op
1267 , (lhs:rhs:_) <- args =
1268 jsPackUBits32 (
1269 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1272 | (LUDiv (ITFixed IT64)) <- op
1273 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1275 | (LSDiv (ATInt (ITFixed IT8))) <- op
1276 , (lhs:rhs:_) <- args =
1277 jsPackSBits8 (
1278 JSBinOp "/" (
1279 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1280 ) (
1281 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1285 | (LSDiv (ATInt (ITFixed IT16))) <- op
1286 , (lhs:rhs:_) <- args =
1287 jsPackSBits16 (
1288 JSBinOp "/" (
1289 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1290 ) (
1291 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1295 | (LSDiv (ATInt (ITFixed IT32))) <- op
1296 , (lhs:rhs:_) <- args =
1297 jsPackSBits32 (
1298 JSBinOp "/" (
1299 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1300 ) (
1301 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1305 | (LSDiv (ATInt (ITFixed IT64))) <- op
1306 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1308 | (LSRem (ATInt (ITFixed IT8))) <- op
1309 , (lhs:rhs:_) <- args =
1310 jsPackSBits8 (
1311 JSBinOp "%" (
1312 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1313 ) (
1314 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1318 | (LSRem (ATInt (ITFixed IT16))) <- op
1319 , (lhs:rhs:_) <- args =
1320 jsPackSBits16 (
1321 JSBinOp "%" (
1322 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1323 ) (
1324 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1328 | (LSRem (ATInt (ITFixed IT32))) <- op
1329 , (lhs:rhs:_) <- args =
1330 jsPackSBits32 (
1331 JSBinOp "%" (
1332 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1333 ) (
1334 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1338 | (LSRem (ATInt (ITFixed IT64))) <- op
1339 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1341 | (LCompl (ITFixed IT8)) <- op
1342 , (arg:_) <- args =
1343 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1345 | (LCompl (ITFixed IT16)) <- op
1346 , (arg:_) <- args =
1347 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1349 | (LCompl (ITFixed IT32)) <- op
1350 , (arg:_) <- args =
1351 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1353 | (LCompl (ITFixed IT64)) <- op
1354 , (arg:_) <- args =
1355 invokeMeth arg "not" []
1357 | (LPlus _) <- op
1358 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1359 | (LMinus _) <- op
1360 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1361 | (LTimes _) <- op
1362 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1363 | (LSDiv _) <- op
1364 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1365 | (LSRem _) <- op
1366 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1367 | (LEq _) <- op
1368 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1369 | (LSLt _) <- op
1370 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1371 | (LSLe _) <- op
1372 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1373 | (LSGt _) <- op
1374 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1375 | (LSGe _) <- op
1376 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1377 | (LAnd _) <- op
1378 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1379 | (LOr _) <- op
1380 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1381 | (LXOr _) <- op
1382 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1383 | (LSHL _) <- op
1384 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1385 | (LASHR _) <- op
1386 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1387 | (LCompl _) <- op
1388 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1390 | LStrConcat <- op
1391 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1392 | LStrEq <- op
1393 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1394 | LStrLt <- op
1395 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1396 | LStrLen <- op
1397 , (arg:_) <- args = JSProj (translateReg arg) "length"
1398 | (LStrInt ITNative) <- op
1399 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1400 | (LIntStr ITNative) <- op
1401 , (arg:_) <- args = jsCall "String" [translateReg arg]
1402 | (LSExt ITNative ITBig) <- op
1403 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1404 | (LTrunc ITBig ITNative) <- op
1405 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1406 | (LIntStr ITBig) <- op
1407 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1408 | (LStrInt ITBig) <- op
1409 , (arg:_) <- args = jsBigInt $ translateReg arg
1410 | LFloatStr <- op
1411 , (arg:_) <- args = jsCall "String" [translateReg arg]
1412 | LStrFloat <- op
1413 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1414 | (LIntFloat ITNative) <- op
1415 , (arg:_) <- args = translateReg arg
1416 | (LFloatInt ITNative) <- op
1417 , (arg:_) <- args = translateReg arg
1418 | (LChInt ITNative) <- op
1419 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1420 | (LIntCh ITNative) <- op
1421 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1423 | LFExp <- op
1424 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1425 | LFLog <- op
1426 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1427 | LFSin <- op
1428 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1429 | LFCos <- op
1430 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1431 | LFTan <- op
1432 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1433 | LFASin <- op
1434 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1435 | LFACos <- op
1436 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1437 | LFATan <- op
1438 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1439 | LFSqrt <- op
1440 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1441 | LFFloor <- op
1442 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1443 | LFCeil <- op
1444 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1446 | LStrCons <- op
1447 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1448 | LStrHead <- op
1449 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1450 | LStrRev <- op
1451 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1452 | LStrIndex <- op
1453 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1454 | LStrTail <- op
1455 , (arg:_) <- args =
1456 let v = translateReg arg in
1457 JSApp (JSProj v "substr") [
1458 JSNum (JSInt 1),
1459 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1462 | LSystemInfo <- op
1463 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1464 | LNullPtr <- op
1465 , (_) <- args = JSNull
1466 | otherwise = JSError $ "Not implemented: " ++ show op
1467 where
1468 translateBinaryOp :: String -> Reg -> Reg -> JS
1469 translateBinaryOp op lhs rhs =
1470 JSBinOp op (translateReg lhs) (translateReg rhs)
1472 invokeMeth :: Reg -> String -> [Reg] -> JS
1473 invokeMeth obj meth args =
1474 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1477jsRESERVE :: CompileInfo -> Int -> JS
1478jsRESERVE _ _ = JSNoop
1480jsSTACK :: JS
1481jsSTACK = JSIdent "i$valstack"
1483jsCALLSTACK :: JS
1484jsCALLSTACK = JSIdent "i$callstack"
1486jsSTACKBASE :: JS
1487jsSTACKBASE = JSIdent "i$valstack_base"
1489jsSTACKTOP :: JS
1490jsSTACKTOP = JSIdent "i$valstack_top"
1492jsOLDBASE :: JS
1493jsOLDBASE = JSIdent "oldbase"
1495jsMYOLDBASE :: JS
1496jsMYOLDBASE = JSIdent "myoldbase"
1498jsRET :: JS
1499jsRET = JSIdent "i$ret"
1501jsLOC :: Int -> JS
1502jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1503jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1505jsTOP :: Int -> JS
1506jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1507jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1509jsPUSH :: [JS] -> JS
1510jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1512jsPOP :: JS
1513jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1515translateBC :: CompileInfo -> BC -> JS
1516translateBC info bc
1517 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1518 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1519 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1520 | ADDTOP n <- bc = jsADDTOP info n
1521 | NULL r <- bc = jsNULL info r
1522 | CALL n <- bc = jsCALL info n
1523 | TAILCALL n <- bc = jsTAILCALL info n
1524 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1525 | TOPBASE n <- bc = jsTOPBASE info n
1526 | BASETOP n <- bc = jsBASETOP info n
1527 | STOREOLD <- bc = jsSTOREOLD info
1528 | SLIDE n <- bc = jsSLIDE info n
1529 | REBASE <- bc = jsREBASE info
1530 | RESERVE n <- bc = jsRESERVE info n
1531 | MKCON r t rs <- bc = jsMKCON info r t rs
1532 | CASE s r c d <- bc = jsCASE info s r c d
1533 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1534 | PROJECT r l a <- bc = jsPROJECT info r l a
1535 | OP r o a <- bc = jsOP info r o a
1536 | ERROR e <- bc = jsERROR info e
1537 | otherwise = JSRaw $ "//" ++ show bc