git.iko.soy/Idris-dev
on 157ffad help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
2641 lines 82 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where
5import Idris.AbsSyntax hiding (TypeCase)
6import IRTS.Bytecode
7import IRTS.Lang
8import IRTS.Simplified
9import IRTS.CodegenCommon
10import Idris.Core.TT
11import Paths_idris
12import Util.System
14import Control.Arrow
15import Control.Applicative ((<$>), (<*>), pure)
16import Data.Char
17import Numeric
18import Data.List
19import Data.Maybe
20import Data.Word
21import System.IO
22import System.Directory
25idrNamespace :: String
26idrNamespace = "__IDR__"
27idrRTNamespace = "__IDRRT__"
28idrLTNamespace = "__IDRLT__"
29idrCTRNamespace = "__IDRCTR__"
32data JSTarget = Node | JavaScript deriving Eq
35data JSType = JSIntTy
36 | JSStringTy
37 | JSIntegerTy
38 | JSFloatTy
39 | JSCharTy
40 | JSPtrTy
41 | JSForgotTy
42 deriving Eq
45data JSInteger = JSBigZero
46 | JSBigOne
47 | JSBigInt Integer
48 deriving Eq
51data JSNum = JSInt Int
52 | JSFloat Double
53 | JSInteger JSInteger
54 deriving Eq
57data JSWord = JSWord8 Word8
58 | JSWord16 Word16
59 | JSWord32 Word32
60 | JSWord64 Word64
61 deriving Eq
64data JSAnnotation = JSConstructor deriving Eq
67instance Show JSAnnotation where
68 show JSConstructor = "constructor"
71data JS = JSRaw String
72 | JSIdent String
73 | JSFunction [String] JS
74 | JSType JSType
75 | JSSeq [JS]
76 | JSReturn JS
77 | JSApp JS [JS]
78 | JSNew String [JS]
79 | JSError String
80 | JSBinOp String JS JS
81 | JSPreOp String JS
82 | JSPostOp String JS
83 | JSProj JS String
84 | JSVar LVar
85 | JSNull
86 | JSThis
87 | JSTrue
88 | JSFalse
89 | JSArray [JS]
90 | JSString String
91 | JSNum JSNum
92 | JSWord JSWord
93 | JSAssign JS JS
94 | JSAlloc String (Maybe JS)
95 | JSIndex JS JS
96 | JSCond [(JS, JS)]
97 | JSTernary JS JS JS
98 | JSParens JS
99 | JSWhile JS JS
100 | JSFFI String [JS]
101 | JSAnnotation JSAnnotation JS
102 | JSNoop
103 deriving Eq
106data FFI = FFICode Char | FFIArg Int | FFIError String
109ffi :: String -> [String] -> String
110ffi code args = let parsed = ffiParse code in
111 case ffiError parsed of
112 Just err -> error err
113 Nothing -> renderFFI parsed args
114 where
115 ffiParse :: String -> [FFI]
116 ffiParse "" = []
117 ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]
118 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
119 ffiParse ('%':s:ss)
120 | isDigit s =
121 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
122 | otherwise =
123 [FFIError $ "FFI - Invalid positional argument"]
124 ffiParse (s:ss) = FFICode s : ffiParse ss
127 ffiError :: [FFI] -> Maybe String
128 ffiError [] = Nothing
129 ffiError ((FFIError s):xs) = Just s
130 ffiError (x:xs) = ffiError xs
133 renderFFI :: [FFI] -> [String] -> String
134 renderFFI [] _ = ""
135 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
136 renderFFI ((FFIArg i) : fs) args
137 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
138 | otherwise = error "FFI - Argument index out of bounds"
141compileJS :: JS -> String
142compileJS JSNoop = ""
144compileJS (JSAnnotation annotation js) =
145 "/** @" ++ show annotation ++ " */\n" ++ compileJS js
147compileJS (JSFFI raw args) =
148 ffi raw (map compileJS args)
150compileJS (JSRaw code) =
151 code
153compileJS (JSIdent ident) =
154 ident
156compileJS (JSFunction args body) =
157 "function("
158 ++ intercalate "," args
159 ++ "){\n"
160 ++ compileJS body
161 ++ "\n}"
163compileJS (JSType ty)
164 | JSIntTy <- ty = idrRTNamespace ++ "Int"
165 | JSStringTy <- ty = idrRTNamespace ++ "String"
166 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
167 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
168 | JSCharTy <- ty = idrRTNamespace ++ "Char"
169 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
170 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
172compileJS (JSSeq seq) =
173 intercalate ";\n" (map compileJS seq)
175compileJS (JSReturn val) =
176 "return " ++ compileJS val
178compileJS (JSApp lhs rhs)
179 | JSFunction {} <- lhs =
180 concat ["(", compileJS lhs, ")(", args, ")"]
181 | otherwise =
182 concat [compileJS lhs, "(", args, ")"]
183 where args :: String
184 args = intercalate "," $ map compileJS rhs
186compileJS (JSNew name args) =
187 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
189compileJS (JSError exc) =
190 "throw new Error(\"" ++ exc ++ "\")"
192compileJS (JSBinOp op lhs rhs) =
193 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
195compileJS (JSPreOp op val) =
196 op ++ compileJS val
198compileJS (JSProj obj field)
199 | JSFunction {} <- obj =
200 concat ["(", compileJS obj, ").", field]
201 | JSAssign {} <- obj =
202 concat ["(", compileJS obj, ").", field]
203 | otherwise =
204 compileJS obj ++ '.' : field
206compileJS (JSVar var) =
207 translateVariableName var
209compileJS JSNull =
210 "null"
212compileJS JSThis =
213 "this"
215compileJS JSTrue =
216 "true"
218compileJS JSFalse =
219 "false"
221compileJS (JSArray elems) =
222 "[" ++ intercalate "," (map compileJS elems) ++ "]"
224compileJS (JSString str) =
225 "\"" ++ str ++ "\""
227compileJS (JSNum num)
228 | JSInt i <- num = show i
229 | JSFloat f <- num = show f
230 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
231 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
232 | JSInteger (JSBigInt i) <- num = show i
234compileJS (JSAssign lhs rhs) =
235 compileJS lhs ++ "=" ++ compileJS rhs
237compileJS (JSAlloc name val) =
238 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
240compileJS (JSIndex lhs rhs) =
241 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
243compileJS (JSCond branches) =
244 intercalate " else " $ map createIfBlock branches
245 where
246 createIfBlock (JSNoop, e) =
247 "{\n"
248 ++ compileJS e
249 ++ ";\n}"
250 createIfBlock (cond, e) =
251 "if (" ++ compileJS cond ++") {\n"
252 ++ compileJS e
253 ++ ";\n}"
255compileJS (JSTernary cond true false) =
256 let c = compileJS cond
257 t = compileJS true
258 f = compileJS false in
259 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
261compileJS (JSParens js) =
262 "(" ++ compileJS js ++ ")"
264compileJS (JSWhile cond body) =
265 "while (" ++ compileJS cond ++ ") {\n"
266 ++ compileJS body
267 ++ "\n}"
269compileJS (JSWord word)
270 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
271 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
272 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
273 | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
276jsTailcall :: JS -> JS
277jsTailcall call =
278 jsCall (idrRTNamespace ++ "tailcall") [
279 JSFunction [] (JSReturn call)
280 ]
283jsCall :: String -> [JS] -> JS
284jsCall fun = JSApp (JSIdent fun)
287jsMeth :: JS -> String -> [JS] -> JS
288jsMeth obj meth =
289 JSApp (JSProj obj meth)
292jsInstanceOf :: JS -> JS -> JS
293jsInstanceOf = JSBinOp "instanceof"
296jsEq :: JS -> JS -> JS
297jsEq = JSBinOp "=="
299jsNotEq :: JS -> JS -> JS
300jsNotEq = JSBinOp "!="
302jsAnd :: JS -> JS -> JS
303jsAnd = JSBinOp "&&"
306jsOr :: JS -> JS -> JS
307jsOr = JSBinOp "||"
310jsType :: JS
311jsType = JSIdent $ idrRTNamespace ++ "Type"
314jsCon :: JS
315jsCon = JSIdent $ idrRTNamespace ++ "Con"
318jsTag :: JS -> JS
319jsTag obj = JSProj obj "tag"
322jsTypeTag :: JS -> JS
323jsTypeTag obj = JSProj obj "type"
326jsBigInt :: JS -> JS
327jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
328jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
329jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
332jsVar :: Int -> String
333jsVar = ("__var_" ++) . show
336jsLet :: String -> JS -> JS -> JS
337jsLet name value body =
338 JSApp (
339 JSFunction [name] (
340 JSReturn body
341 )
342 ) [value]
345jsError :: String -> JS
346jsError err = JSApp (JSFunction [] (JSError err)) []
348jsUnPackBits :: JS -> JS
349jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)
352jsPackUBits8 :: JS -> JS
353jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]
355jsPackUBits16 :: JS -> JS
356jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]
358jsPackUBits32 :: JS -> JS
359jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]
361jsPackSBits8 :: JS -> JS
362jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]
364jsPackSBits16 :: JS -> JS
365jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]
367jsPackSBits32 :: JS -> JS
368jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]
371foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
372foldJS tr add acc js =
373 fold js
374 where
375 fold js
376 | JSFunction args body <- js =
377 add (tr js) (fold body)
378 | JSSeq seq <- js =
379 add (tr js) $ foldl' add acc (map fold seq)
380 | JSReturn ret <- js =
381 add (tr js) (fold ret)
382 | JSApp lhs rhs <- js =
383 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
384 | JSNew _ args <- js =
385 add (tr js) $ foldl' add acc $ map fold args
386 | JSBinOp _ lhs rhs <- js =
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
414 | otherwise =
415 tr js
418transformJS :: (JS -> JS) -> JS -> JS
419transformJS tr js =
420 transformHelper js
421 where
422 transformHelper :: JS -> JS
423 transformHelper 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)
443 | otherwise = js
446moveJSDeclToTop :: String -> [JS] -> [JS]
447moveJSDeclToTop decl js = move ([], js)
448 where
449 move :: ([JS], [JS]) -> [JS]
450 move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
451 | name == decl = js : front ++ back
453 move (front, js@(JSAlloc name _):back)
454 | name == decl = js : front ++ back
456 move (front, js:back) =
457 move (front ++ [js], back)
460jsSubst :: JS -> JS -> JS -> JS
461jsSubst var new old
462 | var == old = new
464jsSubst (JSIdent var) new (JSVar old)
465 | var == translateVariableName old = new
466 | otherwise = JSVar old
468jsSubst var new old@(JSIdent _)
469 | var == old = new
470 | otherwise = old
472jsSubst var new (JSArray fields) =
473 JSArray (map (jsSubst var new) fields)
475jsSubst var new (JSNew con vals) =
476 JSNew con $ map (jsSubst var new) vals
478jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
479 | var `notElem` args =
480 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
481 map (jsSubst (JSIdent var) new) vals
482 )
483 | otherwise =
484 JSApp (JSProj (JSFunction args body) "apply") (
485 map (jsSubst (JSIdent var) new) vals
486 )
488jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
489 | var /= arg =
490 JSApp (JSFunction [arg] (
491 jsSubst (JSIdent var) new body
492 )) $ map (jsSubst (JSIdent var) new) vals
493 | otherwise =
494 JSApp (JSFunction [arg] (
495 body
496 )) $ map (jsSubst (JSIdent var) new) vals
498jsSubst var new js = transformJS (jsSubst var new) js
501removeAllocations :: JS -> JS
502removeAllocations (JSSeq body) =
503 let opt = removeHelper (map removeAllocations body) in
504 case opt of
505 [ret] -> ret
506 _ -> JSSeq opt
507 where
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
514removeAllocations js = transformJS removeAllocations js
517isJSConstant :: JS -> Bool
518isJSConstant js
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
527 | otherwise = False
529isJSConstantConstructor :: [String] -> JS -> Bool
530isJSConstantConstructor constants js
531 | isJSConstant js =
532 True
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 =
539 True
540 | JSIdent name <- js
541 , name `elem` constants =
542 True
543 | otherwise = False
546inlineJS :: JS -> JS
547inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
548 where
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
557 inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
558 | opt <- inlineCaseMatch val =
559 inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
561 inlineCaseMatch js = transformJS inlineCaseMatch js
564 inlineApply js
565 | JSApp (
566 JSProj (JSFunction args (JSReturn body)) "apply"
567 ) [JSThis, JSProj var "vars"] <- js =
568 inlineApply $ inlineApply' var args body 0
569 | JSReturn (JSApp (
570 JSProj (JSFunction args body@(JSCond _)) "apply"
571 ) [JSThis, JSProj var "vars"]) <- js =
572 inlineApply $ inlineApply' var args body 0
573 where
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))
579 ) body
580 ) (n + 1)
582 inlineApply js = transformJS inlineApply js
585 inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
586 inlineError error
588 inlineError js = transformJS inlineError js
591 inlineAssign (JSAssign lhs rhs)
592 | JSVar _ <- lhs
593 , JSVar _ <- rhs
594 , lhs == rhs =
595 lhs
597 inlineAssign (JSAssign lhs rhs)
598 | JSIdent _ <- lhs
599 , JSIdent _ <- rhs
600 , lhs == rhs =
601 lhs
603 inlineAssign js = transformJS inlineAssign js
606removeEval :: [JS] -> [JS]
607removeEval js =
608 let (ret, isReduced) = checkEval js in
609 if isReduced
610 then removeEvalApp ret
611 else ret
612 where
613 removeEvalApp js = catMaybes (map removeEvalApp' js)
614 where
615 removeEvalApp' :: JS -> Maybe JS
616 removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
617 removeEvalApp' js = Just $ transformJS match js
618 where
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
624 where
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)
630 checkEval' :: JS -> (Maybe JS, Bool)
631 checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
632 JSSeq [ _
633 , JSReturn (JSIdent "t")
634 ]
635 )) []))) = (Nothing, True)
637 checkEval' js = (Just js, False)
640reduceJS :: [JS] -> [JS]
641reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
644funName :: JS -> String
645funName (JSAlloc fun _) = fun
648elimDeadLoop :: [JS] -> [JS]
649elimDeadLoop js
650 | ret <- deadEvalApplyCases js
651 , ret /= js = elimDeadLoop ret
652 | otherwise = js
655deadEvalApplyCases :: [JS] -> [JS]
656deadEvalApplyCases js =
657 let tags = sort $ nub $ concatMap (getTags) js in
658 map (removeHelper tags) js
659 where
660 getTags :: JS -> [Int]
661 getTags = foldJS match (++) []
662 where
663 match js
664 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
665 | otherwise = []
668 removeHelper :: [Int] -> JS -> JS
669 removeHelper tags (JSAlloc fun (Just (
670 JSApp (JSFunction [] (JSSeq seq)) []))
671 ) =
672 (JSAlloc fun (Just (
673 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
674 )
676 removeHelper _ js = js
679 remover :: [Int] -> [JS] -> [JS]
680 remover tags (
681 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
682 )
683 | tag `notElem` tags = remover tags js
685 remover tags (j:js) = j : remover tags js
686 remover _ [] = []
689initConstructors :: [JS] -> [JS]
690initConstructors js =
691 let tags = nub $ sort $ concat (map getTags js) in
692 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
693 where
694 rearrangePrelude :: [JS] -> [JS]
695 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
698 getTags :: JS -> [Int]
699 getTags = foldJS match (++) []
700 where
701 match js
702 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
703 | otherwise = []
706 replaceConstructors :: [Int] -> [JS] -> [JS]
707 replaceConstructors tags js = map (replaceHelper tags) js
708 where
709 replaceHelper :: [Int] -> JS -> JS
710 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
711 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
713 replaceHelper tags js = transformJS (replaceHelper tags) js
716 createConstant :: Int -> JS
717 createConstant tag =
718 JSAlloc (idrCTRNamespace ++ show tag) (Just (
719 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
720 ))
723removeIDs :: [JS] -> [JS]
724removeIDs js =
725 case partition isID js of
726 ([], rest) -> rest
727 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
728 where isID :: JS -> Bool
729 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
730 | JSReturn (JSVar _) <- last body = True
732 isID _ = False
735 idFor :: JS -> (String, Int)
736 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
737 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
740 removeIDCall :: [(String, Int)] -> JS -> JS
741 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
742 JSReturn (JSApp (JSIdent fun) args)
743 )])
744 | Just pos <- lookup fun ids
745 , pos < length args = removeIDCall ids (args !! pos)
747 removeIDCall ids (JSNew _ [JSFunction [] (
748 JSReturn (JSApp (JSIdent fun) args)
749 )])
750 | Just pos <- lookup fun ids
751 , pos < length args = removeIDCall ids (args !! pos)
753 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
754 | Just pos <- lookup fun ids
755 , pos < length args = removeIDCall ids (args !! pos)
757 removeIDCall ids js = transformJS (removeIDCall ids) js
760inlineFunction :: String -> [String] -> JS -> JS -> JS
761inlineFunction fun args body js = inline' js
762 where
763 inline' :: JS -> JS
764 inline' (JSApp (JSIdent name) vals)
765 | name == fun =
766 let (js, phs) = insertPlaceHolders args body in
767 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
769 inline' js = transformJS inline' js
771 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
772 insertPlaceHolders args body = insertPlaceHolders' args body []
773 where
774 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
775 insertPlaceHolders' (a:as) body ph
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)
783inlineFunctions :: [JS] -> [JS]
784inlineFunctions js =
785 inlineHelper ([], js)
786 where
787 inlineHelper :: ([JS], [JS]) -> [JS]
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
793 ) fun args body =
794 let f = map (inlineFunction fun args new) in
795 inlineHelper (f front, f back)
797 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
798 inlineHelper (front, []) = front
801 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
802 inlineAble 1 fun args (JSReturn body)
803 | nonRecur fun body =
804 if all (<= 1) (map ($ body) (map countIDOccurences args))
805 then Just body
806 else Nothing
808 inlineAble _ _ _ _ = Nothing
811 nonRecur :: String -> JS -> Bool
812 nonRecur name body = countInvokations name body == 0
815 countAll :: String -> [JS] -> Int
816 countAll name js = sum $ map (countInvokations name) js
819 countIDOccurences :: String -> JS -> Int
820 countIDOccurences name = foldJS match (+) 0
821 where
822 match :: JS -> Int
823 match js
824 | JSIdent ident <- js
825 , name == ident = 1
826 | otherwise = 0
829 countInvokations :: String -> JS -> Int
830 countInvokations name = foldJS match (+) 0
831 where
832 match :: JS -> Int
833 match js
834 | JSApp (JSIdent ident) _ <- js
835 , name == ident = 1
836 | JSNew con _ <- js
837 , name == con = 1
838 | otherwise = 0
841reduceContinuations :: JS -> JS
842reduceContinuations = inlineTC . reduceJS
843 where
844 reduceJS :: JS -> JS
845 reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
846 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
847 )]) = reduceJS js
849 reduceJS js = transformJS reduceJS js
852 inlineTC :: JS -> JS
853 inlineTC js
854 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
855 JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
856 JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
857 JSReturn (JSNew "__IDRRT__Cont" _)
858 )])
859 )])
860 )] <- js = inlineTC ret
862 inlineTC js = transformJS inlineTC js
867reduceConstant :: JS -> JS
868reduceConstant
869 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
870 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
871 )])
872 | JSNum num <- val = val
873 | JSBinOp op lhs rhs <- val =
874 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
876 | JSApp (JSProj lhs op) [rhs] <- val
877 , op `elem` [ "subtract"
878 , "add"
879 , "multiply"
880 , "divide"
881 , "mod"
882 , "equals"
883 , "lesser"
884 , "lesserOrEquals"
885 , "greater"
886 , "greaterOrEquals"
887 ] = val
889reduceConstant (JSApp ident [(JSParens js)]) =
890 JSApp ident [reduceConstant js]
892reduceConstant js = transformJS reduceConstant js
895reduceConstants :: JS -> JS
896reduceConstants js
897 | ret <- reduceConstant js
898 , ret /= js = reduceConstants ret
899 | otherwise = js
902elimDuplicateEvals :: JS -> JS
903elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
904 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
905 where
906 elimHelper :: [JS] -> [JS]
907 elimHelper (j@(JSAlloc var (Just val)):js) =
908 j : map (jsSubst val (JSIdent var)) (elimHelper js)
909 elimHelper (j:js) =
910 j : elimHelper js
911 elimHelper [] = []
913elimDuplicateEvals js = js
916optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
917optimizeRuntimeCalls fun tc js =
918 optTC tc : map optHelper js
919 where
920 optHelper :: JS -> JS
921 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
922 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
923 ])
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 (
933 JSTernary (
934 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
935 (hasProp "__IDRLT__EVAL" "arg0")
936 ) (JSApp
937 (JSIndex
938 (JSIdent "__IDRLT__EVAL")
939 (JSProj (JSIdent "arg0") "tag")
940 )
941 [JSIdent "arg0"]
942 ) (JSIdent "arg0")
943 )
944 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
945 JSAssign (JSIdent "ret") (
946 JSApp (JSProj (JSIdent "ret") "k") []
947 )
948 )
949 , JSReturn $ JSIdent "ret"
950 ]
951 ))
953 optTC tc@"__IDRRT__APPLYTC" =
954 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
955 JSSeq [ JSAlloc "ret" $ Just (
956 JSTernary (
957 (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
958 (hasProp "__IDRLT__APPLY" "fn0")
959 ) (JSApp
960 (JSIndex
961 (JSIdent "__IDRLT__APPLY")
962 (JSProj (JSIdent "fn0") "tag")
963 )
964 [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
965 ) JSNull
966 )
967 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
968 JSAssign (JSIdent "ret") (
969 JSApp (JSProj (JSIdent "ret") "k") []
970 )
971 )
972 , JSReturn $ JSIdent "ret"
973 ]
974 ))
977 hasProp :: String -> String -> JS
978 hasProp table var =
979 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
982unfoldLookupTable :: [JS] -> [JS]
983unfoldLookupTable input =
984 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
985 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
986 js = applyunfold in
987 adaptRuntime $ expandCons evals applys js
988 where
989 adaptRuntime :: [JS] -> [JS]
990 adaptRuntime =
991 adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
994 adaptApply :: [JS] -> [JS]
995 adaptApply js = adaptApply' [] js
996 where
997 adaptApply' :: [JS] -> [JS] -> [JS]
998 adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
999 front ++ (new:back)
1001 adaptApply' front (next:back) =
1002 adaptApply' (front ++ [next]) back
1004 adaptApply' front [] = front
1006 new =
1007 JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
1008 JSTernary (
1009 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1010 (JSProj (JSIdent "mfn0") "app")
1011 ) (JSApp
1012 (JSProj (JSIdent "mfn0") "app")
1013 [JSIdent "mfn0", JSIdent "marg0"]
1014 ) JSNull
1019 adaptApplyTC :: [JS] -> [JS]
1020 adaptApplyTC js = adaptApplyTC' [] js
1021 where
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
1031 new =
1032 JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
1033 JSSeq [ JSAlloc "ret" $ Just (
1034 JSTernary (
1035 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1036 (JSProj (JSIdent "mfn0") "app")
1037 ) (JSApp
1038 (JSProj (JSIdent "mfn0") "app")
1039 [JSIdent "mfn0", JSIdent "marg0"]
1040 ) JSNull
1042 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1043 JSAssign (JSIdent "ret") (
1044 JSApp (JSProj (JSIdent "ret") "k") []
1047 , JSReturn $ JSIdent "ret"
1049 ))
1052 adaptEval :: [JS] -> [JS]
1053 adaptEval js = adaptEval' [] js
1054 where
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
1064 new =
1065 JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
1066 JSTernary (
1067 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1068 (JSProj (JSIdent "marg0") "eval")
1069 ) (JSApp
1070 (JSProj (JSIdent "marg0") "eval")
1071 [JSIdent "marg0"]
1072 ) (JSIdent "marg0")
1077 adaptEvalTC :: [JS] -> [JS]
1078 adaptEvalTC js = adaptEvalTC' [] js
1079 where
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
1089 new =
1090 JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
1091 JSSeq [ JSAlloc "ret" $ Just (
1092 JSTernary (
1093 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1094 (JSProj (JSIdent "marg0") "eval")
1095 ) (JSApp
1096 (JSProj (JSIdent "marg0") "eval")
1097 [JSIdent "marg0"]
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"
1107 ))
1110 adaptCon js =
1111 adaptCon' [] js
1112 where
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
1122 new =
1123 JSAnnotation JSConstructor $
1124 JSAlloc "__IDRRT__Con" (Just $
1125 JSFunction newArgs (
1126 JSSeq (map newVar newArgs)
1129 where
1130 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1131 newArgs = ["tag", "eval", "app", "vars"]
1134 unfoldLT :: String -> [JS] -> ([Int], [JS])
1135 unfoldLT lt 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 =
1143 map expandCons' js
1144 where
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])
1170 extractLT lt js =
1171 extractLT' ([], js)
1172 where
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)]
1182 expandLT lt (
1183 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1184 ) = catMaybes (map expandEntry seq)
1185 where
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 = []
1195removeInstanceChecks :: JS -> JS
1196removeInstanceChecks (JSCond conds) =
1197 removeNoopConds $ JSCond $ eliminateDeadBranches $ map (
1198 removeHelper *** removeInstanceChecks
1199 ) conds
1200 where
1201 removeHelper (
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
1217removeInstanceChecks js = transformJS removeInstanceChecks js
1220reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1221reduceLoop reduced (cons, program) =
1222 case partition findConstructors program of
1223 ([], js) -> cons ++ js
1224 (candidates, rest) ->
1225 let names = reduced ++ map funName candidates in
1226 reduceLoop names (
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
1235 reducable js
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
1245 reduce :: JS -> JS
1246 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1247 | JSReturn js <- last body = (JSAlloc fun (Just js))
1249 reduce js = js
1252 reduceCall :: [String] -> JS -> JS
1253 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1254 JSReturn (JSApp id@(JSIdent ret) _)
1255 )])
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
1264extractLocalConstructors :: [JS] -> [JS]
1265extractLocalConstructors js =
1266 concatMap extractLocalConstructors' js
1267 where
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)]
1275 where
1276 cons :: [(JS, JS)]
1277 cons = zipWith genName (foldJS match (++) [] body) [1..]
1278 where
1279 genName :: JS -> Int -> (JS, JS)
1280 genName js id =
1281 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1283 match :: JS -> [JS]
1284 match js
1285 | JSNew "__IDRRT__Con" args <- js
1286 , all isConstant args = [js]
1287 | otherwise = []
1290 addCons :: [(JS, JS)] -> [JS] -> [JS]
1291 addCons [] js = js
1292 addCons (con@(_, name):cons) js
1293 | sum (map (countOccur name) js) > 0 =
1294 addCons cons ((allocCon con) : js)
1295 | otherwise =
1296 addCons cons js
1299 countOccur :: JS -> JS -> Int
1300 countOccur ident js = foldJS match (+) 0 js
1301 where
1302 match :: JS -> Int
1303 match js
1304 | js == ident = 1
1305 | otherwise = 0
1308 allocCon :: (JS, JS) -> JS
1309 allocCon (js, JSIdent name) =
1310 JSAlloc name (Just js)
1313 isConstant :: JS -> Bool
1314 isConstant js
1315 | JSNew "__IDRRT__Con" args <- js
1316 , all isConstant args =
1317 True
1318 | otherwise =
1319 isJSConstantConstructor globalCons js
1321 extractLocalConstructors' js = [js]
1324 getGlobalCons :: JS -> [String]
1325 getGlobalCons js = foldJS match (++) [] js
1326 where
1327 match :: JS -> [String]
1328 match js
1329 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1330 [name]
1331 | otherwise =
1332 []
1335evalCons :: [JS] -> [JS]
1336evalCons js =
1337 map (collapseCont . collapseTC . expandProj . evalCons') js
1338 where
1339 cons :: [(String, JS)]
1340 cons = concatMap getGlobalCons js
1342 evalCons' :: JS -> JS
1343 evalCons' js = transformJS match js
1344 where
1345 match :: JS -> JS
1346 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1347 | JSIdent name <- arg
1348 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1349 arg
1351 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1352 | JSIdent name <- arg
1353 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1354 arg
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
1368 where
1369 match :: JS -> JS
1370 match (
1371 JSIndex (
1372 JSProj (JSIdent name) "vars"
1373 ) (
1374 JSNum (JSInt idx)
1377 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1378 args !! idx
1380 match js = transformJS match js
1383 collapseTC :: JS -> JS
1384 collapseTC js = transformJS match js
1385 where
1386 match :: JS -> JS
1387 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1388 JSReturn (JSIdent name)
1389 )])
1390 | Just _ <- lookup name cons = (JSIdent name)
1392 match js = transformJS match js
1395 collapseCont :: JS -> JS
1396 collapseCont js = transformJS match js
1397 where
1398 match :: JS -> JS
1399 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1400 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1401 )]) = collapseCont ret
1404 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1405 JSReturn (JSIdent name)
1406 )]) = JSIdent name
1408 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1409 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1410 )])
1411 | all collapsable args = ret
1412 where
1413 collapsable :: JS -> Bool
1414 collapsable (JSIdent _) = True
1415 collapsable js = isJSConstantConstructor (map fst cons) js
1418 match js = transformJS match js
1421elimConds :: [JS] -> [JS]
1422elimConds js =
1423 let (conds, rest) = partition isCond js in
1424 foldl' eraseCond rest conds
1425 where
1426 isCond :: JS -> Bool
1427 isCond (JSAlloc
1428 fun (Just (JSFunction args (JSCond
1429 [ (JSBinOp "==" (JSNum (JSInt tag)) (JSProj (JSIdent _) "tag"), JSReturn t)
1430 , (JSNoop, JSReturn f)
1431 ])))
1433 | isJSConstant t && isJSConstant f =
1434 True
1436 | JSIdent _ <- t
1437 , JSIdent _ <- f =
1438 True
1440 isCond (JSAlloc
1441 fun (Just (JSFunction args (JSCond
1442 [ (JSBinOp "==" (JSIdent _) c, JSReturn t)
1443 , (JSNoop, JSReturn f)
1444 ])))
1446 | isJSConstant t && isJSConstant f && isJSConstant c =
1447 True
1449 | JSIdent _ <- t
1450 , JSIdent _ <- f
1451 , isJSConstant c =
1452 True
1454 isCond _ = False
1457 eraseCond :: [JS] -> JS -> [JS]
1458 eraseCond js (JSAlloc
1459 fun (Just (JSFunction args (JSCond
1460 [ (c, JSReturn t)
1461 , (_, JSReturn f)
1462 ])
1464 )) = map (inlineFunction fun args (JSTernary c t f)) js
1467removeUselessCons :: [JS] -> [JS]
1468removeUselessCons js =
1469 let (cons, rest) = partition isUseless js in
1470 foldl' eraseCon rest cons
1471 where
1472 isUseless :: JS -> Bool
1473 isUseless (JSAlloc fun (Just JSNull)) = True
1474 isUseless (JSAlloc fun (Just (JSIdent _))) = True
1475 isUseless _ = False
1478 eraseCon :: [JS] -> JS -> [JS]
1479 eraseCon js (JSAlloc fun (Just val)) = map (jsSubst (JSIdent fun) val) js
1482getGlobalCons :: JS -> [(String, JS)]
1483getGlobalCons js = foldJS match (++) [] js
1484 where
1485 match :: JS -> [(String, JS)]
1486 match js
1487 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1488 [(name, con)]
1489 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1490 [(name, con)]
1491 | otherwise =
1492 []
1495getIncludes :: [FilePath] -> IO [String]
1496getIncludes = mapM readFile
1498codegenJavaScript :: CodeGenerator
1499codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
1500 (includes ci) (outputFile ci) (outputType ci)
1502codegenNode :: CodeGenerator
1503codegenNode ci = codegenJS_all Node (simpleDecls ci)
1504 (includes ci) (outputFile ci) (outputType ci)
1506codegenJS_all
1507 :: JSTarget
1508 -> [(Name, SDecl)]
1509 -> [FilePath]
1510 -> FilePath
1511 -> OutputType
1512 -> IO ()
1513codegenJS_all target definitions includes filename outputType = do
1514 let (header, rt) = case target of
1515 Node ->
1516 ("#!/usr/bin/env node\n", "-node")
1517 JavaScript ->
1518 ("", "-browser")
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
1530 , writable = True
1531 })
1532 where
1533 def :: [(String, SDecl)]
1534 def = map (first translateNamespace) definitions
1537 checkForBigInt :: [JS] -> Bool
1538 checkForBigInt js = occur
1539 where
1540 occur :: Bool
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
1547 match js = False
1550 runtime :: String -> String -> String -> [String]
1551 runtime jsbn idrRuntime tgtRuntime =
1552 if checkForBigInt optimized
1553 then [jsbn, idrRuntime, tgtRuntime]
1554 else [idrRuntime, tgtRuntime]
1557 optimized :: [JS]
1558 optimized = translate >>> optimize $ def
1559 where
1560 translate p =
1561 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1562 optimize p =
1563 foldl' (flip ($)) p opt
1565 opt =
1566 [ removeEval
1567 , map inlineJS
1568 , removeIDs
1569 , reduceJS
1570 , map reduceConstants
1571 , initConstructors
1572 , map removeAllocations
1573 , elimDeadLoop
1574 , map elimDuplicateEvals
1575 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1576 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1577 , map removeInstanceChecks
1578 , inlineFunctions
1579 , map reduceContinuations
1580 , extractLocalConstructors
1581 , unfoldLookupTable
1582 , evalCons
1583 , elimConds
1584 , removeUselessCons
1587 functions :: [String]
1588 functions = map compileJS optimized
1590 prelude :: [JS]
1591 prelude =
1592 [ JSAnnotation JSConstructor $
1593 JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1594 JSAssign (JSProj JSThis "k") (JSIdent "k")
1595 ))
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")
1601 ))
1604 mainLoop :: JS
1605 mainLoop =
1606 JSAlloc "main" $ Just $ JSFunction [] (
1607 case target of
1608 Node -> mainFun
1609 JavaScript -> JSCond [ (exists document `jsAnd` isReady, mainFun)
1610 , (exists window, windowMainFun)
1611 , (JSTrue, mainFun)
1614 where
1615 exists :: JS -> JS
1616 exists js = (JSPreOp "typeof " js) `jsNotEq` JSString "undefined"
1618 mainFun :: JS
1619 mainFun = jsTailcall $ jsCall runMain []
1621 window :: JS
1622 window = JSIdent "window"
1624 document :: JS
1625 document = JSIdent "document"
1627 windowMainFun :: JS
1628 windowMainFun = jsMeth window "addEventListener" [
1629 JSString "DOMContentLoaded"
1630 , JSFunction [] ( mainFun )
1631 , JSFalse
1634 isReady :: JS
1635 isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1637 readyState :: JS
1638 readyState = JSProj (JSIdent "document") "readyState"
1641 runMain :: String
1642 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1645 invokeLoop :: JS
1646 invokeLoop = jsCall "main" []
1649translateIdentifier :: String -> String
1650translateIdentifier =
1651 replaceReserved . concatMap replaceBadChars
1652 where replaceBadChars :: Char -> String
1653 replaceBadChars c
1654 | ' ' <- c = "_"
1655 | '_' <- c = "__"
1656 | isDigit c = '_' : show (ord c)
1657 | not (isLetter c && isAscii c) = '_' : show (ord c)
1658 | otherwise = [c]
1659 replaceReserved s
1660 | s `elem` reserved = '_' : s
1661 | otherwise = s
1664 reserved = [ "break"
1665 , "case"
1666 , "catch"
1667 , "continue"
1668 , "debugger"
1669 , "default"
1670 , "delete"
1671 , "do"
1672 , "else"
1673 , "finally"
1674 , "for"
1675 , "function"
1676 , "if"
1677 , "in"
1678 , "instanceof"
1679 , "new"
1680 , "return"
1681 , "switch"
1682 , "this"
1683 , "throw"
1684 , "try"
1685 , "typeof"
1686 , "var"
1687 , "void"
1688 , "while"
1689 , "with"
1691 , "class"
1692 , "enum"
1693 , "export"
1694 , "extends"
1695 , "import"
1696 , "super"
1698 , "implements"
1699 , "interface"
1700 , "let"
1701 , "package"
1702 , "private"
1703 , "protected"
1704 , "public"
1705 , "static"
1706 , "yield"
1710translateNamespace :: Name -> String
1711translateNamespace (UN _) = idrNamespace
1712translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1713translateNamespace (MN _ _) = idrNamespace
1714translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1715translateNamespace NErased = idrNamespace
1718translateName :: Name -> String
1719translateName (UN name) = 'u' : translateIdentifier (str name)
1720translateName (NS name _) = 'n' : translateName name
1721translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1722translateName (SN name) = 's' : translateSpecialName name
1723translateName NErased = "e"
1726translateSpecialName :: SpecialName -> String
1727translateSpecialName 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
1740translateConstant :: Const -> JS
1741translateConstant (I i) = JSNum (JSInt i)
1742translateConstant (Fl f) = JSNum (JSFloat f)
1743translateConstant (Ch c) = JSString $ translateChar c
1744translateConstant (Str s) = JSString $ concatMap translateChar s
1745translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1746translateConstant StrType = JSType JSStringTy
1747translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1748translateConstant (AType ATFloat) = JSType JSFloatTy
1749translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1750translateConstant PtrType = JSType JSPtrTy
1751translateConstant Forgot = JSType JSForgotTy
1752translateConstant (BI i) = jsBigInt $ JSString (show i)
1753translateConstant (B8 b) = JSWord (JSWord8 b)
1754translateConstant (B16 b) = JSWord (JSWord16 b)
1755translateConstant (B32 b) = JSWord (JSWord32 b)
1756translateConstant (B64 b) = JSWord (JSWord64 b)
1757translateConstant c =
1758 jsError $ "Unimplemented Constant: " ++ show c
1761translateChar :: Char -> String
1762translateChar ch
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) "")
1776 | otherwise = [ch]
1777 where
1778 fill :: String -> String
1779 fill s = if length s == 1
1780 then '0' : s
1781 else s
1783 asciiTab =
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']
1790translateDeclaration :: (String, SDecl) -> [JS]
1791translateDeclaration (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 $
1797 JSTernary (
1798 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1799 (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1800 ) (JSApp
1801 (JSIndex
1802 (JSIdent (idrLTNamespace ++ "APPLY"))
1803 (JSProj (JSIdent "mfn0") "tag")
1805 [JSIdent "mfn0", JSIdent "marg0"]
1806 ) JSNull
1810 | (MN _ ev) <- name
1811 , (SChkCase var cases) <- body
1812 , ev == txt "EVAL" =
1813 [ lookupTable "EVAL" [] var cases
1814 , jsDecl $ JSFunction ["marg0"] (JSReturn $
1815 JSTernary (
1816 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1817 (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1818 ) (JSApp
1819 (JSIndex
1820 (JSIdent (idrLTNamespace ++ "EVAL"))
1821 (JSProj (JSIdent "marg0") "tag")
1823 [JSIdent "marg0"]
1824 ) (JSIdent "marg0")
1827 | otherwise =
1828 let fun = translateExpression body in
1829 [jsDecl $ jsFun fun]
1831 where
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
1840 jsFunAux aux c
1843 getTag :: SAlt -> Maybe Int
1844 getTag (SConCase _ tag _ _ _) = Just tag
1845 getTag _ = Nothing
1848 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1849 lookupTable table aux var cases =
1850 JSAlloc (idrLTNamespace ++ table) $ Just (
1851 JSApp (JSFunction [] (
1852 JSSeq $ [
1853 JSAlloc "t" $ Just (JSArray [])
1854 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1855 JSReturn (JSIdent "t")
1857 )) []
1859 where
1860 assignEntries :: [(Int, JS)] -> [JS]
1861 assignEntries entries =
1862 map (\(tag, fun) ->
1863 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1864 ) entries
1867 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1868 lookupEntry aux var alt = do
1869 tag <- getTag alt
1870 return (tag, caseFun aux var alt)
1873 jsDecl :: JS -> JS
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) (
1883 JSSeq $
1884 zipWith assignVar [0..] p ++
1885 map assignAux aux ++
1886 [JSReturn body]
1888 where
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)
1898 p :: [String]
1899 p = map translateName params
1902translateVariableName :: LVar -> String
1903translateVariableName (Loc i) =
1904 jsVar i
1907translateExpression :: SExp -> JS
1908translateExpression (SLet name value body) =
1909 jsLet (translateVariableName name) (
1910 translateExpression value
1911 ) (translateExpression body)
1913translateExpression (SConst cst) =
1914 translateConstant cst
1916translateExpression (SV var) =
1917 JSVar var
1919translateExpression (SApp tc name vars)
1920 | False <- tc =
1921 jsTailcall $ translateFunctionCall name vars
1922 | True <- tc =
1923 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1924 JSReturn $ translateFunctionCall name vars
1925 )]
1926 where
1927 translateFunctionCall name vars =
1928 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1930translateExpression (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" [
1981 JSBinOp "+" (
1982 jsCall "__IDRRT__charCode" [JSVar lhs]
1983 ) (
1984 jsCall "__IDRRT__charCode" [JSVar rhs]
1988 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1989 , (arg:_) <- vars =
1990 jsPackUBits8 (
1991 JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFF))
1994 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1995 , (arg:_) <- vars =
1996 jsPackUBits16 (
1997 JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFFFF))
2000 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
2001 , (arg:_) <- vars =
2002 jsPackUBits32 (
2003 jsMeth (jsMeth (JSVar arg) "and" [
2004 jsBigInt (JSString $ show 0xFFFFFFFF)
2005 ]) "intValue" []
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 =
2016 jsPackUBits8 (
2017 JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2020 | (LLSHR (ITFixed IT16)) <- op
2021 , (lhs:rhs:_) <- vars =
2022 jsPackUBits16 (
2023 JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2026 | (LLSHR (ITFixed IT32)) <- op
2027 , (lhs:rhs:_) <- vars =
2028 jsPackUBits32 (
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 =
2038 jsPackUBits8 (
2039 JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2042 | (LSHL (ITFixed IT16)) <- op
2043 , (lhs:rhs:_) <- vars =
2044 jsPackUBits16 (
2045 JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)
2048 | (LSHL (ITFixed IT32)) <- op
2049 , (lhs:rhs:_) <- vars =
2050 jsPackUBits32 (
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 =
2062 jsPackUBits8 (
2063 JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2066 | (LAnd (ITFixed IT16)) <- op
2067 , (lhs:rhs:_) <- vars =
2068 jsPackUBits16 (
2069 JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2072 | (LAnd (ITFixed IT32)) <- op
2073 , (lhs:rhs:_) <- vars =
2074 jsPackUBits32 (
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 =
2084 jsPackUBits8 (
2085 JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2088 | (LOr (ITFixed IT16)) <- op
2089 , (lhs:rhs:_) <- vars =
2090 jsPackUBits16 (
2091 JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2094 | (LOr (ITFixed IT32)) <- op
2095 , (lhs:rhs:_) <- vars =
2096 jsPackUBits32 (
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 =
2106 jsPackUBits8 (
2107 JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2110 | (LXOr (ITFixed IT16)) <- op
2111 , (lhs:rhs:_) <- vars =
2112 jsPackUBits16 (
2113 JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2116 | (LXOr (ITFixed IT32)) <- op
2117 , (lhs:rhs:_) <- vars =
2118 jsPackUBits32 (
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 =
2128 jsPackUBits8 (
2129 JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2132 | (LPlus (ATInt (ITFixed IT16))) <- op
2133 , (lhs:rhs:_) <- vars =
2134 jsPackUBits16 (
2135 JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2138 | (LPlus (ATInt (ITFixed IT32))) <- op
2139 , (lhs:rhs:_) <- vars =
2140 jsPackUBits32 (
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 =
2152 jsPackUBits8 (
2153 JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2156 | (LMinus (ATInt (ITFixed IT16))) <- op
2157 , (lhs:rhs:_) <- vars =
2158 jsPackUBits16 (
2159 JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2162 | (LMinus (ATInt (ITFixed IT32))) <- op
2163 , (lhs:rhs:_) <- vars =
2164 jsPackUBits32 (
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 =
2176 jsPackUBits8 (
2177 JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2180 | (LTimes (ATInt (ITFixed IT16))) <- op
2181 , (lhs:rhs:_) <- vars =
2182 jsPackUBits16 (
2183 JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2186 | (LTimes (ATInt (ITFixed IT32))) <- op
2187 , (lhs:rhs:_) <- vars =
2188 jsPackUBits32 (
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 =
2200 jsPackUBits8 (
2201 JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2204 | (LEq (ATInt (ITFixed IT16))) <- op
2205 , (lhs:rhs:_) <- vars =
2206 jsPackUBits16 (
2207 JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2210 | (LEq (ATInt (ITFixed IT32))) <- op
2211 , (lhs:rhs:_) <- vars =
2212 jsPackUBits32 (
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 =
2224 jsPackUBits8 (
2225 JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2228 | (LLt (ITFixed IT16)) <- op
2229 , (lhs:rhs:_) <- vars =
2230 jsPackUBits16 (
2231 JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2234 | (LLt (ITFixed IT32)) <- op
2235 , (lhs:rhs:_) <- vars =
2236 jsPackUBits32 (
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 =
2245 jsPackUBits8 (
2246 JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2249 | (LLe (ITFixed IT16)) <- op
2250 , (lhs:rhs:_) <- vars =
2251 jsPackUBits16 (
2252 JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2255 | (LLe (ITFixed IT32)) <- op
2256 , (lhs:rhs:_) <- vars =
2257 jsPackUBits32 (
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 =
2266 jsPackUBits8 (
2267 JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2270 | (LGt (ITFixed IT16)) <- op
2271 , (lhs:rhs:_) <- vars =
2272 jsPackUBits16 (
2273 JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2275 | (LGt (ITFixed IT32)) <- op
2276 , (lhs:rhs:_) <- vars =
2277 jsPackUBits32 (
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 =
2286 jsPackUBits8 (
2287 JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2290 | (LGe (ITFixed IT16)) <- op
2291 , (lhs:rhs:_) <- vars =
2292 jsPackUBits16 (
2293 JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2295 | (LGe (ITFixed IT32)) <- op
2296 , (lhs:rhs:_) <- vars =
2297 jsPackUBits32 (
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 =
2306 jsPackUBits8 (
2307 JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2310 | (LUDiv (ITFixed IT16)) <- op
2311 , (lhs:rhs:_) <- vars =
2312 jsPackUBits16 (
2313 JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))
2316 | (LUDiv (ITFixed IT32)) <- op
2317 , (lhs:rhs:_) <- vars =
2318 jsPackUBits32 (
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 =
2327 jsPackSBits8 (
2328 JSBinOp "/" (
2329 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2330 ) (
2331 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2335 | (LSDiv (ATInt (ITFixed IT16))) <- op
2336 , (lhs:rhs:_) <- vars =
2337 jsPackSBits16 (
2338 JSBinOp "/" (
2339 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2340 ) (
2341 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2345 | (LSDiv (ATInt (ITFixed IT32))) <- op
2346 , (lhs:rhs:_) <- vars =
2347 jsPackSBits32 (
2348 JSBinOp "/" (
2349 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2350 ) (
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 =
2360 jsPackSBits8 (
2361 JSBinOp "%" (
2362 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)
2363 ) (
2364 jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)
2368 | (LSRem (ATInt (ITFixed IT16))) <- op
2369 , (lhs:rhs:_) <- vars =
2370 jsPackSBits16 (
2371 JSBinOp "%" (
2372 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)
2373 ) (
2374 jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)
2378 | (LSRem (ATInt (ITFixed IT32))) <- op
2379 , (lhs:rhs:_) <- vars =
2380 jsPackSBits32 (
2381 JSBinOp "%" (
2382 jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)
2383 ) (
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" []
2407 | (LPlus _) <- op
2408 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
2409 | (LMinus _) <- op
2410 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
2411 | (LTimes _) <- op
2412 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
2413 | (LSDiv _) <- op
2414 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
2415 | (LSRem _) <- op
2416 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
2417 | (LEq _) <- op
2418 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2419 | (LSLt _) <- op
2420 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2421 | (LSLe _) <- op
2422 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
2423 | (LSGt _) <- op
2424 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
2425 | (LSGe _) <- op
2426 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
2427 | (LAnd _) <- op
2428 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
2429 | (LOr _) <- op
2430 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
2431 | (LXOr _) <- op
2432 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
2433 | (LSHL _) <- op
2434 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
2435 | (LASHR _) <- op
2436 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
2437 | (LCompl _) <- op
2438 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
2440 | LStrConcat <- op
2441 , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2442 | LStrEq <- op
2443 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
2444 | LStrLt <- op
2445 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
2446 | LStrLen <- op
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
2461 | LFloatStr <- op
2462 , (arg:_) <- vars = jsCall "String" [JSVar arg]
2463 | LStrFloat <- op
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]
2474 | LFExp <- op
2475 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
2476 | LFLog <- op
2477 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
2478 | LFSin <- op
2479 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
2480 | LFCos <- op
2481 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
2482 | LFTan <- op
2483 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
2484 | LFASin <- op
2485 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
2486 | LFACos <- op
2487 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
2488 | LFATan <- op
2489 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
2490 | LFSqrt <- op
2491 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
2492 | LFFloor <- op
2493 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
2494 | LFCeil <- op
2495 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
2497 | LStrCons <- op
2498 , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2499 | LStrHead <- op
2500 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
2501 | LStrRev <- op
2502 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
2503 | LStrIndex <- op
2504 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
2505 | LStrTail <- op
2506 , (arg:_) <- vars = let v = translateVariableName arg in
2507 JSApp (JSProj (JSIdent v) "substr") [
2508 JSNum (JSInt 1),
2509 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
2511 | LSystemInfo <- op
2512 , (arg:_) <- vars = jsCall "__IDRRT__systemInfo" [JSVar arg]
2513 | LNullPtr <- op
2514 , (_) <- vars = JSNull
2516 where
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)
2524translateExpression (SError msg) =
2525 jsError msg
2527translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
2528 jsCall (idrRTNamespace ++ "print") [JSVar var]
2530translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
2531 JSBinOp "==" (JSVar var) JSNull
2533translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
2534 JSBinOp "==" (JSVar lhs) (JSVar rhs)
2536translateExpression (SForeign _ _ "idris_time" []) =
2537 JSRaw "(new Date()).getTime()"
2539translateExpression (SForeign _ _ fun args) =
2540 JSFFI fun (map generateWrapper args)
2541 where
2542 generateWrapper (ffunc, name)
2543 | FFunction <- ffunc =
2544 JSApp (
2545 JSIdent $ idrRTNamespace ++ "ffiWrap"
2546 ) [JSIdent $ translateVariableName name]
2547 | FFunctionIO <- ffunc =
2548 JSApp (
2549 JSIdent $ idrRTNamespace ++ "ffiWrap"
2550 ) [JSIdent $ translateVariableName name]
2552 generateWrapper (_, name) =
2553 JSIdent $ translateVariableName name
2555translateExpression patterncase
2556 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
2557 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
2558 where
2559 caseHelper var cases param =
2560 JSApp (JSFunction [param] (
2561 JSCond $ map (expandCase param . translateCaseCond param) cases
2562 )) [JSVar var]
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)
2579translateExpression (SCon i name vars) =
2580 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
2581 , JSArray $ map JSVar vars
2584translateExpression (SUpdate var@(Loc i) e) =
2585 JSAssign (JSVar var) (translateExpression e)
2587translateExpression (SProj var i) =
2588 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
2590translateExpression SNothing = JSNull
2592translateExpression e =
2593 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2596data CaseType = ConCase Int
2597 | TypeCase JSType
2598 | DefaultCase
2599 deriving Eq
2602data Cond = CaseCond CaseType
2603 | RawCond JS
2606translateCaseCond :: String -> SAlt -> (Cond, JS)
2607translateCaseCond _ cse@(SDefaultCase _) =
2608 (CaseCond DefaultCase, translateCase Nothing cse)
2610translateCaseCond 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
2618 where
2619 matchHelper :: JSType -> (Cond, JS)
2620 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2622translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2623 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2624 (RawCond cond, translateCase Nothing cse)
2626translateCaseCond var cse@(SConstCase cst _) =
2627 let cond = JSIdent var `jsEq` translateConstant cst in
2628 (RawCond cond, translateCase Nothing cse)
2630translateCaseCond var cse@(SConCase _ tag _ _ _) =
2631 (CaseCond $ ConCase tag, translateCase (Just var) cse)
2634translateCase :: Maybe String -> SAlt -> JS
2635translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2636translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2637translateCase (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"