git.iko.soy/Idris-dev
on 2d41378 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1661 lines 57 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 full = concatMap processFunction js
389 let code = deadCodeElim full
390 let (cons, opt) = optimizeConstructors code
391 let (header, rt) = case target of
392 Node -> ("#!/usr/bin/env node\n", "-node")
393 JavaScript -> ("", "-browser")
395 included <- concat <$> getIncludes includes
396 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
397 idrRuntime <- readFile $ path ++ "Runtime-common.js"
398 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
399 jsbn <- if compileInfoNeedsBigInt info
400 then readFile $ path ++ "jsbn/jsbn.js"
401 else return ""
402 let runtime = ( header
403 ++ includeLibs libs
404 ++ included
405 ++ jsbn
406 ++ idrRuntime
407 ++ tgtRuntime
408 )
409 writeFile filename ( runtime
410 ++ concatMap compileJS opt
411 ++ concatMap compileJS cons
412 ++ main
413 ++ invokeMain
414 )
415 setPermissions filename (emptyPermissions { readable = True
416 , executable = target == Node
417 , writable = True
418 })
419 where
420 deadCodeElim :: [JS] -> [JS]
421 deadCodeElim js = concatMap collectFunctions js
422 where
423 collectFunctions :: JS -> [JS]
424 collectFunctions fun@(JSAlloc name _)
425 | name == translateName (sMN 0 "runMain") = [fun]
427 collectFunctions fun@(JSAlloc name (Just (JSFunction _ body))) =
428 let invokations = sum $ map (
429 \x -> execState (countInvokations name x) 0
430 ) js
431 in if invokations == 0
432 then []
433 else [fun]
435 countInvokations :: String -> JS -> State Int ()
436 countInvokations name (JSAlloc _ (Just (JSFunction _ body))) =
437 countInvokations name body
439 countInvokations name (JSSeq seq) =
440 void $ traverse (countInvokations name) seq
442 countInvokations name (JSAssign _ rhs) =
443 countInvokations name rhs
445 countInvokations name (JSCond conds) =
446 void $ traverse (
447 runKleisli $ arr id *** Kleisli (countInvokations name)
448 ) conds
450 countInvokations name (JSSwitch _ conds def) =
451 void $ traverse (
452 runKleisli $ arr id *** Kleisli (countInvokations name)
453 ) conds >> traverse (countInvokations name) def
455 countInvokations name (JSApp lhs rhs) =
456 void $ countInvokations name lhs >> traverse (countInvokations name) rhs
458 countInvokations name (JSNew _ args) =
459 void $ traverse (countInvokations name) args
461 countInvokations name (JSArray args) =
462 void $ traverse (countInvokations name) args
464 countInvokations name (JSIdent name')
465 | name == name' = get >>= put . (+1)
466 | otherwise = return ()
468 countInvokations _ _ = return ()
470 processFunction :: JS -> [JS]
471 processFunction =
472 collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)
474 includeLibs :: [String] -> String
475 includeLibs =
476 concatMap (\lib -> "var " ++ lib ++ " = require(\"" ++ lib ++"\");\n")
478 getIncludes :: [FilePath] -> IO [String]
479 getIncludes = mapM readFile
481 main :: String
482 main =
483 compileJS $ JSAlloc "main" (Just $
484 JSFunction [] (
485 case target of
486 Node -> mainFun
487 JavaScript -> jsMain
488 )
489 )
491 jsMain :: JS
492 jsMain =
493 JSCond [ (exists document `jsAnd` isReady, mainFun)
494 , (exists window, windowMainFun)
495 , (JSTrue, mainFun)
496 ]
497 where
498 exists :: JS -> JS
499 exists js = jsTypeOf js `jsNotEq` JSString "undefined"
501 window :: JS
502 window = JSIdent "window"
504 document :: JS
505 document = JSIdent "document"
507 windowMainFun :: JS
508 windowMainFun =
509 jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
510 , JSFunction [] ( mainFun )
511 , JSFalse
512 ]
514 isReady :: JS
515 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
517 readyState :: JS
518 readyState = JSProj (JSIdent "document") "readyState"
520 mainFun :: JS
521 mainFun =
522 JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
523 , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
524 , JSApp (
525 JSIdent (translateName (sMN 0 "runMain"))
526 ) [JSNum (JSInt 0)]
527 , JSWhile (JSProj jsCALLSTACK "length") (
528 JSSeq [ JSAlloc "func" (Just jsPOP)
529 , JSAlloc "args" (Just jsPOP)
530 , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
531 ]
532 )
533 ]
535 invokeMain :: String
536 invokeMain = compileJS $ JSApp (JSIdent "main") []
538optimizeConstructors :: [JS] -> ([JS], [JS])
539optimizeConstructors js =
540 let (js', cons) = runState (traverse optimizeConstructor' js) M.empty in
541 (map (allocCon . snd) (M.toList cons), js')
542 where
543 allocCon :: (String, JS) -> JS
544 allocCon (name, con) = JSAlloc name (Just con)
546 newConstructor :: Int -> String
547 newConstructor n = "i$CON$" ++ show n
549 optimizeConstructor' :: JS -> State (M.Map Int (String, JS)) JS
550 optimizeConstructor' js@(JSNew "i$CON" [ JSNum (JSInt tag)
551 , JSArray []
552 , a
553 , e
554 ]) = do
555 s <- get
556 case M.lookup tag s of
557 Just (i, c) -> return $ JSIdent i
558 Nothing -> do let n = newConstructor tag
559 put $ M.insert tag (n, js) s
560 return $ JSIdent n
562 optimizeConstructor' (JSSeq seq) =
563 JSSeq <$> traverse optimizeConstructor' seq
565 optimizeConstructor' (JSSwitch reg cond def) = do
566 cond' <- traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
567 def' <- traverse optimizeConstructor' def
568 return $ JSSwitch reg cond' def'
570 optimizeConstructor' (JSCond cond) =
571 JSCond <$> traverse (runKleisli $ arr id *** Kleisli optimizeConstructor') cond
573 optimizeConstructor' (JSAlloc fun (Just (JSFunction args body))) = do
574 body' <- optimizeConstructor' body
575 return $ JSAlloc fun (Just (JSFunction args body'))
577 optimizeConstructor' (JSAssign lhs rhs) = do
578 lhs' <- optimizeConstructor' lhs
579 rhs' <- optimizeConstructor' rhs
580 return $ JSAssign lhs' rhs'
582 optimizeConstructor' js = return js
584collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
585collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
586 where
587 generateSplitFunction :: (Int,JS) -> JS
588 generateSplitFunction (depth, JSAlloc name fun) =
589 JSAlloc (name ++ "$" ++ show depth) fun
591splitFunction :: JS -> RWS () [(Int,JS)] Int JS
592splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
593 body' <- splitSequence body
594 return $ JSAlloc name (Just (JSFunction args body'))
595 where
596 splitCondition :: JS -> RWS () [(Int,JS)] Int JS
597 splitCondition js
598 | JSCond branches <- js =
599 JSCond <$> processBranches branches
600 | JSSwitch cond branches def <- js =
601 JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
602 | otherwise = return js
603 where
604 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
605 processBranches =
606 traverse (runKleisli (arr id *** Kleisli splitSequence))
608 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
609 splitSequence js@(JSSeq seq) =
610 let (pre,post) = break isCall seq in
611 case post of
612 [] -> JSSeq <$> traverse splitCondition seq
613 [js@(JSCond _)] -> splitCondition js
614 [js@(JSSwitch {})] -> splitCondition js
615 [_] -> return js
616 (call:rest) -> do
617 depth <- get
618 put (depth + 1)
619 new <- splitFunction (newFun rest)
620 tell [(depth, new)]
621 return $ JSSeq (pre ++ (newCall depth : [call]))
623 splitSequence js = return js
625 isCall :: JS -> Bool
626 isCall (JSApp (JSIdent "i$CALL") _) = True
627 isCall _ = False
629 newCall :: Int -> JS
630 newCall depth =
631 JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
632 , JSArray [jsOLDBASE, jsMYOLDBASE]
633 ]
635 newFun :: [JS] -> JS
636 newFun seq =
637 JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
639splitFunction js = return js
641translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
642translateDecl info (name@(MN 0 fun), bc)
643 | txt "APPLY" == fun =
644 allocCaseFunctions (snd body)
645 ++ [ JSAlloc (
646 translateName name
647 ) (Just $ JSFunction ["oldbase"] (
648 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
649 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
650 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
651 )
652 , ( JSNoop
653 , JSSeq $ map (translateBC info) (defaultCase (snd body))
654 )
655 ]
656 ]
657 )
658 )
659 ]
661 | txt "EVAL" == fun =
662 allocCaseFunctions (snd body)
663 ++ [ JSAlloc (
664 translateName name
665 ) (Just $ JSFunction ["oldbase"] (
666 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
667 JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
668 , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
669 )
670 , ( JSNoop
671 , JSSeq $ map (translateBC info) (defaultCase (snd body))
672 )
673 ]
674 ]
675 )
676 )
677 ]
678 where
679 body :: ([BC], [BC])
680 body = break isCase bc
682 isCase :: BC -> Bool
683 isCase bc
684 | CASE {} <- bc = True
685 | otherwise = False
687 defaultCase :: [BC] -> [BC]
688 defaultCase ((CASE _ _ _ (Just d)):_) = d
690 caseReg :: [BC] -> Reg
691 caseReg ((CASE _ r _ _):_) = r
693 allocCaseFunctions :: [BC] -> [JS]
694 allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
695 allocCaseFunctions _ = []
697 splitBranches :: [(Int, [BC])] -> [JS]
698 splitBranches = map prepBranch
700 prepBranch :: (Int, [BC]) -> JS
701 prepBranch (tag, code) =
702 JSAlloc (
703 translateName name ++ "$" ++ show tag
704 ) (Just $ JSFunction ["oldbase", "myoldbase"] (
705 JSSeq $ map (translateBC info) code
706 )
707 )
709translateDecl info (name, bc) =
710 [ JSAlloc (
711 translateName name
712 ) (Just $ JSFunction ["oldbase"] (
713 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
714 )
715 )
716 ]
719translateReg :: Reg -> JS
720translateReg reg
721 | RVal <- reg = jsRET
722 | Tmp <- reg = JSRaw "//TMPREG"
723 | L n <- reg = jsLOC n
724 | T n <- reg = jsTOP n
726translateConstant :: Const -> JS
727translateConstant (I i) = JSNum (JSInt i)
728translateConstant (Fl f) = JSNum (JSFloat f)
729translateConstant (Ch c) = JSString $ translateChar c
730translateConstant (Str s) = JSString $ concatMap translateChar s
731translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
732translateConstant StrType = JSType JSStringTy
733translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
734translateConstant (AType ATFloat) = JSType JSFloatTy
735translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
736translateConstant PtrType = JSType JSPtrTy
737translateConstant Forgot = JSType JSForgotTy
738translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
739translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
740translateConstant (BI i) = jsBigInt (JSString $ show i)
741translateConstant (B8 b) = JSWord (JSWord8 b)
742translateConstant (B16 b) = JSWord (JSWord16 b)
743translateConstant (B32 b) = JSWord (JSWord32 b)
744translateConstant (B64 b) = JSWord (JSWord64 b)
745translateConstant c =
746 JSError $ "Unimplemented Constant: " ++ show c
749translateChar :: Char -> String
750translateChar ch
751 | '\a' <- ch = "\\u0007"
752 | '\b' <- ch = "\\b"
753 | '\f' <- ch = "\\f"
754 | '\n' <- ch = "\\n"
755 | '\r' <- ch = "\\r"
756 | '\t' <- ch = "\\t"
757 | '\v' <- ch = "\\v"
758 | '\SO' <- ch = "\\u000E"
759 | '\DEL' <- ch = "\\u007F"
760 | '\\' <- ch = "\\\\"
761 | '\"' <- ch = "\\\""
762 | '\'' <- ch = "\\\'"
763 | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")
764 | otherwise = [ch]
765 where
766 fill :: String -> String
767 fill s = if length s == 1
768 then '0' : s
769 else s
771 asciiTab =
772 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
773 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
774 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
775 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
777translateName :: Name -> String
778translateName n = "_idris_" ++ concatMap cchar (showCG n)
779 where cchar x | isAlphaNum x = [x]
780 | otherwise = "_" ++ show (fromEnum x) ++ "_"
782jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
783jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
785jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
786jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
788jsCALL :: CompileInfo -> Name -> JS
789jsCALL _ n =
790 JSApp (
791 JSIdent "i$CALL"
792 ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
794jsTAILCALL :: CompileInfo -> Name -> JS
795jsTAILCALL _ n =
796 JSApp (
797 JSIdent "i$CALL"
798 ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
800jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
801jsFOREIGN _ reg n args
802 | n == "putStr"
803 , [(FString, arg)] <- args =
804 JSAssign (
805 translateReg reg
806 ) (
807 JSApp (JSIdent "i$putStr") [translateReg arg]
808 )
810 | n == "isNull"
811 , [(FPtr, arg)] <- args =
812 JSAssign (
813 translateReg reg
814 ) (
815 JSBinOp "==" (translateReg arg) JSNull
816 )
818 | n == "idris_eqPtr"
819 , [(_, lhs),(_, rhs)] <- args =
820 JSAssign (
821 translateReg reg
822 ) (
823 JSBinOp "==" (translateReg lhs) (translateReg rhs)
824 )
825 | otherwise =
826 JSAssign (
827 translateReg reg
828 ) (
829 JSFFI n (map generateWrapper args)
830 )
831 where
832 generateWrapper :: (FType, Reg) -> JS
833 generateWrapper (ty, reg)
834 | FFunction <- ty =
835 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
836 , JSIdent "oldbase"
837 , JSIdent "myoldbase"
838 ]
839 | FFunctionIO <- ty =
840 JSApp (JSIdent "i$ffiWrap") [ translateReg reg
841 , JSIdent "oldbase"
842 , JSIdent "myoldbase"
843 ]
845 generateWrapper (_, reg) =
846 translateReg reg
848jsREBASE :: CompileInfo -> JS
849jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
851jsSTOREOLD :: CompileInfo ->JS
852jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
854jsADDTOP :: CompileInfo -> Int -> JS
855jsADDTOP info n
856 | 0 <- n = JSNoop
857 | otherwise =
858 JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
860jsTOPBASE :: CompileInfo -> Int -> JS
861jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
862jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
865jsBASETOP :: CompileInfo -> Int -> JS
866jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
867jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
869jsNULL :: CompileInfo -> Reg -> JS
870jsNULL _ r = JSAssign (translateReg r) JSNull
872jsERROR :: CompileInfo -> String -> JS
873jsERROR _ = JSError
875jsSLIDE :: CompileInfo -> Int -> JS
876jsSLIDE _ 1 = JSAssign (jsLOC 0) (jsTOP 0)
877jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
879jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
880jsMKCON info r t rs =
881 JSAssign (translateReg r) (
882 JSNew "i$CON" [ JSNum (JSInt t)
883 , JSArray (map translateReg rs)
884 , if t `elem` compileInfoApplyCases info
885 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
886 else JSNull
887 , if t `elem` compileInfoEvalCases info
888 then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
889 else JSNull
890 ]
891 )
893jsInstanceOf :: JS -> String -> JS
894jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
896jsOr :: JS -> JS -> JS
897jsOr lhs rhs = JSBinOp "||" lhs rhs
899jsAnd :: JS -> JS -> JS
900jsAnd lhs rhs = JSBinOp "&&" lhs rhs
902jsMeth :: JS -> String -> [JS] -> JS
903jsMeth obj meth args = JSApp (JSProj obj meth) args
905jsCall :: String -> [JS] -> JS
906jsCall fun args = JSApp (JSIdent fun) args
908jsTypeOf :: JS -> JS
909jsTypeOf js = JSPreOp "typeof " js
911jsEq :: JS -> JS -> JS
912jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
913jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
914jsEq lhs rhs = JSBinOp "==" lhs rhs
916jsNotEq :: JS -> JS -> JS
917jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
919jsIsNumber :: JS -> JS
920jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
922jsIsNull :: JS -> JS
923jsIsNull js = JSBinOp "==" js JSNull
925jsBigInt :: JS -> JS
926jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
927jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
928jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
930jsUnPackBits :: JS -> JS
931jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
933jsPackUBits8 :: JS -> JS
934jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
936jsPackUBits16 :: JS -> JS
937jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
939jsPackUBits32 :: JS -> JS
940jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
942jsPackSBits8 :: JS -> JS
943jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
945jsPackSBits16 :: JS -> JS
946jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
948jsPackSBits32 :: JS -> JS
949jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
951jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
952jsCASE info safe reg cases def =
953 JSSwitch (tag safe $ translateReg reg) (
954 map ((JSNum . JSInt) *** prepBranch) cases
955 ) (fmap prepBranch def)
956 where
957 tag :: Bool -> JS -> JS
958 tag True = jsCTAG
959 tag False = jsTAG
961 prepBranch :: [BC] -> JS
962 prepBranch bc = JSSeq $ map (translateBC info) bc
964 jsTAG :: JS -> JS
965 jsTAG js =
966 (JSTernary (js `jsInstanceOf` "i$CON") (
967 JSProj js "tag"
968 ) (JSNum (JSInt $ negate 1)))
970 jsCTAG :: JS -> JS
971 jsCTAG js = JSProj js "tag"
974jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
975jsCONSTCASE info reg cases def =
976 JSCond $ (
977 map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
978 ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
979 where
980 prepBranch :: [BC] -> JS
981 prepBranch bc = JSSeq $ map (translateBC info) bc
983jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
984jsPROJECT _ reg loc 0 = JSNoop
985jsPROJECT _ reg loc 1 =
986 JSAssign (jsLOC loc) (
987 JSIndex (
988 JSProj (translateReg reg) "args"
989 ) (
990 JSNum (JSInt 0)
991 )
992 )
993jsPROJECT _ reg loc ar =
994 JSApp (JSIdent "i$PROJECT") [ translateReg reg
995 , JSNum (JSInt loc)
996 , JSNum (JSInt ar)
997 ]
999jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
1000jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
1001 where
1002 jsOP' :: JS
1003 jsOP'
1004 | LNoOp <- op = translateReg (last args)
1006 | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
1007 | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
1008 | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
1010 | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
1011 | (LPlus (ATInt ITBig)) <- op
1012 , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
1013 | (LMinus (ATInt ITBig)) <- op
1014 , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
1015 | (LTimes (ATInt ITBig)) <- op
1016 , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
1017 | (LSDiv (ATInt ITBig)) <- op
1018 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1019 | (LSRem (ATInt ITBig)) <- op
1020 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1021 | (LEq (ATInt ITBig)) <- op
1022 , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
1023 | (LSLt (ATInt ITBig)) <- op
1024 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1025 | (LSLe (ATInt ITBig)) <- op
1026 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1027 | (LSGt (ATInt ITBig)) <- op
1028 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1029 | (LSGe (ATInt ITBig)) <- op
1030 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1032 | (LPlus ATFloat) <- op
1033 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1034 | (LMinus ATFloat) <- op
1035 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1036 | (LTimes ATFloat) <- op
1037 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1038 | (LSDiv ATFloat) <- op
1039 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1040 | (LEq ATFloat) <- op
1041 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1042 | (LSLt ATFloat) <- op
1043 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1044 | (LSLe ATFloat) <- op
1045 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1046 | (LSGt ATFloat) <- op
1047 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1048 | (LSGe ATFloat) <- op
1049 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1051 | (LPlus (ATInt ITChar)) <- op
1052 , (lhs:rhs:_) <- args =
1053 jsCall "i$fromCharCode" [
1054 JSBinOp "+" (
1055 jsCall "i$charCode" [translateReg lhs]
1056 ) (
1057 jsCall "i$charCode" [translateReg rhs]
1061 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1062 , (arg:_) <- args =
1063 jsPackUBits8 (
1064 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
1067 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1068 , (arg:_) <- args =
1069 jsPackUBits16 (
1070 JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
1073 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
1074 , (arg:_) <- args =
1075 jsPackUBits32 (
1076 jsMeth (jsMeth (translateReg arg) "and" [
1077 jsBigInt (JSString $ show 0xFFFFFFFF)
1078 ]) "intValue" []
1081 | (LTrunc ITBig (ITFixed IT64)) <- op
1082 , (arg:_) <- args =
1083 jsMeth (translateReg arg) "and" [
1084 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1087 | (LLSHR (ITFixed IT8)) <- op
1088 , (lhs:rhs:_) <- args =
1089 jsPackUBits8 (
1090 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1093 | (LLSHR (ITFixed IT16)) <- op
1094 , (lhs:rhs:_) <- args =
1095 jsPackUBits16 (
1096 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1099 | (LLSHR (ITFixed IT32)) <- op
1100 , (lhs:rhs:_) <- args =
1101 jsPackUBits32 (
1102 JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1105 | (LLSHR (ITFixed IT64)) <- op
1106 , (lhs:rhs:_) <- args =
1107 jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
1109 | (LSHL (ITFixed IT8)) <- op
1110 , (lhs:rhs:_) <- args =
1111 jsPackUBits8 (
1112 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1115 | (LSHL (ITFixed IT16)) <- op
1116 , (lhs:rhs:_) <- args =
1117 jsPackUBits16 (
1118 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1121 | (LSHL (ITFixed IT32)) <- op
1122 , (lhs:rhs:_) <- args =
1123 jsPackUBits32 (
1124 JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
1127 | (LSHL (ITFixed IT64)) <- op
1128 , (lhs:rhs:_) <- args =
1129 jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
1130 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1133 | (LAnd (ITFixed IT8)) <- op
1134 , (lhs:rhs:_) <- args =
1135 jsPackUBits8 (
1136 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1139 | (LAnd (ITFixed IT16)) <- op
1140 , (lhs:rhs:_) <- args =
1141 jsPackUBits16 (
1142 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1145 | (LAnd (ITFixed IT32)) <- op
1146 , (lhs:rhs:_) <- args =
1147 jsPackUBits32 (
1148 JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1151 | (LAnd (ITFixed IT64)) <- op
1152 , (lhs:rhs:_) <- args =
1153 jsMeth (translateReg lhs) "and" [translateReg rhs]
1155 | (LOr (ITFixed IT8)) <- op
1156 , (lhs:rhs:_) <- args =
1157 jsPackUBits8 (
1158 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1161 | (LOr (ITFixed IT16)) <- op
1162 , (lhs:rhs:_) <- args =
1163 jsPackUBits16 (
1164 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1167 | (LOr (ITFixed IT32)) <- op
1168 , (lhs:rhs:_) <- args =
1169 jsPackUBits32 (
1170 JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1173 | (LOr (ITFixed IT64)) <- op
1174 , (lhs:rhs:_) <- args =
1175 jsMeth (translateReg lhs) "or" [translateReg rhs]
1177 | (LXOr (ITFixed IT8)) <- op
1178 , (lhs:rhs:_) <- args =
1179 jsPackUBits8 (
1180 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1183 | (LXOr (ITFixed IT16)) <- op
1184 , (lhs:rhs:_) <- args =
1185 jsPackUBits16 (
1186 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1189 | (LXOr (ITFixed IT32)) <- op
1190 , (lhs:rhs:_) <- args =
1191 jsPackUBits32 (
1192 JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1195 | (LXOr (ITFixed IT64)) <- op
1196 , (lhs:rhs:_) <- args =
1197 jsMeth (translateReg lhs) "xor" [translateReg rhs]
1199 | (LPlus (ATInt (ITFixed IT8))) <- op
1200 , (lhs:rhs:_) <- args =
1201 jsPackUBits8 (
1202 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1205 | (LPlus (ATInt (ITFixed IT16))) <- op
1206 , (lhs:rhs:_) <- args =
1207 jsPackUBits16 (
1208 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1211 | (LPlus (ATInt (ITFixed IT32))) <- op
1212 , (lhs:rhs:_) <- args =
1213 jsPackUBits32 (
1214 JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1217 | (LPlus (ATInt (ITFixed IT64))) <- op
1218 , (lhs:rhs:_) <- args =
1219 jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
1220 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1223 | (LMinus (ATInt (ITFixed IT8))) <- op
1224 , (lhs:rhs:_) <- args =
1225 jsPackUBits8 (
1226 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1229 | (LMinus (ATInt (ITFixed IT16))) <- op
1230 , (lhs:rhs:_) <- args =
1231 jsPackUBits16 (
1232 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1235 | (LMinus (ATInt (ITFixed IT32))) <- op
1236 , (lhs:rhs:_) <- args =
1237 jsPackUBits32 (
1238 JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1241 | (LMinus (ATInt (ITFixed IT64))) <- op
1242 , (lhs:rhs:_) <- args =
1243 jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
1244 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1247 | (LTimes (ATInt (ITFixed IT8))) <- op
1248 , (lhs:rhs:_) <- args =
1249 jsPackUBits8 (
1250 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1253 | (LTimes (ATInt (ITFixed IT16))) <- op
1254 , (lhs:rhs:_) <- args =
1255 jsPackUBits16 (
1256 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1259 | (LTimes (ATInt (ITFixed IT32))) <- op
1260 , (lhs:rhs:_) <- args =
1261 jsPackUBits32 (
1262 JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1265 | (LTimes (ATInt (ITFixed IT64))) <- op
1266 , (lhs:rhs:_) <- args =
1267 jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
1268 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1271 | (LEq (ATInt (ITFixed IT8))) <- op
1272 , (lhs:rhs:_) <- args =
1273 jsPackUBits8 (
1274 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1277 | (LEq (ATInt (ITFixed IT16))) <- op
1278 , (lhs:rhs:_) <- args =
1279 jsPackUBits16 (
1280 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1283 | (LEq (ATInt (ITFixed IT32))) <- op
1284 , (lhs:rhs:_) <- args =
1285 jsPackUBits32 (
1286 JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1289 | (LEq (ATInt (ITFixed IT64))) <- op
1290 , (lhs:rhs:_) <- args =
1291 jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
1292 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1295 | (LLt (ITFixed IT8)) <- op
1296 , (lhs:rhs:_) <- args =
1297 jsPackUBits8 (
1298 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1301 | (LLt (ITFixed IT16)) <- op
1302 , (lhs:rhs:_) <- args =
1303 jsPackUBits16 (
1304 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1307 | (LLt (ITFixed IT32)) <- op
1308 , (lhs:rhs:_) <- args =
1309 jsPackUBits32 (
1310 JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1313 | (LLt (ITFixed IT64)) <- op
1314 , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
1316 | (LLe (ITFixed IT8)) <- op
1317 , (lhs:rhs:_) <- args =
1318 jsPackUBits8 (
1319 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1322 | (LLe (ITFixed IT16)) <- op
1323 , (lhs:rhs:_) <- args =
1324 jsPackUBits16 (
1325 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1328 | (LLe (ITFixed IT32)) <- op
1329 , (lhs:rhs:_) <- args =
1330 jsPackUBits32 (
1331 JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1334 | (LLe (ITFixed IT64)) <- op
1335 , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1337 | (LGt (ITFixed IT8)) <- op
1338 , (lhs:rhs:_) <- args =
1339 jsPackUBits8 (
1340 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1343 | (LGt (ITFixed IT16)) <- op
1344 , (lhs:rhs:_) <- args =
1345 jsPackUBits16 (
1346 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1348 | (LGt (ITFixed IT32)) <- op
1349 , (lhs:rhs:_) <- args =
1350 jsPackUBits32 (
1351 JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1354 | (LGt (ITFixed IT64)) <- op
1355 , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1357 | (LGe (ITFixed IT8)) <- op
1358 , (lhs:rhs:_) <- args =
1359 jsPackUBits8 (
1360 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1363 | (LGe (ITFixed IT16)) <- op
1364 , (lhs:rhs:_) <- args =
1365 jsPackUBits16 (
1366 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1368 | (LGe (ITFixed IT32)) <- op
1369 , (lhs:rhs:_) <- args =
1370 jsPackUBits32 (
1371 JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1374 | (LGe (ITFixed IT64)) <- op
1375 , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
1377 | (LUDiv (ITFixed IT8)) <- op
1378 , (lhs:rhs:_) <- args =
1379 jsPackUBits8 (
1380 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1383 | (LUDiv (ITFixed IT16)) <- op
1384 , (lhs:rhs:_) <- args =
1385 jsPackUBits16 (
1386 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1389 | (LUDiv (ITFixed IT32)) <- op
1390 , (lhs:rhs:_) <- args =
1391 jsPackUBits32 (
1392 JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1395 | (LUDiv (ITFixed IT64)) <- op
1396 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1398 | (LSDiv (ATInt (ITFixed IT8))) <- op
1399 , (lhs:rhs:_) <- args =
1400 jsPackSBits8 (
1401 JSBinOp "/" (
1402 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1403 ) (
1404 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1408 | (LSDiv (ATInt (ITFixed IT16))) <- op
1409 , (lhs:rhs:_) <- args =
1410 jsPackSBits16 (
1411 JSBinOp "/" (
1412 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1413 ) (
1414 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1418 | (LSDiv (ATInt (ITFixed IT32))) <- op
1419 , (lhs:rhs:_) <- args =
1420 jsPackSBits32 (
1421 JSBinOp "/" (
1422 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1423 ) (
1424 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1428 | (LSDiv (ATInt (ITFixed IT64))) <- op
1429 , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1431 | (LSRem (ATInt (ITFixed IT8))) <- op
1432 , (lhs:rhs:_) <- args =
1433 jsPackSBits8 (
1434 JSBinOp "%" (
1435 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1436 ) (
1437 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1441 | (LSRem (ATInt (ITFixed IT16))) <- op
1442 , (lhs:rhs:_) <- args =
1443 jsPackSBits16 (
1444 JSBinOp "%" (
1445 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1446 ) (
1447 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1451 | (LSRem (ATInt (ITFixed IT32))) <- op
1452 , (lhs:rhs:_) <- args =
1453 jsPackSBits32 (
1454 JSBinOp "%" (
1455 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1456 ) (
1457 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1461 | (LSRem (ATInt (ITFixed IT64))) <- op
1462 , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1464 | (LCompl (ITFixed IT8)) <- op
1465 , (arg:_) <- args =
1466 jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1468 | (LCompl (ITFixed IT16)) <- op
1469 , (arg:_) <- args =
1470 jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1472 | (LCompl (ITFixed IT32)) <- op
1473 , (arg:_) <- args =
1474 jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1476 | (LCompl (ITFixed IT64)) <- op
1477 , (arg:_) <- args =
1478 invokeMeth arg "not" []
1480 | (LPlus _) <- op
1481 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1482 | (LMinus _) <- op
1483 , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1484 | (LTimes _) <- op
1485 , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1486 | (LSDiv _) <- op
1487 , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1488 | (LSRem _) <- op
1489 , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1490 | (LEq _) <- op
1491 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1492 | (LSLt _) <- op
1493 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1494 | (LSLe _) <- op
1495 , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1496 | (LSGt _) <- op
1497 , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1498 | (LSGe _) <- op
1499 , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1500 | (LAnd _) <- op
1501 , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1502 | (LOr _) <- op
1503 , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1504 | (LXOr _) <- op
1505 , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1506 | (LSHL _) <- op
1507 , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1508 | (LASHR _) <- op
1509 , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1510 | (LCompl _) <- op
1511 , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1513 | LStrConcat <- op
1514 , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1515 | LStrEq <- op
1516 , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1517 | LStrLt <- op
1518 , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1519 | LStrLen <- op
1520 , (arg:_) <- args = JSProj (translateReg arg) "length"
1521 | (LStrInt ITNative) <- op
1522 , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1523 | (LIntStr ITNative) <- op
1524 , (arg:_) <- args = jsCall "String" [translateReg arg]
1525 | (LSExt ITNative ITBig) <- op
1526 , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1527 | (LTrunc ITBig ITNative) <- op
1528 , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1529 | (LIntStr ITBig) <- op
1530 , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1531 | (LStrInt ITBig) <- op
1532 , (arg:_) <- args = jsBigInt $ translateReg arg
1533 | LFloatStr <- op
1534 , (arg:_) <- args = jsCall "String" [translateReg arg]
1535 | LStrFloat <- op
1536 , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1537 | (LIntFloat ITNative) <- op
1538 , (arg:_) <- args = translateReg arg
1539 | (LFloatInt ITNative) <- op
1540 , (arg:_) <- args = translateReg arg
1541 | (LChInt ITNative) <- op
1542 , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1543 | (LIntCh ITNative) <- op
1544 , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1546 | LFExp <- op
1547 , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1548 | LFLog <- op
1549 , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1550 | LFSin <- op
1551 , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1552 | LFCos <- op
1553 , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1554 | LFTan <- op
1555 , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1556 | LFASin <- op
1557 , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1558 | LFACos <- op
1559 , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1560 | LFATan <- op
1561 , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1562 | LFSqrt <- op
1563 , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1564 | LFFloor <- op
1565 , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1566 | LFCeil <- op
1567 , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1569 | LStrCons <- op
1570 , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1571 | LStrHead <- op
1572 , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1573 | LStrRev <- op
1574 , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1575 | LStrIndex <- op
1576 , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1577 | LStrTail <- op
1578 , (arg:_) <- args =
1579 let v = translateReg arg in
1580 JSApp (JSProj v "substr") [
1581 JSNum (JSInt 1),
1582 JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1585 | LSystemInfo <- op
1586 , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1587 | LNullPtr <- op
1588 , (_) <- args = JSNull
1589 | otherwise = JSError $ "Not implemented: " ++ show op
1590 where
1591 translateBinaryOp :: String -> Reg -> Reg -> JS
1592 translateBinaryOp op lhs rhs =
1593 JSBinOp op (translateReg lhs) (translateReg rhs)
1595 invokeMeth :: Reg -> String -> [Reg] -> JS
1596 invokeMeth obj meth args =
1597 JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1600jsRESERVE :: CompileInfo -> Int -> JS
1601jsRESERVE _ _ = JSNoop
1603jsSTACK :: JS
1604jsSTACK = JSIdent "i$valstack"
1606jsCALLSTACK :: JS
1607jsCALLSTACK = JSIdent "i$callstack"
1609jsSTACKBASE :: JS
1610jsSTACKBASE = JSIdent "i$valstack_base"
1612jsSTACKTOP :: JS
1613jsSTACKTOP = JSIdent "i$valstack_top"
1615jsOLDBASE :: JS
1616jsOLDBASE = JSIdent "oldbase"
1618jsMYOLDBASE :: JS
1619jsMYOLDBASE = JSIdent "myoldbase"
1621jsRET :: JS
1622jsRET = JSIdent "i$ret"
1624jsLOC :: Int -> JS
1625jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1626jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1628jsTOP :: Int -> JS
1629jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1630jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1632jsPUSH :: [JS] -> JS
1633jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1635jsPOP :: JS
1636jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1638translateBC :: CompileInfo -> BC -> JS
1639translateBC info bc
1640 | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1641 | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1642 | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1643 | ADDTOP n <- bc = jsADDTOP info n
1644 | NULL r <- bc = jsNULL info r
1645 | CALL n <- bc = jsCALL info n
1646 | TAILCALL n <- bc = jsTAILCALL info n
1647 | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1648 | TOPBASE n <- bc = jsTOPBASE info n
1649 | BASETOP n <- bc = jsBASETOP info n
1650 | STOREOLD <- bc = jsSTOREOLD info
1651 | SLIDE n <- bc = jsSLIDE info n
1652 | REBASE <- bc = jsREBASE info
1653 | RESERVE n <- bc = jsRESERVE info n
1654 | MKCON r t rs <- bc = jsMKCON info r t rs
1655 | CASE s r c d <- bc = jsCASE info s r c d
1656 | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1657 | PROJECT r l a <- bc = jsPROJECT info r l a
1658 | OP r o a <- bc = jsOP info r o a
1659 | ERROR e <- bc = jsERROR info e
1660 | otherwise = JSRaw $ "//" ++ show bc