@@ -1,5 +1,4 @@
1{-# LANGUAGE PatternGuards #-}
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
2module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
5import Idris.AbsSyntax hiding (TypeCase)
4import Idris.AbsSyntax hiding (TypeCase)
@@ -12,12 +11,15 @@ import Paths_idris
12import Util.System
11import Util.System
14import Control.Arrow
13import Control.Arrow
14+import Control.Monad (mapM)
15import Control.Applicative ((<$>), (<*>), pure)
15import Control.Applicative ((<$>), (<*>), pure)
16+import Control.Monad.RWS hiding (mapM)
16import Data.Char
17import Data.Char
17import Numeric
18import Numeric
18import Data.List
19import Data.List
19import Data.Maybe
20import Data.Maybe
20import Data.Word
21import Data.Word
22+import Data.Traversable hiding (mapM)
21import System.IO
23import System.IO
22import System.Directory
24import System.Directory
@@ -28,6 +30,30 @@ idrRTNamespace = "__IDRRT__"
28idrLTNamespace = "__IDRLT__"
30idrLTNamespace = "__IDRLT__"
29idrCTRNamespace = "__IDRCTR__"
31idrCTRNamespace = "__IDRCTR__"
33+data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
34+ , compileInfoEvalCases :: [Int]
38+initCompileInfo :: [(Name, [BC])] -> CompileInfo
40+ CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc)
42+ collectCases :: String -> [(Name, [BC])] -> [Int]
43+ collectCases fun bc = getCases $ findFunction fun bc
45+ findFunction :: String -> [(Name, [BC])] -> [BC]
46+ findFunction f ((MN 0 fun, bc):_)
48+ findFunction f (_:bc) = findFunction f bc
50+ getCases :: [BC] -> [Int]
51+ getCases = concatMap analyze
53+ analyze :: BC -> [Int]
54+ analyze (CASE _ _ b _) = map fst b
32data JSTarget = Node | JavaScript deriving Eq
58data JSTarget = Node | JavaScript deriving Eq
@@ -45,6 +71,7 @@ data JSType = JSIntTy
45data JSInteger = JSBigZero
71data JSInteger = JSBigZero
46 | JSBigOne
72 | JSBigOne
47 | JSBigInt Integer
73 | JSBigInt Integer
48 deriving Eq
75 deriving Eq
@@ -81,8 +108,8 @@ data JS = JSRaw String
81 | JSPreOp String JS
108 | JSPreOp String JS
82 | JSPostOp String JS
109 | JSPostOp String JS
83 | JSProj JS String
110 | JSProj JS String
88 | JSFalse
115 | JSFalse
@@ -93,6 +120,7 @@ data JS = JSRaw String
93 | JSAssign JS JS
120 | JSAssign JS JS
94 | JSAlloc String (Maybe JS)
121 | JSAlloc String (Maybe JS)
95 | JSIndex JS JS
122 | JSIndex JS JS
123+ | JSSwitch JS [(JS, JS)] (Maybe JS)
96 | JSCond [(JS, JS)]
124 | JSCond [(JS, JS)]
97 | JSTernary JS JS JS
125 | JSTernary JS JS JS
98 | JSParens JS
126 | JSParens JS
@@ -105,7 +133,6 @@ data JS = JSRaw String
106data FFI = FFICode Char | FFIArg Int | FFIError String
134data FFI = FFICode Char | FFIArg Int | FFIError String
109ffi :: String -> [String] -> String
136ffi :: String -> [String] -> String
110ffi code args = let parsed = ffiParse code in
137ffi code args = let parsed = ffiParse code in
111 case ffiError parsed of
138 case ffiError parsed of
@@ -137,30 +164,32 @@ ffi code args = let parsed = ffiParse code in
137 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
164 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
138 | otherwise = error "FFI - Argument index out of bounds"
165 | otherwise = error "FFI - Argument index out of bounds"
141compileJS :: JS -> String
167compileJS :: JS -> String
142−compileJS JSNoop = ""
168+compileJS = compileJS' 0
144−compileJS (JSAnnotation annotation js) =
170+compileJS' :: Int -> JS -> String
145− "/** @" ++ show annotation ++ " */\n" ++ compileJS js
171+compileJS' indent JSNoop = ""
147−compileJS (JSFFI raw args) =
173+compileJS' indent (JSAnnotation annotation js) =
148− ffi raw (map compileJS args)
174+ "/** @" ++ show annotation ++ " */\n" ++ compileJS' indent js
176+compileJS' indent (JSFFI raw args) =
177+ ffi raw (map (compileJS' indent) args)
150−compileJS (JSRaw code) =
179+compileJS' indent (JSRaw code) =
153−compileJS (JSIdent ident) =
182+compileJS' indent (JSIdent ident) =
156−compileJS (JSFunction args body) =
185+compileJS' indent (JSFunction args body) =
157− "function("
186+ replicate indent ' ' ++ "function("
158 ++ intercalate "," args
187 ++ intercalate "," args
159 ++ "){\n"
188 ++ "){\n"
160− ++ compileJS body
189+ ++ compileJS' (indent + 2) body
161− ++ "\n}"
190+ ++ "\n}\n"
163−compileJS (JSType ty)
192+compileJS' indent (JSType ty)
164 | JSIntTy <- ty = idrRTNamespace ++ "Int"
193 | JSIntTy <- ty = idrRTNamespace ++ "Int"
165 | JSStringTy <- ty = idrRTNamespace ++ "String"
194 | JSStringTy <- ty = idrRTNamespace ++ "String"
166 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
195 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
@@ -169,2473 +198,1307 @@ compileJS (JSType ty)
169 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
198 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
170 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
199 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
172−compileJS (JSSeq seq) =
201+compileJS' indent (JSSeq seq) =
173− intercalate ";\n" (map compileJS seq)
202+ intercalate ";\n" (
204+ ((replicate indent ' ') ++) . (compileJS' indent)
205+ ) $ filter (/= JSNoop) seq
175−compileJS (JSReturn val) =
208+compileJS' indent (JSReturn val) =
176− "return " ++ compileJS val
209+ "return " ++ compileJS' indent val
178−compileJS (JSApp lhs rhs)
211+compileJS' indent (JSApp lhs rhs)
179 | JSFunction {} <- lhs =
212 | JSFunction {} <- lhs =
180− concat ["(", compileJS lhs, ")(", args, ")"]
213+ concat ["(", compileJS' indent lhs, ")(", args, ")"]
181 | otherwise =
214 | otherwise =
182− concat [compileJS lhs, "(", args, ")"]
215+ concat [compileJS' indent lhs, "(", args, ")"]
183 where args :: String
216 where args :: String
184− args = intercalate "," $ map compileJS rhs
217+ args = intercalate "," $ map (compileJS' 0) rhs
186−compileJS (JSNew name args) =
219+compileJS' indent (JSNew name args) =
187− "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
220+ "new " ++ name ++ "(" ++ intercalate "," (map (compileJS' 0) args) ++ ")"
189−compileJS (JSError exc) =
222+compileJS' indent (JSError exc) =
190 "throw new Error(\"" ++ exc ++ "\")"
223 "throw new Error(\"" ++ exc ++ "\")"
192−compileJS (JSBinOp op lhs rhs) =
225+compileJS' indent (JSBinOp op lhs rhs) =
193− compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
226+ compileJS' indent lhs ++ " " ++ op ++ " " ++ compileJS' indent rhs
195−compileJS (JSPreOp op val) =
228+compileJS' indent (JSPreOp op val) =
196− op ++ compileJS val
229+ op ++ compileJS' indent val
198−compileJS (JSProj obj field)
231+compileJS' indent (JSProj obj field)
199 | JSFunction {} <- obj =
232 | JSFunction {} <- obj =
200− concat ["(", compileJS obj, ").", field]
233+ concat ["(", compileJS' indent obj, ").", field]
201 | JSAssign {} <- obj =
234 | JSAssign {} <- obj =
202− concat ["(", compileJS obj, ").", field]
235+ concat ["(", compileJS' indent obj, ").", field]
203 | otherwise =
236 | otherwise =
204− compileJS obj ++ '.' : field
237+ compileJS' indent obj ++ '.' : field
206−compileJS (JSVar var) =
207− translateVariableName var
209−compileJS JSNull =
239+compileJS' indent JSNull =
212−compileJS JSThis =
242+compileJS' indent JSUndefined =
245+compileJS' indent JSThis =
215−compileJS JSTrue =
248+compileJS' indent JSTrue =
218−compileJS JSFalse =
251+compileJS' indent JSFalse =
221−compileJS (JSArray elems) =
254+compileJS' indent (JSArray elems) =
222− "[" ++ intercalate "," (map compileJS elems) ++ "]"
255+ "[" ++ intercalate "," (map (compileJS' 0) elems) ++ "]"
224−compileJS (JSString str) =
257+compileJS' indent (JSString str) =
225 "\"" ++ str ++ "\""
258 "\"" ++ str ++ "\""
227−compileJS (JSNum num)
260+compileJS' indent (JSNum num)
228− | JSInt i <- num = show i
261+ | JSInt i <- num = show i
229− | JSFloat f <- num = show f
262+ | JSFloat f <- num = show f
230− | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
263+ | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
231− | JSInteger JSBigOne <- num = "__IDRRT__ONE"
264+ | JSInteger JSBigOne <- num = "__IDRRT__ONE"
232− | JSInteger (JSBigInt i) <- num = show i
265+ | JSInteger (JSBigInt i) <- num = show i
266+ | JSInteger (JSBigIntExpr e) <- num = "__IDRRT__bigInt(" ++ compileJS' indent e ++ ")"
234−compileJS (JSAssign lhs rhs) =
268+compileJS' indent (JSAssign lhs rhs) =
235− compileJS lhs ++ "=" ++ compileJS rhs
269+ compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
237−compileJS (JSAlloc name val) =
271+compileJS' indent (JSAlloc name val) =
238− "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
272+ "var " ++ name ++ maybe "" ((" = " ++) . compileJS' indent) val
240−compileJS (JSIndex lhs rhs) =
274+compileJS' indent (JSIndex lhs rhs) =
241− compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
275+ compileJS' indent lhs ++ "[" ++ compileJS' indent rhs ++ "]"
243−compileJS (JSCond branches) =
277+compileJS' indent (JSCond branches) =
244 intercalate " else " $ map createIfBlock branches
278 intercalate " else " $ map createIfBlock branches
280+ createIfBlock (JSNoop, e@(JSSeq _)) =
282+ ++ compileJS' (indent + 2) e
283+ ++ "\n" ++ replicate indent ' ' ++ "}"
246 createIfBlock (JSNoop, e) =
284 createIfBlock (JSNoop, e) =
248− ++ compileJS e
286+ ++ compileJS' (indent + 2) e
249− ++ ";\n}"
287+ ++ ";\n" ++ replicate indent ' ' ++ "}"
288+ createIfBlock (cond, e@(JSSeq _)) =
289+ "if (" ++ compileJS' indent cond ++") {\n"
290+ ++ compileJS' (indent + 2) e
291+ ++ "\n" ++ replicate indent ' ' ++ "}"
250 createIfBlock (cond, e) =
292 createIfBlock (cond, e) =
251− "if (" ++ compileJS cond ++") {\n"
293+ "if (" ++ compileJS' indent cond ++") {\n"
252− ++ compileJS e
294+ ++ replicate (indent + 2) ' ' ++ compileJS' (indent + 2) e
253− ++ ";\n}"
295+ ++ ";\n" ++ replicate indent ' ' ++ "}"
297+compileJS' indent (JSSwitch val [(_,seq)] Nothing) =
298+ compileJS' indent seq
300+compileJS' indent (JSSwitch val branches def) =
301+ "switch(" ++ compileJS' indent val ++ "){\n"
302+ ++ concatMap mkBranch branches
304+ ++ (replicate indent ' ') ++ "}"
306+ mkBranch :: (JS, JS) -> String
307+ mkBranch (tag, code) =
308+ replicate (indent + 2) ' ' ++ "case " ++ compileJS' indent tag ++ ":\n"
309+ ++ compileJS' (indent + 4) code
310+ ++ "\n" ++ (replicate (indent + 4) ' ' ++ "break;\n")
312+ mkDefault :: Maybe JS -> String
313+ mkDefault Nothing = ""
314+ mkDefault (Just def) =
315+ replicate (indent + 2) ' ' ++ "default:\n"
316+ ++ compileJS' (indent + 4)def
255−compileJS (JSTernary cond true false) =
320+compileJS' indent (JSTernary cond true false) =
256− let c = compileJS cond
321+ let c = compileJS' indent cond
257− t = compileJS true
322+ t = compileJS' indent true
258− f = compileJS false in
323+ f = compileJS' indent false in
259 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
324 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
261−compileJS (JSParens js) =
326+compileJS' indent (JSParens js) =
262− "(" ++ compileJS js ++ ")"
327+ "(" ++ compileJS' indent js ++ ")"
264−compileJS (JSWhile cond body) =
329+compileJS' indent (JSWhile cond body) =
265− "while (" ++ compileJS cond ++ ") {\n"
330+ "while (" ++ compileJS' indent cond ++ ") {\n"
266− ++ compileJS body
331+ ++ compileJS' (indent + 2) body
267− ++ "\n}"
332+ ++ "\n" ++ replicate indent ' ' ++ "}"
269−compileJS (JSWord word)
334+compileJS' indent (JSWord word)
270 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
335 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
271 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
336 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
272 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
337 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
273 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
338 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
340+codegenJavaScript :: CodeGenerator
341+codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
342+ (includes ci) (outputFile ci) (outputType ci)
276−jsTailcall :: JS -> JS
344+codegenNode :: CodeGenerator
277−jsTailcall call =
345+codegenNode ci = codegenJS_all Node (simpleDecls ci)
278− jsCall (idrRTNamespace ++ "tailcall") [
346+ (includes ci) (outputFile ci) (outputType ci)
279− JSFunction [] (JSReturn call)
283−jsCall :: String -> [JS] -> JS
284−jsCall fun = JSApp (JSIdent fun)
287−jsMeth :: JS -> String -> [JS] -> JS
289− JSApp (JSProj obj meth)
292−jsInstanceOf :: JS -> JS -> JS
293−jsInstanceOf = JSBinOp "instanceof"
296−jsEq :: JS -> JS -> JS
299−jsNotEq :: JS -> JS -> JS
300−jsNotEq = JSBinOp "!="
302−jsAnd :: JS -> JS -> JS
306−jsOr :: JS -> JS -> JS
311−jsType = JSIdent $ idrRTNamespace ++ "Type"
315−jsCon = JSIdent $ idrRTNamespace ++ "Con"
319−jsTag obj = JSProj obj "tag"
322−jsTypeTag :: JS -> JS
323−jsTypeTag obj = JSProj obj "type"
326−jsBigInt :: JS -> JS
348+codegenJS_all
327−jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
349+ :: JSTarget
328−jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
350+ -> [(Name, SDecl)]
329−jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
351+ -> [FilePath]
355+codegenJS_all target definitions includes filename outputType = do
356+ let bytecode = map toBC definitions
357+ let info = initCompileInfo bytecode
358+ let js = concatMap (translateDecl info) bytecode
359+ let code = concatMap ((map compileJS) . collectSplitFunctions . (\x -> evalRWS (splitFunction x) () 0)) js
360+ let (header, rt) = case target of
361+ Node -> ("#!/usr/bin/env node\n", "-node")
362+ JavaScript -> ("", "-browser")
364+ included <- concat <$> getIncludes includes
365+ path <- (++) <$> getDataDir <*> (pure "/jsrts/")
366+ idrRuntime <- readFile $ path ++ "Runtime-common.js"
367+ tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
368+ jsbn <- readFile $ path ++ "jsbn/jsbn.js"
369+ let runtime = header ++ included ++ jsbn ++ idrRuntime ++ tgtRuntime
370+ writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
371+ setPermissions filename (emptyPermissions { readable = True
372+ , executable = target == Node
376+ getIncludes :: [FilePath] -> IO [String]
377+ getIncludes = mapM readFile
381+ compileJS $ JSAlloc "main" (Just $
385+ JavaScript -> jsMain
332−jsVar :: Int -> String
389+ jsMain :: JS
333−jsVar = ("__var_" ++) . show
390+ jsMain =
391+ JSCond [ (exists document `jsAnd` isReady, mainFun)
392+ , (exists window, windowMainFun)
397+ exists js = jsTypeOf js `jsNotEq` JSString "undefined"
400+ window = JSIdent "window"
403+ document = JSIdent "document"
407+ jsMeth window "addEventListener" [ JSString "DOMContentLoaded"
408+ , JSFunction [] ( mainFun )
413+ isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
416+ readyState = JSProj (JSIdent "document") "readyState"
420+ JSSeq [ JSAlloc "vm" (Just $ JSNew "i$VM" [])
421+ , JSApp (JSIdent "i$SCHED") [JSIdent "vm"]
423+ JSIdent (translateName (sMN 0 "runMain"))
425+ , JSWhile (JSProj jsCALLSTACK "length") (
426+ JSSeq [ JSAlloc "func" (Just jsPOP)
427+ , JSAlloc "args" (Just jsPOP)
428+ , JSApp (JSProj (JSIdent "func") "apply") [JSThis, JSIdent "args"]
433+ invokeMain :: String
434+ invokeMain = compileJS $ JSApp (JSIdent "main") []
336−jsLet :: String -> JS -> JS -> JS
436+collectSplitFunctions :: (JS, [(Int,JS)]) -> [JS]
337−jsLet name value body =
437+collectSplitFunctions (fun, splits) = map generateSplitFunction splits ++ [fun]
339− JSFunction [name] (
439+ generateSplitFunction :: (Int,JS) -> JS
340− JSReturn body
440+ generateSplitFunction (depth, JSAlloc name fun) =
341− )
441+ JSAlloc (name ++ "$" ++ show depth) fun
443+splitFunction :: JS -> RWS () [(Int,JS)] Int JS
444+splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
445+ body' <- splitSequence body
446+ return $ JSAlloc name (Just (JSFunction args body'))
448+ splitCondition :: JS -> RWS () [(Int,JS)] Int JS
450+ | JSCond branches <- js =
451+ JSCond <$> processBranches branches
452+ | JSSwitch cond branches def <- js =
453+ JSSwitch cond <$> (processBranches branches) <*> (traverse splitSequence def)
454+ | otherwise = return js
456+ processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
458+ traverse (runKleisli (arr id *** (Kleisli splitSequence)))
460+ splitSequence :: JS -> RWS () [(Int, JS)] Int JS
461+ splitSequence js@(JSSeq seq) = do
462+ let (pre,post) = break isCall seq in
464+ [] -> JSSeq <$> traverse splitCondition seq
465+ [js@(JSCond _)] -> splitCondition js
466+ [js@(JSSwitch _ _ _)] -> splitCondition js
471+ new <- splitFunction (newFun rest)
473+ return $ JSSeq (pre ++ (newCall depth : [call]))
475+ splitSequence js = return js
477+ isCall :: JS -> Bool
478+ isCall (JSApp (JSIdent "i$CALL") _) = True
481+ newCall :: Int -> JS
483+ JSApp (JSIdent "i$CALL") [ JSIdent $ name ++ "$" ++ show depth
484+ , JSArray [jsOLDBASE, jsMYOLDBASE]
487+ newFun :: [JS] -> JS
489+ JSAlloc name (Just $ JSFunction ["oldbase", "myoldbase"] (JSSeq seq))
491+splitFunction js = return js
493+translateDecl :: CompileInfo -> (Name, [BC]) -> [JS]
494+translateDecl info (name@(MN 0 fun), bc)
495+ | txt "APPLY" == fun =
496+ allocCaseFunctions (snd body)
499+ ) (Just $ JSFunction ["oldbase"] (
500+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
501+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
502+ , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [jsOLDBASE, jsMYOLDBASE]
505+ , JSSeq $ map (translateBC info) (defaultCase (snd body))
513+ | txt "EVAL" == fun =
514+ allocCaseFunctions (snd body)
517+ ) (Just $ JSFunction ["oldbase"] (
518+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
519+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
520+ , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [jsOLDBASE, jsMYOLDBASE]
523+ , JSSeq $ map (translateBC info) (defaultCase (snd body))
531+ body :: ([BC], [BC])
532+ body = break isCase bc
534+ isCase :: BC -> Bool
536+ | CASE _ _ _ _ <- bc = True
345−jsError :: String -> JS
539+ defaultCase :: [BC] -> [BC]
346−jsError err = JSApp (JSFunction [] (JSError err)) []
540+ defaultCase ((CASE _ _ _ (Just d)):_) = d
348−jsUnPackBits :: JS -> JS
542+ caseReg :: [BC] -> Reg
349−jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
543+ caseReg ((CASE _ r _ _):_) = r
545+ allocCaseFunctions :: [BC] -> [JS]
546+ allocCaseFunctions ((CASE _ _ c _):_) = splitBranches c
547+ allocCaseFunctions _ = []
352−jsPackUBits8 :: JS -> JS
549+ splitBranches :: [(Int, [BC])] -> [JS]
353−jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
550+ splitBranches = map prepBranch
355−jsPackUBits16 :: JS -> JS
552+ prepBranch :: (Int, [BC]) -> JS
356−jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
553+ prepBranch (tag, code) =
555+ translateName name ++ "$" ++ show tag
556+ ) (Just $ JSFunction ["oldbase", "myoldbase"] (
557+ JSSeq $ map (translateBC info) code
358−jsPackUBits32 :: JS -> JS
561+translateDecl info (name, bc) =
359−jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
562+ [ JSAlloc (
564+ ) (Just $ JSFunction ["oldbase"] (
565+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info)bc
361−jsPackSBits8 :: JS -> JS
362−jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
364−jsPackSBits16 :: JS -> JS
571+translateReg :: Reg -> JS
365−jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
572+translateReg reg
573+ | RVal <- reg = jsRET
574+ | Tmp <- reg = JSProj (JSIdent "vm") "reg1"
575+ | L n <- reg = jsLOC n
576+ | T n <- reg = jsTOP n
367−jsPackSBits32 :: JS -> JS
578+translateConstant :: Const -> JS
368−jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
579+translateConstant (I i) = JSNum (JSInt i)
580+translateConstant (Fl f) = JSNum (JSFloat f)
581+translateConstant (Ch c) = JSString $ translateChar c
582+translateConstant (Str s) = JSString $ concatMap translateChar s
583+translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
584+translateConstant StrType = JSType JSStringTy
585+translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
586+translateConstant (AType ATFloat) = JSType JSFloatTy
587+translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
588+translateConstant PtrType = JSType JSPtrTy
589+translateConstant Forgot = JSType JSForgotTy
590+translateConstant (BI 0) = JSNum (JSInteger JSBigZero)
591+translateConstant (BI 1) = JSNum (JSInteger JSBigOne)
592+translateConstant (BI i) = jsBigInt (JSString $ show i)
593+translateConstant (B8 b) = JSWord (JSWord8 b)
594+translateConstant (B16 b) = JSWord (JSWord16 b)
595+translateConstant (B32 b) = JSWord (JSWord32 b)
596+translateConstant (B64 b) = JSWord (JSWord64 b)
597+translateConstant c =
598+ JSError $ "Unimplemented Constant: " ++ show c
371−foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
601+translateChar :: Char -> String
372−foldJS tr add acc js =
602+translateChar ch
373− fold js
603+ | '\a' <- ch = "\\u0007"
374− where
604+ | '\b' <- ch = "\\b"
375− fold js
605+ | '\f' <- ch = "\\f"
376− | JSFunction args body <- js =
606+ | '\n' <- ch = "\\n"
377− add (tr js) (fold body)
607+ | '\r' <- ch = "\\r"
378− | JSSeq seq <- js =
608+ | '\t' <- ch = "\\t"
379− add (tr js) $ foldl' add acc (map fold seq)
609+ | '\v' <- ch = "\\v"
380− | JSReturn ret <- js =
610+ | '\SO' <- ch = "\\u000E"
381− add (tr js) (fold ret)
611+ | '\DEL' <- ch = "\\u007F"
382− | JSApp lhs rhs <- js =
612+ | '\\' <- ch = "\\\\"
383− add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
613+ | '\"' <- ch = "\\\""
384− | JSNew _ args <- js =
614+ | '\'' <- ch = "\\\'"
385− add (tr js) $ foldl' add acc $ map fold args
615+ | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
386− | JSBinOp _ lhs rhs <- js =
616+ | otherwise = [ch]
387− add (tr js) $ add (fold lhs) (fold rhs)
388− | JSPreOp _ val <- js =
389− add (tr js) $ fold val
390− | JSPostOp _ val <- js =
391− add (tr js) $ fold val
392− | JSProj obj _ <- js =
393− add (tr js) (fold obj)
394− | JSArray vals <- js =
395− add (tr js) $ foldl' add acc $ map fold vals
396− | JSAssign lhs rhs <- js =
397− add (tr js) $ add (fold lhs) (fold rhs)
398− | JSIndex lhs rhs <- js =
399− add (tr js) $ add (fold lhs) (fold rhs)
400− | JSAlloc _ val <- js =
401− add (tr js) $ fromMaybe acc $ fmap fold val
402− | JSTernary c t f <- js =
403− add (tr js) $ add (fold c) (add (fold t) (fold f))
404− | JSParens val <- js =
405− add (tr js) $ fold val
406− | JSCond conds <- js =
407− add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
408− | JSWhile cond body <- js =
409− add (tr js) $ add (fold cond) (fold body)
410− | JSFFI raw args <- js =
411− add (tr js) $ foldl' add acc $ map fold args
412− | JSAnnotation a js <- js =
413− add (tr js) $ fold js
418−transformJS :: (JS -> JS) -> JS -> JS
422− transformHelper :: JS -> JS
424− | JSFunction args body <- js = JSFunction args $ tr body
425− | JSSeq seq <- js = JSSeq $ map tr seq
426− | JSReturn ret <- js = JSReturn $ tr ret
427− | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
428− | JSNew con args <- js = JSNew con $ map tr args
429− | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
430− | JSPreOp op val <- js = JSPreOp op (tr val)
431− | JSPostOp op val <- js = JSPostOp op (tr val)
432− | JSProj obj field <- js = JSProj (tr obj) field
433− | JSArray vals <- js = JSArray $ map tr vals
434− | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
435− | JSAlloc var val <- js = JSAlloc var $ fmap tr val
436− | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
437− | JSCond conds <- js = JSCond $ map (tr *** tr) conds
438− | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
439− | JSParens val <- js = JSParens $ tr val
440− | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
441− | JSFFI raw args <- js = JSFFI raw (map tr args)
442− | JSAnnotation a js <- js = JSAnnotation a (tr js)
446−moveJSDeclToTop :: String -> [JS] -> [JS]
447−moveJSDeclToTop decl js = move ([], js)
449− move :: ([JS], [JS]) -> [JS]
618+ fill :: String -> String
450− move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
619+ fill s = if length s == 1
451− | name == decl = js : front ++ back
620+ then '0' : s
453− move (front, js@(JSAlloc name _):back)
454− | name == decl = js : front ++ back
456− move (front, js:back) =
623+ asciiTab =
457− move (front ++ [js], back)
624+ ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
625+ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
626+ '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
627+ '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
629+translateName :: Name -> String
630+translateName n = "_idris_" ++ concatMap cchar (showCG n)
631+ where cchar x | isAlpha x || isDigit x = [x]
632+ | otherwise = "_" ++ show (fromEnum x) ++ "_"
460−jsSubst :: JS -> JS -> JS -> JS
634+jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
461−jsSubst var new old
635+jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
464−jsSubst (JSIdent var) new (JSVar old)
637+jsASSIGNCONST :: CompileInfo -> Reg -> Const -> JS
465− | var == translateVariableName old = new
638+jsASSIGNCONST _ r c = JSAssign (translateReg r) (translateConstant c)
466− | otherwise = JSVar old
468−jsSubst var new old@(JSIdent _)
640+jsCALL :: CompileInfo -> Name -> JS
469− | var == old = new
641+jsCALL _ n =
470− | otherwise = old
642+ JSApp (
644+ ) [JSIdent (translateName n), JSArray [jsMYOLDBASE]]
472−jsSubst var new (JSArray fields) =
646+jsTAILCALL :: CompileInfo -> Name -> JS
473− JSArray (map (jsSubst var new) fields)
647+jsTAILCALL _ n =
650+ ) [JSIdent (translateName n), JSArray [jsOLDBASE]]
652+jsFOREIGN :: CompileInfo -> Reg -> String -> [(FType, Reg)] -> JS
653+jsFOREIGN _ reg n args
655+ , [(FString, arg)] <- args =
659+ JSApp (JSIdent "i$putStr") [translateReg arg]
475−jsSubst var new (JSNew con vals) =
662+ | n == "isNull"
476− JSNew con $ map (jsSubst var new) vals
663+ , [(FPtr, arg)] <- args =
667+ JSBinOp "==" (translateReg arg) JSNull
478−jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
670+ | n == "idris_eqPtr"
479− | var `notElem` args =
671+ , [(_, lhs),(_, rhs)] <- args =
480− JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
672+ JSAssign (
481− map (jsSubst (JSIdent var) new) vals
673+ translateReg reg
675+ JSBinOp "==" (translateReg lhs) (translateReg rhs)
483 | otherwise =
677 | otherwise =
484− JSApp (JSProj (JSFunction args body) "apply") (
678+ JSAssign (
485− map (jsSubst (JSIdent var) new) vals
679+ translateReg reg
487−
681+ JSFFI n (map generateWrapper args)
488−jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
682+ )
489− | var /= arg =
683+ where
490− JSApp (JSFunction [arg] (
684+ generateWrapper :: (FType, Reg) -> JS
491− jsSubst (JSIdent var) new body
685+ generateWrapper (ty, reg)
492− )) $ map (jsSubst (JSIdent var) new) vals
686+ | FFunction <- ty =
687+ JSApp (JSIdent "i$ffiWrap") [ translateReg reg
689+ , JSIdent "myoldbase"
691+ | FFunctionIO <- ty =
692+ JSApp (JSIdent "i$ffiWrap") [ translateReg reg
694+ , JSIdent "myoldbase"
697+ generateWrapper (_, reg) =
700+jsREBASE :: CompileInfo -> JS
701+jsREBASE _ = JSAssign jsSTACKBASE jsOLDBASE
703+jsSTOREOLD :: CompileInfo ->JS
704+jsSTOREOLD _ = JSAssign jsMYOLDBASE jsSTACKBASE
706+jsADDTOP :: CompileInfo -> Int -> JS
493 | otherwise =
709 | otherwise =
494− JSApp (JSFunction [arg] (
710+ JSBinOp "+=" jsSTACKTOP (JSNum (JSInt n))
496− )) $ map (jsSubst (JSIdent var) new) vals
498−jsSubst var new js = transformJS (jsSubst var new) js
712+jsTOPBASE :: CompileInfo -> Int -> JS
713+jsTOPBASE _ 0 = JSAssign jsSTACKTOP jsSTACKBASE
714+jsTOPBASE _ n = JSAssign jsSTACKTOP (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
501−removeAllocations :: JS -> JS
717+jsBASETOP :: CompileInfo -> Int -> JS
502−removeAllocations (JSSeq body) =
718+jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP
503− let opt = removeHelper (map removeAllocations body) in
719+jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
508− removeHelper :: [JS] -> [JS]
509− removeHelper [js] = [js]
510− removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
511− map (jsSubst (JSIdent name) val) (removeHelper js)
512− removeHelper (j:js) = j : removeHelper js
514−removeAllocations js = transformJS removeAllocations js
517−isJSConstant :: JS -> Bool
519− | JSString _ <- js = True
520− | JSNum _ <- js = True
521− | JSType _ <- js = True
522− | JSNull <- js = True
523− | JSArray vals <- js = all isJSConstant vals
525− | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
529−isJSConstantConstructor :: [String] -> JS -> Bool
530−isJSConstantConstructor constants js
533− | JSArray vals <- js =
534− all (isJSConstantConstructor constants) vals
535− | JSNew "__IDRRT__Con" args <- js =
536− all (isJSConstantConstructor constants) args
537− | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
538− , name `elem` constants =
540− | JSIdent name <- js
541− , name `elem` constants =
547−inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
549− inlineJSLet :: JS -> JS
550− inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
551− | opt <- inlineJSLet val =
552− inlineJS $ jsSubst (JSIdent arg) opt ret
554− inlineJSLet js = transformJS inlineJSLet js
721+jsNULL :: CompileInfo -> Reg -> JS
722+jsNULL _ r = JSAssign (translateReg r) JSNull
724+jsERROR :: CompileInfo -> String -> JS
557− inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
727+jsSLIDE :: CompileInfo -> Int -> JS
558− | opt <- inlineCaseMatch val =
728+jsSLIDE _ n = JSApp (JSIdent "i$SLIDE") [JSNum (JSInt n)]
559− inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
561− inlineCaseMatch js = transformJS inlineCaseMatch js
730+jsMKCON :: CompileInfo -> Reg -> Int -> [Reg] -> JS
731+jsMKCON info r t rs =
732+ JSAssign (translateReg r) (
733+ JSNew "i$CON" [ JSNum (JSInt t)
734+ , JSArray (map translateReg rs)
735+ , if t `elem` compileInfoApplyCases info
736+ then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
738+ , if t `elem` compileInfoEvalCases info
739+ then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
744+jsInstanceOf :: JS -> String -> JS
745+jsInstanceOf obj cls = JSBinOp "instanceof" obj (JSIdent cls)
564− inlineApply js
747+jsOr :: JS -> JS -> JS
565− | JSApp (
748+jsOr lhs rhs = JSBinOp "||" lhs rhs
566− JSProj (JSFunction args (JSReturn body)) "apply"
567− ) [JSThis, JSProj var "vars"] <- js =
568− inlineApply $ inlineApply' var args body 0
570− JSProj (JSFunction args body@(JSCond _)) "apply"
571− ) [JSThis, JSProj var "vars"]) <- js =
572− inlineApply $ inlineApply' var args body 0
574− inlineApply' _ [] body _ = body
575− inlineApply' var (a:as) body n =
576− inlineApply' var as (
577− jsSubst (JSIdent a) (
578− JSIndex (JSProj var "vars") (JSNum (JSInt n))
582− inlineApply js = transformJS inlineApply js
750+jsAnd :: JS -> JS -> JS
751+jsAnd lhs rhs = JSBinOp "&&" lhs rhs
753+jsMeth :: JS -> String -> [JS] -> JS
754+jsMeth obj meth args = JSApp (JSProj obj meth) args
585− inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
756+jsCall :: String -> [JS] -> JS
586− inlineError error
757+jsCall fun args = JSApp (JSIdent fun) args
588− inlineError js = transformJS inlineError js
759+jsTypeOf :: JS -> JS
760+jsTypeOf js = JSPreOp "typeof " js
762+jsEq :: JS -> JS -> JS
763+jsEq lhs@(JSNum (JSInteger _)) rhs = JSApp (JSProj lhs "equals") [rhs]
764+jsEq lhs rhs@(JSNum (JSInteger _)) = JSApp (JSProj lhs "equals") [rhs]
765+jsEq lhs rhs = JSBinOp "==" lhs rhs
591− inlineAssign (JSAssign lhs rhs)
767+jsNotEq :: JS -> JS -> JS
592− | JSVar _ <- lhs
768+jsNotEq lhs rhs = JSBinOp "!=" lhs rhs
597− inlineAssign (JSAssign lhs rhs)
770+jsIsNumber :: JS -> JS
598− | JSIdent _ <- lhs
771+jsIsNumber js = (jsTypeOf js) `jsEq` (JSString "number")
603− inlineAssign js = transformJS inlineAssign js
773+jsIsNull :: JS -> JS
774+jsIsNull js = JSBinOp "==" js JSNull
777+jsBigInt (JSString "0") = JSNum (JSInteger JSBigZero)
778+jsBigInt (JSString "1") = JSNum (JSInteger JSBigOne)
779+jsBigInt js = JSNum $ JSInteger $ JSBigIntExpr js
606−removeEval :: [JS] -> [JS]
781+jsUnPackBits :: JS -> JS
607−removeEval js =
782+jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
608− let (ret, isReduced) = checkEval js in
610− then removeEvalApp ret
613− removeEvalApp js = catMaybes (map removeEvalApp' js)
615− removeEvalApp' :: JS -> Maybe JS
616− removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
617− removeEvalApp' js = Just $ transformJS match js
619− match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
620− match js = transformJS match js
622− checkEval :: [JS] -> ([JS], Bool)
623− checkEval js = foldr f ([], False) $ map checkEval' js
625− f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
626− f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
627− f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
784+jsPackUBits8 :: JS -> JS
785+jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
630− checkEval' :: JS -> (Maybe JS, Bool)
787+jsPackUBits16 :: JS -> JS
631− checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
788+jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
633− , JSReturn (JSIdent "t")
635− )) []))) = (Nothing, True)
637− checkEval' js = (Just js, False)
790+jsPackUBits32 :: JS -> JS
791+jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
793+jsPackSBits8 :: JS -> JS
794+jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
640−reduceJS :: [JS] -> [JS]
796+jsPackSBits16 :: JS -> JS
641−reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
797+jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
799+jsPackSBits32 :: JS -> JS
800+jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
644−funName :: JS -> String
802+jsCASE :: CompileInfo -> Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> JS
645−funName (JSAlloc fun _) = fun
803+jsCASE info safe reg cases def =
804+ JSSwitch (tag safe $ translateReg reg) (
805+ map ((JSNum . JSInt) *** prepBranch) cases
806+ ) (fmap prepBranch def)
808+ tag :: Bool -> JS -> JS
812+ prepBranch :: [BC] -> JS
813+ prepBranch bc = JSSeq $ map (translateBC info) bc
817+ (JSTernary (js `jsInstanceOf` "i$CON") (
819+ ) (JSNum (JSInt $ negate 1)))
822+ jsCTAG js = JSProj js "tag"
825+jsCONSTCASE :: CompileInfo -> Reg -> [(Const, [BC])] -> Maybe [BC] -> JS
826+jsCONSTCASE info reg cases def =
828+ map (jsEq (translateReg reg) . translateConstant *** prepBranch) cases
829+ ) ++ (maybe [] ((:[]) . ((,) JSNoop) . prepBranch) def)
831+ prepBranch :: [BC] -> JS
832+ prepBranch bc = JSSeq $ map (translateBC info) bc
834+jsPROJECT :: CompileInfo -> Reg -> Int -> Int -> JS
835+jsPROJECT _ reg loc ar =
836+ JSApp (JSIdent "i$PROJECT") [ translateReg reg
841+jsOP :: CompileInfo -> Reg -> PrimFn -> [Reg] -> JS
842+jsOP _ reg op args = JSAssign (translateReg reg) jsOP'
846+ | LNoOp <- op = translateReg (last args)
848+ | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ translateReg (last args)
849+ | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ translateReg (last args)
850+ | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ translateReg (last args)
852+ | (LZExt _ ITBig) <- op = jsBigInt $ JSApp (JSIdent "String") [translateReg (last args)]
853+ | (LPlus (ATInt ITBig)) <- op
854+ , (lhs:rhs:_) <- args = invokeMeth lhs "add" [rhs]
855+ | (LMinus (ATInt ITBig)) <- op
856+ , (lhs:rhs:_) <- args = invokeMeth lhs "subtract" [rhs]
857+ | (LTimes (ATInt ITBig)) <- op
858+ , (lhs:rhs:_) <- args = invokeMeth lhs "multiply" [rhs]
859+ | (LSDiv (ATInt ITBig)) <- op
860+ , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
861+ | (LSRem (ATInt ITBig)) <- op
862+ , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
863+ | (LEq (ATInt ITBig)) <- op
864+ , (lhs:rhs:_) <- args = invokeMeth lhs "equals" [rhs]
865+ | (LSLt (ATInt ITBig)) <- op
866+ , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
867+ | (LSLe (ATInt ITBig)) <- op
868+ , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
869+ | (LSGt (ATInt ITBig)) <- op
870+ , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
871+ | (LSGe (ATInt ITBig)) <- op
872+ , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
874+ | (LPlus ATFloat) <- op
875+ , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
876+ | (LMinus ATFloat) <- op
877+ , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
878+ | (LTimes ATFloat) <- op
879+ , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
880+ | (LSDiv ATFloat) <- op
881+ , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
882+ | (LEq ATFloat) <- op
883+ , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
884+ | (LSLt ATFloat) <- op
885+ , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
886+ | (LSLe ATFloat) <- op
887+ , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
888+ | (LSGt ATFloat) <- op
889+ , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
890+ | (LSGe ATFloat) <- op
891+ , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
893+ | (LPlus (ATInt ITChar)) <- op
894+ , (lhs:rhs:_) <- args =
895+ jsCall "i$fromCharCode" [
897+ jsCall "i$charCode" [translateReg lhs]
899+ jsCall "i$charCode" [translateReg rhs]
648−elimDeadLoop :: [JS] -> [JS]
903+ | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
649−elimDeadLoop js
904+ , (arg:_) <- args =
650− | ret <- deadEvalApplyCases js
905+ jsPackUBits8 (
651− , ret /= js = elimDeadLoop ret
906+ JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFF))
652− | otherwise = js
907+ )
909+ | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
912+ JSBinOp "&" (jsUnPackBits $ translateReg arg) (JSNum (JSInt 0xFFFF))
655−deadEvalApplyCases :: [JS] -> [JS]
915+ | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
656−deadEvalApplyCases js =
916+ , (arg:_) <- args =
657− let tags = sort $ nub $ concatMap (getTags) js in
917+ jsPackUBits32 (
658− map (removeHelper tags) js
918+ jsMeth (jsMeth (translateReg arg) "and" [
659− where
919+ jsBigInt (JSString $ show 0xFFFFFFFF)
660− getTags :: JS -> [Int]
920+ ]) "intValue" []
661− getTags = foldJS match (++) []
664− | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
668− removeHelper :: [Int] -> JS -> JS
669− removeHelper tags (JSAlloc fun (Just (
670− JSApp (JSFunction [] (JSSeq seq)) []))
672− (JSAlloc fun (Just (
673− JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
676− removeHelper _ js = js
923+ | (LTrunc ITBig (ITFixed IT64)) <- op
925+ jsMeth (translateReg arg) "and" [
926+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
929+ | (LLSHR (ITFixed IT8)) <- op
930+ , (lhs:rhs:_) <- args =
932+ JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
679− remover :: [Int] -> [JS] -> [JS]
935+ | (LLSHR (ITFixed IT16)) <- op
680− remover tags (
936+ , (lhs:rhs:_) <- args =
681− j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
937+ jsPackUBits16 (
938+ JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
683− | tag `notElem` tags = remover tags js
685− remover tags (j:js) = j : remover tags js
941+ | (LLSHR (ITFixed IT32)) <- op
686− remover _ [] = []
942+ , (lhs:rhs:_) <- args =
944+ JSBinOp ">>" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
947+ | (LLSHR (ITFixed IT64)) <- op
948+ , (lhs:rhs:_) <- args =
949+ jsMeth (translateReg lhs) "shiftRight" [translateReg rhs]
689−initConstructors :: [JS] -> [JS]
951+ | (LSHL (ITFixed IT8)) <- op
690−initConstructors js =
952+ , (lhs:rhs:_) <- args =
691− let tags = nub $ sort $ concat (map getTags js) in
953+ jsPackUBits8 (
692− rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
954+ JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
694− rearrangePrelude :: [JS] -> [JS]
695− rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
957+ | (LSHL (ITFixed IT16)) <- op
958+ , (lhs:rhs:_) <- args =
960+ JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
698− getTags :: JS -> [Int]
963+ | (LSHL (ITFixed IT32)) <- op
699− getTags = foldJS match (++) []
964+ , (lhs:rhs:_) <- args =
700− where
965+ jsPackUBits32 (
701− match js
966+ JSBinOp "<<" (jsUnPackBits $ translateReg lhs) (jsUnPackBits $ translateReg rhs)
702− | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
967+ )
969+ | (LSHL (ITFixed IT64)) <- op
970+ , (lhs:rhs:_) <- args =
971+ jsMeth (jsMeth (translateReg lhs) "shiftLeft" [translateReg rhs]) "and" [
972+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
706− replaceConstructors :: [Int] -> [JS] -> [JS]
975+ | (LAnd (ITFixed IT8)) <- op
707− replaceConstructors tags js = map (replaceHelper tags) js
976+ , (lhs:rhs:_) <- args =
708− where
977+ jsPackUBits8 (
709− replaceHelper :: [Int] -> JS -> JS
978+ JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
710− replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
979+ )
711− | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
713− replaceHelper tags js = transformJS (replaceHelper tags) js
981+ | (LAnd (ITFixed IT16)) <- op
982+ , (lhs:rhs:_) <- args =
984+ JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
987+ | (LAnd (ITFixed IT32)) <- op
988+ , (lhs:rhs:_) <- args =
990+ JSBinOp "&" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
716− createConstant :: Int -> JS
993+ | (LAnd (ITFixed IT64)) <- op
717− createConstant tag =
994+ , (lhs:rhs:_) <- args =
718− JSAlloc (idrCTRNamespace ++ show tag) (Just (
995+ jsMeth (translateReg lhs) "and" [translateReg rhs]
719− JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
997+ | (LOr (ITFixed IT8)) <- op
998+ , (lhs:rhs:_) <- args =
1000+ JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
723−removeIDs :: [JS] -> [JS]
1003+ | (LOr (ITFixed IT16)) <- op
724−removeIDs js =
1004+ , (lhs:rhs:_) <- args =
725− case partition isID js of
1005+ jsPackUBits16 (
726− ([], rest) -> rest
1006+ JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
727− (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
1007+ )
728− where isID :: JS -> Bool
729− isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
730− | JSReturn (JSVar _) <- last body = True
732− isID _ = False
1009+ | (LOr (ITFixed IT32)) <- op
1010+ , (lhs:rhs:_) <- args =
1012+ JSBinOp "|" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1015+ | (LOr (ITFixed IT64)) <- op
1016+ , (lhs:rhs:_) <- args =
1017+ jsMeth (translateReg lhs) "or" [translateReg rhs]
735− idFor :: JS -> (String, Int)
1019+ | (LXOr (ITFixed IT8)) <- op
736− idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1020+ , (lhs:rhs:_) <- args =
737− | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
1021+ jsPackUBits8 (
1022+ JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1025+ | (LXOr (ITFixed IT16)) <- op
1026+ , (lhs:rhs:_) <- args =
1028+ JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
740− removeIDCall :: [(String, Int)] -> JS -> JS
1031+ | (LXOr (ITFixed IT32)) <- op
741− removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1032+ , (lhs:rhs:_) <- args =
742− JSReturn (JSApp (JSIdent fun) args)
1033+ jsPackUBits32 (
743− )])
1034+ JSBinOp "^" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
744− | Just pos <- lookup fun ids
1035+ )
745− , pos < length args = removeIDCall ids (args !! pos)
747− removeIDCall ids (JSNew _ [JSFunction [] (
1037+ | (LXOr (ITFixed IT64)) <- op
748− JSReturn (JSApp (JSIdent fun) args)
1038+ , (lhs:rhs:_) <- args =
749− )])
1039+ jsMeth (translateReg lhs) "xor" [translateReg rhs]
750− | Just pos <- lookup fun ids
751− , pos < length args = removeIDCall ids (args !! pos)
753− removeIDCall ids js@(JSApp id@(JSIdent fun) args)
1041+ | (LPlus (ATInt (ITFixed IT8))) <- op
754− | Just pos <- lookup fun ids
1042+ , (lhs:rhs:_) <- args =
755− , pos < length args = removeIDCall ids (args !! pos)
1043+ jsPackUBits8 (
1044+ JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
757− removeIDCall ids js = transformJS (removeIDCall ids) js
1047+ | (LPlus (ATInt (ITFixed IT16))) <- op
1048+ , (lhs:rhs:_) <- args =
1050+ JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1053+ | (LPlus (ATInt (ITFixed IT32))) <- op
1054+ , (lhs:rhs:_) <- args =
1056+ JSBinOp "+" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
760−inlineFunction :: String -> [String] -> JS -> JS -> JS
1059+ | (LPlus (ATInt (ITFixed IT64))) <- op
761−inlineFunction fun args body js = inline' js
1060+ , (lhs:rhs:_) <- args =
762− where
1061+ jsMeth (jsMeth (translateReg lhs) "add" [translateReg rhs]) "and" [
763− inline' :: JS -> JS
1062+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
764− inline' (JSApp (JSIdent name) vals)
1063+ ]
766− let (js, phs) = insertPlaceHolders args body in
767− inline' $ foldr (uncurry jsSubst) js (zip phs vals)
769− inline' js = transformJS inline' js
1065+ | (LMinus (ATInt (ITFixed IT8))) <- op
1066+ , (lhs:rhs:_) <- args =
1068+ JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
771− insertPlaceHolders :: [String] -> JS -> (JS, [JS])
1071+ | (LMinus (ATInt (ITFixed IT16))) <- op
772− insertPlaceHolders args body = insertPlaceHolders' args body []
1072+ , (lhs:rhs:_) <- args =
773− where
1073+ jsPackUBits16 (
774− insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
1074+ JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
775− insertPlaceHolders' (a:as) body ph
1075+ )
776− | (body', ph') <- insertPlaceHolders' as body ph =
777− let phvar = JSIdent $ "__PH_" ++ show (length ph') in
778− (jsSubst (JSIdent a) phvar body', phvar : ph')
780− insertPlaceHolders' [] body ph = (body, ph)
1077+ | (LMinus (ATInt (ITFixed IT32))) <- op
1078+ , (lhs:rhs:_) <- args =
1080+ JSBinOp "-" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1083+ | (LMinus (ATInt (ITFixed IT64))) <- op
1084+ , (lhs:rhs:_) <- args =
1085+ jsMeth (jsMeth (translateReg lhs) "subtract" [translateReg rhs]) "and" [
1086+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
783−inlineFunctions :: [JS] -> [JS]
1089+ | (LTimes (ATInt (ITFixed IT8))) <- op
784−inlineFunctions js =
1090+ , (lhs:rhs:_) <- args =
785− inlineHelper ([], js)
1091+ jsPackUBits8 (
786− where
1092+ JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
787− inlineHelper :: ([JS], [JS]) -> [JS]
1093+ )
788− inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
789− | countAll fun front + countAll fun back == 0 =
790− inlineHelper (front, back)
791− | Just new <- inlineAble (
792− countAll fun front + countAll fun back
794− let f = map (inlineFunction fun args new) in
795− inlineHelper (f front, f back)
797− inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
1095+ | (LTimes (ATInt (ITFixed IT16))) <- op
798− inlineHelper (front, []) = front
1096+ , (lhs:rhs:_) <- args =
1098+ JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1101+ | (LTimes (ATInt (ITFixed IT32))) <- op
1102+ , (lhs:rhs:_) <- args =
1104+ JSBinOp "*" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
801− inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
1107+ | (LTimes (ATInt (ITFixed IT64))) <- op
802− inlineAble 1 fun args (JSReturn body)
1108+ , (lhs:rhs:_) <- args =
803− | nonRecur fun body =
1109+ jsMeth (jsMeth (translateReg lhs) "multiply" [translateReg rhs]) "and" [
804− if all (<= 1) (map ($ body) (map countIDOccurences args))
1110+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
805− then Just body
1111+ ]
808− inlineAble _ _ _ _ = Nothing
1113+ | (LEq (ATInt (ITFixed IT8))) <- op
1114+ , (lhs:rhs:_) <- args =
1116+ JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1119+ | (LEq (ATInt (ITFixed IT16))) <- op
1120+ , (lhs:rhs:_) <- args =
1122+ JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
811− nonRecur :: String -> JS -> Bool
1125+ | (LEq (ATInt (ITFixed IT32))) <- op
812− nonRecur name body = countInvokations name body == 0
1126+ , (lhs:rhs:_) <- args =
1128+ JSBinOp "==" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1131+ | (LEq (ATInt (ITFixed IT64))) <- op
1132+ , (lhs:rhs:_) <- args =
1133+ jsMeth (jsMeth (translateReg lhs) "equals" [translateReg rhs]) "and" [
1134+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
815− countAll :: String -> [JS] -> Int
1137+ | (LLt (ITFixed IT8)) <- op
816− countAll name js = sum $ map (countInvokations name) js
1138+ , (lhs:rhs:_) <- args =
1140+ JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1143+ | (LLt (ITFixed IT16)) <- op
1144+ , (lhs:rhs:_) <- args =
1146+ JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
819− countIDOccurences :: String -> JS -> Int
1149+ | (LLt (ITFixed IT32)) <- op
820− countIDOccurences name = foldJS match (+) 0
1150+ , (lhs:rhs:_) <- args =
821− where
1151+ jsPackUBits32 (
822− match :: JS -> Int
1152+ JSBinOp "<" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
824− | JSIdent ident <- js
1155+ | (LLt (ITFixed IT64)) <- op
1156+ , (lhs:rhs:_) <- args = invokeMeth lhs "lesser" [rhs]
829− countInvokations :: String -> JS -> Int
1158+ | (LLe (ITFixed IT8)) <- op
830− countInvokations name = foldJS match (+) 0
1159+ , (lhs:rhs:_) <- args =
831− where
1160+ jsPackUBits8 (
832− match :: JS -> Int
1161+ JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
834− | JSApp (JSIdent ident) _ <- js
1164+ | (LLe (ITFixed IT16)) <- op
1165+ , (lhs:rhs:_) <- args =
1167+ JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
841−reduceContinuations :: JS -> JS
1170+ | (LLe (ITFixed IT32)) <- op
842−reduceContinuations = inlineTC . reduceJS
1171+ , (lhs:rhs:_) <- args =
843− where
1172+ jsPackUBits32 (
844− reduceJS :: JS -> JS
1173+ JSBinOp "<=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
845− reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
1174+ )
846− JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
849− reduceJS js = transformJS reduceJS js
1176+ | (LLe (ITFixed IT64)) <- op
1177+ , (lhs:rhs:_) <- args = invokeMeth lhs "lesserOrEquals" [rhs]
1179+ | (LGt (ITFixed IT8)) <- op
1180+ , (lhs:rhs:_) <- args =
1182+ JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
852− inlineTC :: JS -> JS
1185+ | (LGt (ITFixed IT16)) <- op
853− inlineTC js
1186+ , (lhs:rhs:_) <- args =
854− | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1187+ jsPackUBits16 (
855− JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
1188+ JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
856− JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1189+ )
857− JSReturn (JSNew "__IDRRT__Cont" _)
1190+ | (LGt (ITFixed IT32)) <- op
858− )])
1191+ , (lhs:rhs:_) <- args =
859− )])
1192+ jsPackUBits32 (
860− )] <- js = inlineTC ret
1193+ JSBinOp ">" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
862− inlineTC js = transformJS inlineTC js
1196+ | (LGt (ITFixed IT64)) <- op
1197+ , (lhs:rhs:_) <- args = invokeMeth lhs "greater" [rhs]
1199+ | (LGe (ITFixed IT8)) <- op
1200+ , (lhs:rhs:_) <- args =
1202+ JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1205+ | (LGe (ITFixed IT16)) <- op
1206+ , (lhs:rhs:_) <- args =
1208+ JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1210+ | (LGe (ITFixed IT32)) <- op
1211+ , (lhs:rhs:_) <- args =
1213+ JSBinOp ">=" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
1216+ | (LGe (ITFixed IT64)) <- op
1217+ , (lhs:rhs:_) <- args = invokeMeth lhs "greaterOrEquals" [rhs]
867−reduceConstant :: JS -> JS
1219+ | (LUDiv (ITFixed IT8)) <- op
869− (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
870− JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
872− | JSNum num <- val = val
873− | JSBinOp op lhs rhs <- val =
1220+ , (lhs:rhs:_) <- args =
874− JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
1221+ jsPackUBits8 (
1222+ JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
876− | JSApp (JSProj lhs op) [rhs] <- val
1225+ | (LUDiv (ITFixed IT16)) <- op
877− , op `elem` [ "subtract"
1226+ , (lhs:rhs:_) <- args =
878− , "add"
1227+ jsPackUBits16 (
879− , "multiply"
1228+ JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
889−reduceConstant (JSApp ident [(JSParens js)]) =
1231+ | (LUDiv (ITFixed IT32)) <- op
890− JSApp ident [reduceConstant js]
1232+ , (lhs:rhs:_) <- args =
1234+ JSBinOp "/" (jsUnPackBits (translateReg lhs)) (jsUnPackBits (translateReg rhs))
892−reduceConstant js = transformJS reduceConstant js
1237+ | (LUDiv (ITFixed IT64)) <- op
1238+ , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
1240+ | (LSDiv (ATInt (ITFixed IT8))) <- op
1241+ , (lhs:rhs:_) <- args =
1244+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1246+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
895−reduceConstants :: JS -> JS
1250+ | (LSDiv (ATInt (ITFixed IT16))) <- op
896−reduceConstants js
1251+ , (lhs:rhs:_) <- args =
897− | ret <- reduceConstant js
1252+ jsPackSBits16 (
898− , ret /= js = reduceConstants ret
1253+ JSBinOp "/" (
899− | otherwise = js
1254+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1256+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
1260+ | (LSDiv (ATInt (ITFixed IT32))) <- op
1261+ , (lhs:rhs:_) <- args =
1264+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
1266+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
902−elimDuplicateEvals :: JS -> JS
1270+ | (LSDiv (ATInt (ITFixed IT64))) <- op
903−elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
1271+ , (lhs:rhs:_) <- args = invokeMeth lhs "divide" [rhs]
904− JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
906− elimHelper :: [JS] -> [JS]
907− elimHelper (j@(JSAlloc var (Just val)):js) =
908− j : map (jsSubst val (JSIdent var)) (elimHelper js)
913−elimDuplicateEvals js = js
1273+ | (LSRem (ATInt (ITFixed IT8))) <- op
1274+ , (lhs:rhs:_) <- args =
1277+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg lhs)
1279+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (translateReg rhs)
1283+ | (LSRem (ATInt (ITFixed IT16))) <- op
1284+ , (lhs:rhs:_) <- args =
1287+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg lhs)
1289+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (translateReg rhs)
916−optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
1293+ | (LSRem (ATInt (ITFixed IT32))) <- op
917−optimizeRuntimeCalls fun tc js =
1294+ , (lhs:rhs:_) <- args =
918− optTC tc : map optHelper js
1295+ jsPackSBits32 (
919− where
1296+ JSBinOp "%" (
920− optHelper :: JS -> JS
1297+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg lhs)
921− optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
922− JSFunction [] (JSReturn (JSApp (JSIdent n) args))
924− | n == fun = JSApp (JSIdent tc) $ map optHelper args
926− optHelper js = transformJS optHelper js
929− optTC :: String -> JS
930− optTC tc@"__IDRRT__EVALTC" =
931− JSAlloc tc (Just $ JSFunction ["arg0"] (
932− JSSeq [ JSAlloc "ret" $ Just (
934− (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
935− (hasProp "__IDRLT__EVAL" "arg0")
938− (JSIdent "__IDRLT__EVAL")
939− (JSProj (JSIdent "arg0") "tag")
944− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
945− JSAssign (JSIdent "ret") (
946− JSApp (JSProj (JSIdent "ret") "k") []
949− , JSReturn $ JSIdent "ret"
953− optTC tc@"__IDRRT__APPLYTC" =
954− JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
955− JSSeq [ JSAlloc "ret" $ Just (
957− (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
958− (hasProp "__IDRLT__APPLY" "fn0")
961− (JSIdent "__IDRLT__APPLY")
962− (JSProj (JSIdent "fn0") "tag")
964− [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
967− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
968− JSAssign (JSIdent "ret") (
969− JSApp (JSProj (JSIdent "ret") "k") []
972− , JSReturn $ JSIdent "ret"
977− hasProp :: String -> String -> JS
979− JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
982−unfoldLookupTable :: [JS] -> [JS]
983−unfoldLookupTable input =
984− let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
985− (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
987− adaptRuntime $ expandCons evals applys js
989− adaptRuntime :: [JS] -> [JS]
991− adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
994− adaptApply :: [JS] -> [JS]
995− adaptApply js = adaptApply' [] js
997− adaptApply' :: [JS] -> [JS] -> [JS]
998− adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
1001− adaptApply' front (next:back) =
1002− adaptApply' (front ++ [next]) back
1004− adaptApply' front [] = front
1007− JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
1009− (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1010− (JSProj (JSIdent "mfn0") "app")
1012− (JSProj (JSIdent "mfn0") "app")
1013− [JSIdent "mfn0", JSIdent "marg0"]
1019− adaptApplyTC :: [JS] -> [JS]
1020− adaptApplyTC js = adaptApplyTC' [] js
1022− adaptApplyTC' :: [JS] -> [JS] -> [JS]
1023− adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
1024− front ++ (new:back)
1026− adaptApplyTC' front (next:back) =
1027− adaptApplyTC' (front ++ [next]) back
1029− adaptApplyTC' front [] = front
1032− JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
1033− JSSeq [ JSAlloc "ret" $ Just (
1035− (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1036− (JSProj (JSIdent "mfn0") "app")
1038− (JSProj (JSIdent "mfn0") "app")
1039− [JSIdent "mfn0", JSIdent "marg0"]
1042− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1043− JSAssign (JSIdent "ret") (
1044− JSApp (JSProj (JSIdent "ret") "k") []
1047− , JSReturn $ JSIdent "ret"
1052− adaptEval :: [JS] -> [JS]
1053− adaptEval js = adaptEval' [] js
1055− adaptEval' :: [JS] -> [JS] -> [JS]
1056− adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
1057− front ++ (new:back)
1059− adaptEval' front (next:back) =
1060− adaptEval' (front ++ [next]) back
1062− adaptEval' front [] = front
1065− JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
1067− (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1068− (JSProj (JSIdent "marg0") "eval")
1070− (JSProj (JSIdent "marg0") "eval")
1072− ) (JSIdent "marg0")
1077− adaptEvalTC :: [JS] -> [JS]
1078− adaptEvalTC js = adaptEvalTC' [] js
1080− adaptEvalTC' :: [JS] -> [JS] -> [JS]
1081− adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
1082− front ++ (new:back)
1084− adaptEvalTC' front (next:back) =
1085− adaptEvalTC' (front ++ [next]) back
1087− adaptEvalTC' front [] = front
1090− JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
1091− JSSeq [ JSAlloc "ret" $ Just (
1093− (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1094− (JSProj (JSIdent "marg0") "eval")
1096− (JSProj (JSIdent "marg0") "eval")
1098− ) (JSIdent "marg0")
1100− , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1101− JSAssign (JSIdent "ret") (
1102− JSApp (JSProj (JSIdent "ret") "k") []
1105− , JSReturn $ JSIdent "ret"
1113− adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
1114− front ++ (new:back)
1116− adaptCon' front (next:back) =
1117− adaptCon' (front ++ [next]) back
1119− adaptCon' front [] = front
1123− JSAnnotation JSConstructor $
1124− JSAlloc "__IDRRT__Con" (Just $
1125− JSFunction newArgs (
1126− JSSeq (map newVar newArgs)
1130− newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1131− newArgs = ["tag", "eval", "app", "vars"]
1134− unfoldLT :: String -> [JS] -> ([Int], [JS])
1136− let (table, code) = extractLT lt js
1137− expanded = expandLT lt table in
1138− (map fst expanded, map snd expanded ++ code)
1141− expandCons :: [Int] -> [Int] -> [JS] -> [JS]
1142− expandCons evals applys js =
1145− expandCons' :: JS -> JS
1146− expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
1147− | evalid <- getId "__IDRLT__EVAL" tag evals
1148− , applyid <- getId "__IDRLT__APPLY" tag applys =
1149− JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
1150− , maybe JSNull JSIdent evalid
1151− , maybe JSNull JSIdent applyid
1152− , JSArray (map expandCons' args)
1155− expandCons' js = transformJS expandCons' js
1158− getId :: String -> Int -> [Int] -> Maybe String
1159− getId lt tag entries
1160− | tag `elem` entries = Just $ ltIdentifier lt tag
1161− | otherwise = Nothing
1164− ltIdentifier :: String -> Int -> String
1165− ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
1166− ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
1169− extractLT :: String -> [JS] -> (JS, [JS])
1171− extractLT' ([], js)
1173− extractLT' :: ([JS], [JS]) -> (JS, [JS])
1174− extractLT' (front, js@(JSAlloc fun _):back)
1175− | fun == lt = (js, front ++ back)
1177− extractLT' (front, js:back) = extractLT' (front ++ [js], back)
1178− extractLT' (front, back) = (JSNoop, front ++ back)
1181− expandLT :: String -> JS -> [(Int, JS)]
1183− JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1184− ) = catMaybes (map expandEntry seq)
1186− expandEntry :: JS -> Maybe (Int, JS)
1187− expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
1188− Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
1190− expandEntry js = Nothing
1192− expandLT lt JSNoop = []
1195−removeInstanceChecks :: JS -> JS
1196−removeInstanceChecks (JSCond conds) =
1197− removeNoopConds $ JSCond $ eliminateDeadBranches $ map (
1198− removeHelper *** removeInstanceChecks
1202− JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
1203− ) = removeHelper check
1204− removeHelper js = js
1207− eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1208− eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
1209− eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1210− eliminateDeadBranches [] = []
1213− removeNoopConds :: JS -> JS
1214− removeNoopConds (JSCond [(JSNoop, js)]) = js
1215− removeNoopConds js = js
1217−removeInstanceChecks js = transformJS removeInstanceChecks js
1220−reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1221−reduceLoop reduced (cons, program) =
1222− case partition findConstructors program of
1223− ([], js) -> cons ++ js
1224− (candidates, rest) ->
1225− let names = reduced ++ map funName candidates in
1227− cons ++ map reduce candidates, map (reduceCall names) rest
1229− where findConstructors :: JS -> Bool
1230− findConstructors js
1231− | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
1232− reducable $ last body
1233− | otherwise = False
1234− where reducable :: JS -> Bool
1236− | JSReturn ret <- js = reducable ret
1237− | JSNew _ args <- js = and $ map reducable args
1238− | JSArray fields <- js = and $ map reducable fields
1239− | JSNum _ <- js = True
1240− | JSNull <- js = True
1241− | JSIdent _ <- js = True
1242− | otherwise = False
1246− reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1247− | JSReturn js <- last body = (JSAlloc fun (Just js))
1252− reduceCall :: [String] -> JS -> JS
1253− reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1254− JSReturn (JSApp id@(JSIdent ret) _)
1256− | ret `elem` funs = id
1258− reduceCall funs js@(JSApp id@(JSIdent fun) _)
1259− | fun `elem` funs = id
1261− reduceCall funs js = transformJS (reduceCall funs) js
1264−extractLocalConstructors :: [JS] -> [JS]
1265−extractLocalConstructors js =
1266− concatMap extractLocalConstructors' js
1268− globalCons :: [String]
1269− globalCons = concatMap (getGlobalCons) js
1272− extractLocalConstructors' :: JS -> [JS]
1273− extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1274− addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1277− cons = zipWith genName (foldJS match (++) [] body) [1..]
1279− genName :: JS -> Int -> (JS, JS)
1281− (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1283− match :: JS -> [JS]
1285− | JSNew "__IDRRT__Con" args <- js
1286− , all isConstant args = [js]
1290− addCons :: [(JS, JS)] -> [JS] -> [JS]
1292− addCons (con@(_, name):cons) js
1293− | sum (map (countOccur name) js) > 0 =
1294− addCons cons ((allocCon con) : js)
1299− countOccur :: JS -> JS -> Int
1300− countOccur ident js = foldJS match (+) 0 js
1308− allocCon :: (JS, JS) -> JS
1309− allocCon (js, JSIdent name) =
1310− JSAlloc name (Just js)
1313− isConstant :: JS -> Bool
1315− | JSNew "__IDRRT__Con" args <- js
1316− , all isConstant args =
1319− isJSConstantConstructor globalCons js
1321− extractLocalConstructors' js = [js]
1324− getGlobalCons :: JS -> [String]
1325− getGlobalCons js = foldJS match (++) [] js
1327− match :: JS -> [String]
1329− | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1335−evalCons :: [JS] -> [JS]
1337− map (collapseCont . collapseTC . expandProj . evalCons') js
1339− cons :: [(String, JS)]
1340− cons = concatMap getGlobalCons js
1342− evalCons' :: JS -> JS
1343− evalCons' js = transformJS match js
1346− match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1347− | JSIdent name <- arg
1348− , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1351− match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1352− | JSIdent name <- arg
1353− , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1356− match js = transformJS match js
1359− lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1360− lookupConstructor ctr cons
1361− | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1362− | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1363− | otherwise = Nothing
1366− expandProj :: JS -> JS
1367− expandProj js = transformJS match js
1372− JSProj (JSIdent name) "vars"
1374− JSNum (JSInt idx)
1299+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (translateReg rhs)
1377− | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1380− match js = transformJS match js
1383− collapseTC :: JS -> JS
1384− collapseTC js = transformJS match js
1387− match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1388− JSReturn (JSIdent name)
1390− | Just _ <- lookup name cons = (JSIdent name)
1392− match js = transformJS match js
1303+ | (LSRem (ATInt (ITFixed IT64))) <- op
1393−
1304+ , (lhs:rhs:_) <- args = invokeMeth lhs "mod" [rhs]
1395− collapseCont :: JS -> JS
1306+ | (LCompl (ITFixed IT8)) <- op
1396− collapseCont js = transformJS match js
1307+ , (arg:_) <- args =
1397− where
1308+ jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1398− match :: JS -> JS
1309+
1399− match (JSNew "__IDRRT__Cont" [JSFunction [] (
1310+ | (LCompl (ITFixed IT16)) <- op
1400− JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1311+ , (arg:_) <- args =
1401− )]) = collapseCont ret
1312+ jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1403−
1314+ | (LCompl (ITFixed IT32)) <- op
1404− match (JSNew "__IDRRT__Cont" [JSFunction [] (
1315+ , (arg:_) <- args =
1405− JSReturn (JSIdent name)
1316+ jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (translateReg arg)
1406− )]) = JSIdent name
1317+
1407−
1318+ | (LCompl (ITFixed IT64)) <- op
1408− match (JSNew "__IDRRT__Cont" [JSFunction [] (
1319+ , (arg:_) <- args =
1409− JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1320+ invokeMeth arg "not" []
1411− | all collapsable args = ret
1322+ | (LPlus _) <- op
1412− where
1323+ , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1413− collapsable :: JS -> Bool
1324+ | (LMinus _) <- op
1414− collapsable (JSIdent _) = True
1325+ , (lhs:rhs:_) <- args = translateBinaryOp "-" lhs rhs
1415− collapsable js = isJSConstantConstructor (map fst cons) js
1326+ | (LTimes _) <- op
1416−
1327+ , (lhs:rhs:_) <- args = translateBinaryOp "*" lhs rhs
1417−
1328+ | (LSDiv _) <- op
1418− match js = transformJS match js
1329+ , (lhs:rhs:_) <- args = translateBinaryOp "/" lhs rhs
1419−
1330+ | (LSRem _) <- op
1420−
1331+ , (lhs:rhs:_) <- args = translateBinaryOp "%" lhs rhs
1421−elimConds :: [JS] -> [JS]
1332+ | (LEq _) <- op
1422−elimConds js =
1333+ , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1423− let (conds, rest) = partition isCond js in
1334+ | (LSLt _) <- op
1424− foldl' eraseCond rest conds
1335+ , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1425− where
1336+ | (LSLe _) <- op
1426− isCond :: JS -> Bool
1337+ , (lhs:rhs:_) <- args = translateBinaryOp "<=" lhs rhs
1427− isCond (JSAlloc
1338+ | (LSGt _) <- op
1428− fun (Just (JSFunction args (JSCond
1339+ , (lhs:rhs:_) <- args = translateBinaryOp ">" lhs rhs
1429− [ (JSBinOp "==" (JSNum (JSInt tag)) (JSProj (JSIdent _) "tag"), JSReturn t)
1340+ | (LSGe _) <- op
1430− , (JSNoop, JSReturn f)
1341+ , (lhs:rhs:_) <- args = translateBinaryOp ">=" lhs rhs
1431− ])))
1342+ | (LAnd _) <- op
1432− )
1343+ , (lhs:rhs:_) <- args = translateBinaryOp "&" lhs rhs
1433− | isJSConstant t && isJSConstant f =
1344+ | (LOr _) <- op
1434− True
1345+ , (lhs:rhs:_) <- args = translateBinaryOp "|" lhs rhs
1435−
1346+ | (LXOr _) <- op
1436− | JSIdent _ <- t
1347+ , (lhs:rhs:_) <- args = translateBinaryOp "^" lhs rhs
1437− , JSIdent _ <- f =
1348+ | (LSHL _) <- op
1438− True
1349+ , (lhs:rhs:_) <- args = translateBinaryOp "<<" rhs lhs
1439−
1350+ | (LASHR _) <- op
1440− isCond (JSAlloc
1351+ , (lhs:rhs:_) <- args = translateBinaryOp ">>" rhs lhs
1441− fun (Just (JSFunction args (JSCond
1352+ | (LCompl _) <- op
1442− [ (JSBinOp "==" (JSIdent _) c, JSReturn t)
1353+ , (arg:_) <- args = JSPreOp "~" (translateReg arg)
1443− , (JSNoop, JSReturn f)
1354+
1444− ])))
1355+ | LStrConcat <- op
1445− )
1356+ , (lhs:rhs:_) <- args = translateBinaryOp "+" lhs rhs
1446− | isJSConstant t && isJSConstant f && isJSConstant c =
1357+ | LStrEq <- op
1447− True
1358+ , (lhs:rhs:_) <- args = translateBinaryOp "==" lhs rhs
1448−
1359+ | LStrLt <- op
1449− | JSIdent _ <- t
1360+ , (lhs:rhs:_) <- args = translateBinaryOp "<" lhs rhs
1450− , JSIdent _ <- f
1361+ | LStrLen <- op
1451− , isJSConstant c =
1362+ , (arg:_) <- args = JSProj (translateReg arg) "length"
1452− True
1363+ | (LStrInt ITNative) <- op
1453−
1364+ , (arg:_) <- args = jsCall "parseInt" [translateReg arg]
1454− isCond _ = False
1365+ | (LIntStr ITNative) <- op
1455−
1366+ , (arg:_) <- args = jsCall "String" [translateReg arg]
1456−
1367+ | (LSExt ITNative ITBig) <- op
1457− eraseCond :: [JS] -> JS -> [JS]
1368+ , (arg:_) <- args = jsBigInt $ jsCall "String" [translateReg arg]
1458− eraseCond js (JSAlloc
1369+ | (LTrunc ITBig ITNative) <- op
1459− fun (Just (JSFunction args (JSCond
1370+ , (arg:_) <- args = jsMeth (translateReg arg) "intValue" []
1460− [ (c, JSReturn t)
1371+ | (LIntStr ITBig) <- op
1461− , (_, JSReturn f)
1372+ , (arg:_) <- args = jsMeth (translateReg arg) "toString" []
1462− ])
1373+ | (LStrInt ITBig) <- op
1463− )
1374+ , (arg:_) <- args = jsBigInt $ translateReg arg
1464− )) = map (inlineFunction fun args (JSTernary c t f)) js
1375+ | LFloatStr <- op
1465−
1376+ , (arg:_) <- args = jsCall "String" [translateReg arg]
1466−
1377+ | LStrFloat <- op
1467−removeUselessCons :: [JS] -> [JS]
1378+ , (arg:_) <- args = jsCall "parseFloat" [translateReg arg]
1468−removeUselessCons js =
1379+ | (LIntFloat ITNative) <- op
1469− let (cons, rest) = partition isUseless js in
1380+ , (arg:_) <- args = translateReg arg
1470− foldl' eraseCon rest cons
1381+ | (LFloatInt ITNative) <- op
1471− where
1382+ , (arg:_) <- args = translateReg arg
1472− isUseless :: JS -> Bool
1383+ | (LChInt ITNative) <- op
1473− isUseless (JSAlloc fun (Just JSNull)) = True
1384+ , (arg:_) <- args = jsCall "i$charCode" [translateReg arg]
1474− isUseless (JSAlloc fun (Just (JSIdent _))) = True
1385+ | (LIntCh ITNative) <- op
1475− isUseless _ = False
1386+ , (arg:_) <- args = jsCall "i$fromCharCode" [translateReg arg]
1478− eraseCon :: [JS] -> JS -> [JS]
1389+ , (arg:_) <- args = jsCall "Math.exp" [translateReg arg]
1479− eraseCon js (JSAlloc fun (Just val)) = map (jsSubst (JSIdent fun) val) js
1390+ | LFLog <- op
1480−
1391+ , (arg:_) <- args = jsCall "Math.log" [translateReg arg]
1482−getGlobalCons :: JS -> [(String, JS)]
1393+ , (arg:_) <- args = jsCall "Math.sin" [translateReg arg]
1483−getGlobalCons js = foldJS match (++) [] js
1394+ | LFCos <- op
1484− where
1395+ , (arg:_) <- args = jsCall "Math.cos" [translateReg arg]
1485− match :: JS -> [(String, JS)]
1396+ | LFTan <- op
1486− match js
1397+ , (arg:_) <- args = jsCall "Math.tan" [translateReg arg]
1487− | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1398+ | LFASin <- op
1488− [(name, con)]
1399+ , (arg:_) <- args = jsCall "Math.asin" [translateReg arg]
1489− | (JSAlloc name (Just con@(JSIdent _))) <- js =
1400+ | LFACos <- op
1490− [(name, con)]
1401+ , (arg:_) <- args = jsCall "Math.acos" [translateReg arg]
1491− | otherwise =
1402+ | LFATan <- op
1492− []
1403+ , (arg:_) <- args = jsCall "Math.atan" [translateReg arg]
1493−
1404+ | LFSqrt <- op
1494−
1405+ , (arg:_) <- args = jsCall "Math.sqrt" [translateReg arg]
1495−getIncludes :: [FilePath] -> IO [String]
1406+ | LFFloor <- op
1496−getIncludes = mapM readFile
1407+ , (arg:_) <- args = jsCall "Math.floor" [translateReg arg]
1497−
1408+ | LFCeil <- op
1498−codegenJavaScript :: CodeGenerator
1409+ , (arg:_) <- args = jsCall "Math.ceil" [translateReg arg]
1499−codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
1410+
1500− (includes ci) (outputFile ci) (outputType ci)
1411+ | LStrCons <- op
1501−
1412+ , (lhs:rhs:_) <- args = invokeMeth lhs "concat" [rhs]
1502−codegenNode :: CodeGenerator
1413+ | LStrHead <- op
1503−codegenNode ci = codegenJS_all Node (simpleDecls ci)
1414+ , (arg:_) <- args = JSIndex (translateReg arg) (JSNum (JSInt 0))
1504− (includes ci) (outputFile ci) (outputType ci)
1415+ | LStrRev <- op
1505−
1416+ , (arg:_) <- args = JSProj (translateReg arg) "split('').reverse().join('')"
1506−codegenJS_all
1417+ | LStrIndex <- op
1507− :: JSTarget
1418+ , (lhs:rhs:_) <- args = JSIndex (translateReg lhs) (translateReg rhs)
1508− -> [(Name, SDecl)]
1419+ | LStrTail <- op
1509− -> [FilePath]
1420+ , (arg:_) <- args =
1510− -> FilePath
1421+ let v = translateReg arg in
1511− -> OutputType
1422+ JSApp (JSProj v "substr") [
1512− -> IO ()
1423+ JSNum (JSInt 1),
1513−codegenJS_all target definitions includes filename outputType = do
1424+ JSBinOp "-" (JSProj v "length") (JSNum (JSInt 1))
1514− let (header, rt) = case target of
1425+ ]
1516− ("#!/usr/bin/env node\n", "-node")
1519− included <- getIncludes includes
1520− path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1521− idrRuntime <- readFile $ path ++ "Runtime-common.js"
1522− tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
1523− jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1524− writeFile filename $ header ++ (
1525− intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions
1528− setPermissions filename (emptyPermissions { readable = True
1529− , executable = target == Node
1533− def :: [(String, SDecl)]
1534− def = map (first translateNamespace) definitions
1537− checkForBigInt :: [JS] -> Bool
1538− checkForBigInt js = occur
1541− occur = or $ map (foldJS match (||) False) js
1543− match :: JS -> Bool
1544− match (JSIdent "__IDRRT__bigInt") = True
1545− match (JSWord (JSWord64 _)) = True
1546− match (JSNum (JSInteger _)) = True
1550− runtime :: String -> String -> String -> [String]
1551− runtime jsbn idrRuntime tgtRuntime =
1552− if checkForBigInt optimized
1553− then [jsbn, idrRuntime, tgtRuntime]
1554− else [idrRuntime, tgtRuntime]
1558− optimized = translate >>> optimize $ def
1561− prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1563− foldl' (flip ($)) p opt
1570− , map reduceConstants
1572− , map removeAllocations
1574− , map elimDuplicateEvals
1575− , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1576− , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1577− , map removeInstanceChecks
1579− , map reduceContinuations
1580− , extractLocalConstructors
1581− , unfoldLookupTable
1584− , removeUselessCons
1587− functions :: [String]
1588− functions = map compileJS optimized
1592− [ JSAnnotation JSConstructor $
1593− JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1594− JSAssign (JSProj JSThis "k") (JSIdent "k")
1596− , JSAnnotation JSConstructor $
1597− JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1598− JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1599− , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1606− JSAlloc "main" $ Just $ JSFunction [] (
1609− JavaScript -> JSCond [ (exists document `jsAnd` isReady, mainFun)
1610− , (exists window, windowMainFun)
1611− , (JSTrue, mainFun)
1616− exists js = (JSPreOp "typeof " js) `jsNotEq` JSString "undefined"
1619− mainFun = jsTailcall $ jsCall runMain []
1622− window = JSIdent "window"
1625− document = JSIdent "document"
1627− windowMainFun :: JS
1628− windowMainFun = jsMeth window "addEventListener" [
1629− JSString "DOMContentLoaded"
1630− , JSFunction [] ( mainFun )
1635− isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1638− readyState = JSProj (JSIdent "document") "readyState"
1642− runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1646− invokeLoop = jsCall "main" []
1649−translateIdentifier :: String -> String
1650−translateIdentifier =
1651− replaceReserved . concatMap replaceBadChars
1652− where replaceBadChars :: Char -> String
1656− | isDigit c = '_' : show (ord c)
1657− | not (isLetter c && isAscii c) = '_' : show (ord c)
1660− | s `elem` reserved = '_' : s
1664− reserved = [ "break"
1710−translateNamespace :: Name -> String
1711−translateNamespace (UN _) = idrNamespace
1712−translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1713−translateNamespace (MN _ _) = idrNamespace
1714−translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1715−translateNamespace NErased = idrNamespace
1718−translateName :: Name -> String
1719−translateName (UN name) = 'u' : translateIdentifier (str name)
1720−translateName (NS name _) = 'n' : translateName name
1721−translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1722−translateName (SN name) = 's' : translateSpecialName name
1723−translateName NErased = "e"
1726−translateSpecialName :: SpecialName -> String
1727−translateSpecialName name
1728− | WhereN i m n <- name =
1729− 'w' : translateName m ++ translateName n ++ show i
1730− | InstanceN n s <- name =
1731− 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1732− | ParentN n s <- name =
1733− 'p' : translateName n ++ translateIdentifier (str s)
1734− | MethodN n <- name =
1735− 'm' : translateName n
1736− | CaseN n <- name =
1737− 'c' : translateName n
1740−translateConstant :: Const -> JS
1741−translateConstant (I i) = JSNum (JSInt i)
1742−translateConstant (Fl f) = JSNum (JSFloat f)
1743−translateConstant (Ch c) = JSString $ translateChar c
1744−translateConstant (Str s) = JSString $ concatMap translateChar s
1745−translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1746−translateConstant StrType = JSType JSStringTy
1747−translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1748−translateConstant (AType ATFloat) = JSType JSFloatTy
1749−translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1750−translateConstant PtrType = JSType JSPtrTy
1751−translateConstant Forgot = JSType JSForgotTy
1752−translateConstant (BI i) = jsBigInt $ JSString (show i)
1753−translateConstant (B8 b) = JSWord (JSWord8 b)
1754−translateConstant (B16 b) = JSWord (JSWord16 b)
1755−translateConstant (B32 b) = JSWord (JSWord32 b)
1756−translateConstant (B64 b) = JSWord (JSWord64 b)
1757−translateConstant c =
1758− jsError $ "Unimplemented Constant: " ++ show c
1761−translateChar :: Char -> String
1763− | '\a' <- ch = "\\u0007"
1764− | '\b' <- ch = "\\b"
1765− | '\f' <- ch = "\\f"
1766− | '\n' <- ch = "\\n"
1767− | '\r' <- ch = "\\r"
1768− | '\t' <- ch = "\\t"
1769− | '\v' <- ch = "\\v"
1770− | '\SO' <- ch = "\\u000E"
1771− | '\DEL' <- ch = "\\u007F"
1772− | '\\' <- ch = "\\\\"
1773− | '\"' <- ch = "\\\""
1774− | '\'' <- ch = "\\\'"
1775− | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1778− fill :: String -> String
1779− fill s = if length s == 1
1784− ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1785− '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1786− '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1787− '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1790−translateDeclaration :: (String, SDecl) -> [JS]
1791−translateDeclaration (path, SFun name params stackSize body)
1792− | (MN _ ap) <- name
1793− , (SChkCase var cases) <- body
1794− , ap == txt "APPLY" =
1795− [ lookupTable "APPLY" [] var cases
1796− , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1798− (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1799− (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1802− (JSIdent (idrLTNamespace ++ "APPLY"))
1803− (JSProj (JSIdent "mfn0") "tag")
1805− [JSIdent "mfn0", JSIdent "marg0"]
1810− | (MN _ ev) <- name
1811− , (SChkCase var cases) <- body
1812− , ev == txt "EVAL" =
1813− [ lookupTable "EVAL" [] var cases
1814− , jsDecl $ JSFunction ["marg0"] (JSReturn $
1816− (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1817− (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1820− (JSIdent (idrLTNamespace ++ "EVAL"))
1821− (JSProj (JSIdent "marg0") "tag")
1824− ) (JSIdent "marg0")
1828− let fun = translateExpression body in
1829− [jsDecl $ jsFun fun]
1832− hasProp :: String -> String -> JS
1833− hasProp table var =
1834− JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1837− caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1838− caseFun aux var cse =
1839− let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1843− getTag :: SAlt -> Maybe Int
1844− getTag (SConCase _ tag _ _ _) = Just tag
1848− lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1849− lookupTable table aux var cases =
1850− JSAlloc (idrLTNamespace ++ table) $ Just (
1851− JSApp (JSFunction [] (
1853− JSAlloc "t" $ Just (JSArray [])
1854− ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1855− JSReturn (JSIdent "t")
1860− assignEntries :: [(Int, JS)] -> [JS]
1861− assignEntries entries =
1862− map (\(tag, fun) ->
1863− JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1867− lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1868− lookupEntry aux var alt = do
1870− return (tag, caseFun aux var alt)
1874− jsDecl = JSAlloc (path ++ translateName name) . Just
1877− jsFun body = jsFunAux [] body
1880− jsFunAux :: [(LVar, String)] -> JS -> JS
1881− jsFunAux aux body =
1882− JSFunction (p ++ map snd aux) (
1884− zipWith assignVar [0..] p ++
1885− map assignAux aux ++
1889− assignVar :: Int -> String -> JS
1890− assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1893− assignAux :: (LVar, String) -> JS
1894− assignAux (Loc var, val) =
1895− JSAlloc (jsVar var) (Just $ JSIdent val)
1899− p = map translateName params
1902−translateVariableName :: LVar -> String
1903−translateVariableName (Loc i) =
1907−translateExpression :: SExp -> JS
1908−translateExpression (SLet name value body) =
1909− jsLet (translateVariableName name) (
1910− translateExpression value
1911− ) (translateExpression body)
1913−translateExpression (SConst cst) =
1914− translateConstant cst
1916−translateExpression (SV var) =
1919−translateExpression (SApp tc name vars)
1921− jsTailcall $ translateFunctionCall name vars
1923− JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1924− JSReturn $ translateFunctionCall name vars
1927− translateFunctionCall name vars =
1928− jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1930−translateExpression (SOp op vars)
1931− | LNoOp <- op = JSVar (last vars)
1933− | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1934− | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1935− | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ JSVar (last vars)
1937− | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1938− | (LPlus (ATInt ITBig)) <- op
1939− , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1940− | (LMinus (ATInt ITBig)) <- op
1941− , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1942− | (LTimes (ATInt ITBig)) <- op
1943− , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1944− | (LSDiv (ATInt ITBig)) <- op
1945− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1946− | (LSRem (ATInt ITBig)) <- op
1947− , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1948− | (LEq (ATInt ITBig)) <- op
1949− , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1950− | (LSLt (ATInt ITBig)) <- op
1951− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1952− | (LSLe (ATInt ITBig)) <- op
1953− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1954− | (LSGt (ATInt ITBig)) <- op
1955− , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1956− | (LSGe (ATInt ITBig)) <- op
1957− , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1959− | (LPlus ATFloat) <- op
1960− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1961− | (LMinus ATFloat) <- op
1962− , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1963− | (LTimes ATFloat) <- op
1964− , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1965− | (LSDiv ATFloat) <- op
1966− , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1967− | (LEq ATFloat) <- op
1968− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1969− | (LSLt ATFloat) <- op
1970− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1971− | (LSLe ATFloat) <- op
1972− , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1973− | (LSGt ATFloat) <- op
1974− , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1975− | (LSGe ATFloat) <- op
1976− , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1978− | (LPlus (ATInt ITChar)) <- op
1979− , (lhs:rhs:_) <- vars =
1980− jsCall "__IDRRT__fromCharCode" [
1982− jsCall "__IDRRT__charCode" [JSVar lhs]
1984− jsCall "__IDRRT__charCode" [JSVar rhs]
1988− | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1989− , (arg:_) <- vars =
1991− JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFF))
1994− | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1995− , (arg:_) <- vars =
1997− JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFFFF))
2000− | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
2001− , (arg:_) <- vars =
2003− jsMeth (jsMeth (JSVar arg) "and" [
2004− jsBigInt (JSString $ show 0xFFFFFFFF)
2008− | (LTrunc ITBig (ITFixed IT64)) <- op
2009− , (arg:_) <- vars =
2010− jsMeth (JSVar arg) "and" [
2011− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2014− | (LLSHR (ITFixed IT8)) <- op
2015− , (lhs:rhs:_) <- vars =
2017− JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2020− | (LLSHR (ITFixed IT16)) <- op
2021− , (lhs:rhs:_) <- vars =
2023− JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2026− | (LLSHR (ITFixed IT32)) <- op
2027− , (lhs:rhs:_) <- vars =
2029− JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2032− | (LLSHR (ITFixed IT64)) <- op
2033− , (lhs:rhs:_) <- vars =
2034− jsMeth (JSVar lhs) "shiftRight" [JSVar rhs]
2036− | (LSHL (ITFixed IT8)) <- op
2037− , (lhs:rhs:_) <- vars =
2039− JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2042− | (LSHL (ITFixed IT16)) <- op
2043− , (lhs:rhs:_) <- vars =
2045− JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2048− | (LSHL (ITFixed IT32)) <- op
2049− , (lhs:rhs:_) <- vars =
2051− JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2054− | (LSHL (ITFixed IT64)) <- op
2055− , (lhs:rhs:_) <- vars =
2056− jsMeth (jsMeth (JSVar lhs) "shiftLeft" [JSVar rhs]) "and" [
2057− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2060− | (LAnd (ITFixed IT8)) <- op
2061− , (lhs:rhs:_) <- vars =
2063− JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2066− | (LAnd (ITFixed IT16)) <- op
2067− , (lhs:rhs:_) <- vars =
2069− JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2072− | (LAnd (ITFixed IT32)) <- op
2073− , (lhs:rhs:_) <- vars =
2075− JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2078− | (LAnd (ITFixed IT64)) <- op
2079− , (lhs:rhs:_) <- vars =
2080− jsMeth (JSVar lhs) "and" [JSVar rhs]
2082− | (LOr (ITFixed IT8)) <- op
2083− , (lhs:rhs:_) <- vars =
2085− JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2088− | (LOr (ITFixed IT16)) <- op
2089− , (lhs:rhs:_) <- vars =
2091− JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2094− | (LOr (ITFixed IT32)) <- op
2095− , (lhs:rhs:_) <- vars =
2097− JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2100− | (LOr (ITFixed IT64)) <- op
2101− , (lhs:rhs:_) <- vars =
2102− jsMeth (JSVar lhs) "or" [JSVar rhs]
2104− | (LXOr (ITFixed IT8)) <- op
2105− , (lhs:rhs:_) <- vars =
2107− JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2110− | (LXOr (ITFixed IT16)) <- op
2111− , (lhs:rhs:_) <- vars =
2113− JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2116− | (LXOr (ITFixed IT32)) <- op
2117− , (lhs:rhs:_) <- vars =
2119− JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2122− | (LXOr (ITFixed IT64)) <- op
2123− , (lhs:rhs:_) <- vars =
2124− jsMeth (JSVar lhs) "xor" [JSVar rhs]
2126− | (LPlus (ATInt (ITFixed IT8))) <- op
2127− , (lhs:rhs:_) <- vars =
2129− JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2132− | (LPlus (ATInt (ITFixed IT16))) <- op
2133− , (lhs:rhs:_) <- vars =
2135− JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2138− | (LPlus (ATInt (ITFixed IT32))) <- op
2139− , (lhs:rhs:_) <- vars =
2141− JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2144− | (LPlus (ATInt (ITFixed IT64))) <- op
2145− , (lhs:rhs:_) <- vars =
2146− jsMeth (jsMeth (JSVar lhs) "add" [JSVar rhs]) "and" [
2147− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2150− | (LMinus (ATInt (ITFixed IT8))) <- op
2151− , (lhs:rhs:_) <- vars =
2153− JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2156− | (LMinus (ATInt (ITFixed IT16))) <- op
2157− , (lhs:rhs:_) <- vars =
2159− JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2162− | (LMinus (ATInt (ITFixed IT32))) <- op
2163− , (lhs:rhs:_) <- vars =
2165− JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2168− | (LMinus (ATInt (ITFixed IT64))) <- op
2169− , (lhs:rhs:_) <- vars =
2170− jsMeth (jsMeth (JSVar lhs) "subtract" [JSVar rhs]) "and" [
2171− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2174− | (LTimes (ATInt (ITFixed IT8))) <- op
2175− , (lhs:rhs:_) <- vars =
2177− JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2180− | (LTimes (ATInt (ITFixed IT16))) <- op
2181− , (lhs:rhs:_) <- vars =
2183− JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2186− | (LTimes (ATInt (ITFixed IT32))) <- op
2187− , (lhs:rhs:_) <- vars =
2189− JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2192− | (LTimes (ATInt (ITFixed IT64))) <- op
2193− , (lhs:rhs:_) <- vars =
2194− jsMeth (jsMeth (JSVar lhs) "multiply" [JSVar rhs]) "and" [
2195− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2198− | (LEq (ATInt (ITFixed IT8))) <- op
2199− , (lhs:rhs:_) <- vars =
2201− JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2204− | (LEq (ATInt (ITFixed IT16))) <- op
2205− , (lhs:rhs:_) <- vars =
2207− JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2210− | (LEq (ATInt (ITFixed IT32))) <- op
2211− , (lhs:rhs:_) <- vars =
2213− JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2216− | (LEq (ATInt (ITFixed IT64))) <- op
2217− , (lhs:rhs:_) <- vars =
2218− jsMeth (jsMeth (JSVar lhs) "equals" [JSVar rhs]) "and" [
2219− jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
2222− | (LLt (ITFixed IT8)) <- op
2223− , (lhs:rhs:_) <- vars =
2225− JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2228− | (LLt (ITFixed IT16)) <- op
2229− , (lhs:rhs:_) <- vars =
2231− JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2234− | (LLt (ITFixed IT32)) <- op
2235− , (lhs:rhs:_) <- vars =
2237− JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2240− | (LLt (ITFixed IT64)) <- op
2241− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
2243− | (LLe (ITFixed IT8)) <- op
2244− , (lhs:rhs:_) <- vars =
2246− JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2249− | (LLe (ITFixed IT16)) <- op
2250− , (lhs:rhs:_) <- vars =
2252− JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2255− | (LLe (ITFixed IT32)) <- op
2256− , (lhs:rhs:_) <- vars =
2258− JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2261− | (LLe (ITFixed IT64)) <- op
2262− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
2264− | (LGt (ITFixed IT8)) <- op
2265− , (lhs:rhs:_) <- vars =
2267− JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2270− | (LGt (ITFixed IT16)) <- op
2271− , (lhs:rhs:_) <- vars =
2273− JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2275− | (LGt (ITFixed IT32)) <- op
2276− , (lhs:rhs:_) <- vars =
2278− JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2281− | (LGt (ITFixed IT64)) <- op
2282− , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
2284− | (LGe (ITFixed IT8)) <- op
2285− , (lhs:rhs:_) <- vars =
2287− JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2290− | (LGe (ITFixed IT16)) <- op
2291− , (lhs:rhs:_) <- vars =
2293− JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2295− | (LGe (ITFixed IT32)) <- op
2296− , (lhs:rhs:_) <- vars =
2298− JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2301− | (LGe (ITFixed IT64)) <- op
2302− , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
2304− | (LUDiv (ITFixed IT8)) <- op
2305− , (lhs:rhs:_) <- vars =
2307− JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2310− | (LUDiv (ITFixed IT16)) <- op
2311− , (lhs:rhs:_) <- vars =
2313− JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2316− | (LUDiv (ITFixed IT32)) <- op
2317− , (lhs:rhs:_) <- vars =
2319− JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2322− | (LUDiv (ITFixed IT64)) <- op
2323− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
2325− | (LSDiv (ATInt (ITFixed IT8))) <- op
2326− , (lhs:rhs:_) <- vars =
2329− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2331− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2335− | (LSDiv (ATInt (ITFixed IT16))) <- op
2336− , (lhs:rhs:_) <- vars =
2339− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2341− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2345− | (LSDiv (ATInt (ITFixed IT32))) <- op
2346− , (lhs:rhs:_) <- vars =
2349− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2351− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)
2355− | (LSDiv (ATInt (ITFixed IT64))) <- op
2356− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
2358− | (LSRem (ATInt (ITFixed IT8))) <- op
2359− , (lhs:rhs:_) <- vars =
2362− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2364− jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2368− | (LSRem (ATInt (ITFixed IT16))) <- op
2369− , (lhs:rhs:_) <- vars =
2372− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2374− jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2378− | (LSRem (ATInt (ITFixed IT32))) <- op
2379− , (lhs:rhs:_) <- vars =
2382− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2384− jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)
2388− | (LSRem (ATInt (ITFixed IT64))) <- op
2389− , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
2391− | (LCompl (ITFixed IT8)) <- op
2392− , (arg:_) <- vars =
2393− jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
2395− | (LCompl (ITFixed IT16)) <- op
2396− , (arg:_) <- vars =
2397− jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
2399− | (LCompl (ITFixed IT32)) <- op
2400− , (arg:_) <- vars =
2401− jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)
2403− | (LCompl (ITFixed IT64)) <- op
2404− , (arg:_) <- vars =
2405− invokeMeth arg "not" []
2408− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
2410− , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
2412− , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
2414− , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
2416− , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
2418− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2420− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2422− , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
2424− , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
2426− , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
2428− , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
2430− , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
2432− , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
2434− , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
2436− , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
2438− , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
2441− , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2443− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2445− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2447− , (arg:_) <- vars = JSProj (JSVar arg) "length"
2449− | (LStrInt ITNative) <- op
2450− , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
2451− | (LIntStr ITNative) <- op
2452− , (arg:_) <- vars = jsCall "String" [JSVar arg]
2453− | (LSExt ITNative ITBig) <- op
2454− , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
2455− | (LTrunc ITBig ITNative) <- op
2456− , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
2457− | (LIntStr ITBig) <- op
2458− , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
2459− | (LStrInt ITBig) <- op
2460− , (arg:_) <- vars = jsBigInt $ JSVar arg
2462− , (arg:_) <- vars = jsCall "String" [JSVar arg]
2464− , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
2465− | (LIntFloat ITNative) <- op
2466− , (arg:_) <- vars = JSVar arg
2467− | (LFloatInt ITNative) <- op
2468− , (arg:_) <- vars = JSVar arg
2469− | (LChInt ITNative) <- op
2470− , (arg:_) <- vars = jsCall "__IDRRT__charCode" [JSVar arg]
2471− | (LIntCh ITNative) <- op
2472− , (arg:_) <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]
2475− , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
2477− , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
2479− , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
2481− , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
2483− , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
2485− , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
2487− , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
2489− , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
2491− , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
2493− , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
2495− , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
2498− , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2500− , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
2502− , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
2504− , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
2506− , (arg:_) <- vars = let v = translateVariableName arg in
2507− JSApp (JSProj (JSIdent v) "substr") [
2509− JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
2511− | LSystemInfo <- op
2512− , (arg:_) <- vars = jsCall "__IDRRT__systemInfo" [JSVar arg]
2514− , (_) <- vars = JSNull
2517− translateBinaryOp :: String -> LVar -> LVar -> JS
2518− translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)
2521− invokeMeth :: LVar -> String -> [LVar] -> JS
2522− invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
2524−translateExpression (SError msg) =
2527−translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
2528− jsCall (idrRTNamespace ++ "print") [JSVar var]
2530−translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
2531− JSBinOp "==" (JSVar var) JSNull
2533−translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
2534− JSBinOp "==" (JSVar lhs) (JSVar rhs)
2536−translateExpression (SForeign _ _ "idris_time" []) =
2537− JSRaw "(new Date()).getTime()"
2539−translateExpression (SForeign _ _ fun args) =
2540− JSFFI fun (map generateWrapper args)
2542− generateWrapper (ffunc, name)
2543− | FFunction <- ffunc =
2545− JSIdent $ idrRTNamespace ++ "ffiWrap"
2546− ) [JSIdent $ translateVariableName name]
2547− | FFunctionIO <- ffunc =
2549− JSIdent $ idrRTNamespace ++ "ffiWrap"
2550− ) [JSIdent $ translateVariableName name]
2552− generateWrapper (_, name) =
2553− JSIdent $ translateVariableName name
2555−translateExpression patterncase
2556− | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
2557− | (SCase var cases) <- patterncase = caseHelper var cases "cse"
2559− caseHelper var cases param =
2560− JSApp (JSFunction [param] (
2561− JSCond $ map (expandCase param . translateCaseCond param) cases
2565− expandCase :: String -> (Cond, JS) -> (JS, JS)
2566− expandCase _ (RawCond cond, branch) = (cond, branch)
2567− expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
2568− expandCase var (CaseCond caseTy, branch)
2569− | ConCase tag <- caseTy =
2570− let checkCon = JSIdent var `jsInstanceOf` jsCon
2571− checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
2572− (checkCon `jsAnd` checkTag, branch)
2574− | TypeCase ty <- caseTy =
2575− let checkTy = JSIdent var `jsInstanceOf` jsType
2576− checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
2577− (checkTy `jsAnd` checkTag, branch)
2579−translateExpression (SCon i name vars) =
2580− JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
2581− , JSArray $ map JSVar vars
2584−translateExpression (SUpdate var@(Loc i) e) =
2585− JSAssign (JSVar var) (translateExpression e)
2587−translateExpression (SProj var i) =
2588− JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
2590−translateExpression SNothing = JSNull
2592−translateExpression e =
2593− jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2596−data CaseType = ConCase Int
2602−data Cond = CaseCond CaseType
2606−translateCaseCond :: String -> SAlt -> (Cond, JS)
2607−translateCaseCond _ cse@(SDefaultCase _) =
2608− (CaseCond DefaultCase, translateCase Nothing cse)
2610−translateCaseCond var cse@(SConstCase ty _)
2611− | StrType <- ty = matchHelper JSStringTy
2612− | PtrType <- ty = matchHelper JSPtrTy
2613− | Forgot <- ty = matchHelper JSForgotTy
2614− | (AType ATFloat) <- ty = matchHelper JSFloatTy
2615− | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
2616− | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
2617− | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
2619− matchHelper :: JSType -> (Cond, JS)
2620− matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2622−translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2623− let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2624− (RawCond cond, translateCase Nothing cse)
2626−translateCaseCond var cse@(SConstCase cst _) =
2627− let cond = JSIdent var `jsEq` translateConstant cst in
2628− (RawCond cond, translateCase Nothing cse)
2630−translateCaseCond var cse@(SConCase _ tag _ _ _) =
2631− (CaseCond $ ConCase tag, translateCase (Just var) cse)
1427+ | LSystemInfo <- op
1428+ , (arg:_) <- args = jsCall "i$systemInfo" [translateReg arg]
1430+ , (_) <- args = JSNull
1431+ | otherwise = JSError $ "Not implemented: " ++ show op
1433+ translateBinaryOp :: String -> Reg -> Reg -> JS
1434+ translateBinaryOp op lhs rhs =
1435+ JSBinOp op (translateReg lhs) (translateReg rhs)
1437+ invokeMeth :: Reg -> String -> [Reg] -> JS
1438+ invokeMeth obj meth args =
1439+ JSApp (JSProj (translateReg obj) meth) $ map translateReg args
1442+jsRESERVE :: CompileInfo -> Int -> JS
1443+jsRESERVE _ _ = JSNoop
1446+jsSTACK = JSIdent "i$valstack"
1449+jsCALLSTACK = JSIdent "i$callstack"
1452+jsSTACKBASE = JSIdent "i$valstack_base"
1455+jsSTACKTOP = JSIdent "i$valstack_top"
1458+jsOLDBASE = JSIdent "oldbase"
1461+jsMYOLDBASE = JSIdent "myoldbase"
1464+jsRET = JSIdent "i$ret"
1467+jsLOC 0 = JSIndex jsSTACK jsSTACKBASE
1468+jsLOC n = JSIndex jsSTACK (JSBinOp "+" jsSTACKBASE (JSNum (JSInt n)))
1471+jsTOP 0 = JSIndex jsSTACK jsSTACKTOP
1472+jsTOP n = JSIndex jsSTACK (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))
1474+jsPUSH :: [JS] -> JS
1475+jsPUSH args = JSApp (JSProj jsCALLSTACK "push") args
1478+jsPOP = JSApp (JSProj jsCALLSTACK "pop") []
1480+translateBC :: CompileInfo -> BC -> JS
1482+ | ASSIGN r1 r2 <- bc = jsASSIGN info r1 r2
1483+ | ASSIGNCONST r c <- bc = jsASSIGNCONST info r c
1484+ | UPDATE r1 r2 <- bc = jsASSIGN info r1 r2
1485+ | ADDTOP n <- bc = jsADDTOP info n
1486+ | NULL r <- bc = jsNULL info r
1487+ | CALL n <- bc = jsCALL info n
1488+ | TAILCALL n <- bc = jsTAILCALL info n
1489+ | FOREIGNCALL r _ _ n a <- bc = jsFOREIGN info r n a
1490+ | TOPBASE n <- bc = jsTOPBASE info n
1491+ | BASETOP n <- bc = jsBASETOP info n
1492+ | STOREOLD <- bc = jsSTOREOLD info
1493+ | SLIDE n <- bc = jsSLIDE info n
1494+ | REBASE <- bc = jsREBASE info
1495+ | RESERVE n <- bc = jsRESERVE info n
1496+ | MKCON r t rs <- bc = jsMKCON info r t rs
1497+ | CASE s r c d <- bc = jsCASE info s r c d
1498+ | CONSTCASE r c d <- bc = jsCONSTCASE info r c d
1499+ | PROJECT r l a <- bc = jsPROJECT info r l a
1500+ | OP r o a <- bc = jsOP info r o a
1501+ | ERROR e <- bc = jsERROR info e
1502+ | otherwise = JSRaw $ show bc
1503+ {- PROJECTINTO _ _ _ <- bc = undefined -}
2634−translateCase :: Maybe String -> SAlt -> JS
2635−translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2636−translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2637−translateCase (Just var) (SConCase a _ _ vars e) =
2638− let params = map jsVar [a .. (a + length vars)] in
2639− JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
2640− JSThis, JSProj (JSIdent var) "vars"