git.iko.soy/Idris-dev
on fb019f0 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
2161 lines 67 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 = show b
271 | JSWord16 b <- word = show b
272 | JSWord32 b <- word = 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 "=="
300jsAnd :: JS -> JS -> JS
301jsAnd = JSBinOp "&&"
304jsOr :: JS -> JS -> JS
305jsOr = JSBinOp "||"
308jsType :: JS
309jsType = JSIdent $ idrRTNamespace ++ "Type"
312jsCon :: JS
313jsCon = JSIdent $ idrRTNamespace ++ "Con"
316jsTag :: JS -> JS
317jsTag obj = JSProj obj "tag"
320jsTypeTag :: JS -> JS
321jsTypeTag obj = JSProj obj "type"
324jsBigInt :: JS -> JS
325jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
326jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
327jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
330jsVar :: Int -> String
331jsVar = ("__var_" ++) . show
334jsLet :: String -> JS -> JS -> JS
335jsLet name value body =
336 JSApp (
337 JSFunction [name] (
338 JSReturn body
339 )
340 ) [value]
343jsError :: String -> JS
344jsError err = JSApp (JSFunction [] (JSError err)) []
347foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
348foldJS tr add acc js =
349 fold js
350 where
351 fold js
352 | JSFunction args body <- js =
353 add (tr js) (fold body)
354 | JSSeq seq <- js =
355 add (tr js) $ foldl' add acc (map fold seq)
356 | JSReturn ret <- js =
357 add (tr js) (fold ret)
358 | JSApp lhs rhs <- js =
359 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
360 | JSNew _ args <- js =
361 add (tr js) $ foldl' add acc $ map fold args
362 | JSBinOp _ lhs rhs <- js =
363 add (tr js) $ add (fold lhs) (fold rhs)
364 | JSPreOp _ val <- js =
365 add (tr js) $ fold val
366 | JSPostOp _ val <- js =
367 add (tr js) $ fold val
368 | JSProj obj _ <- js =
369 add (tr js) (fold obj)
370 | JSArray vals <- js =
371 add (tr js) $ foldl' add acc $ map fold vals
372 | JSAssign lhs rhs <- js =
373 add (tr js) $ add (fold lhs) (fold rhs)
374 | JSIndex lhs rhs <- js =
375 add (tr js) $ add (fold lhs) (fold rhs)
376 | JSAlloc _ val <- js =
377 add (tr js) $ fromMaybe acc $ fmap fold val
378 | JSTernary c t f <- js =
379 add (tr js) $ add (fold c) (add (fold t) (fold f))
380 | JSParens val <- js =
381 add (tr js) $ fold val
382 | JSCond conds <- js =
383 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
384 | JSWhile cond body <- js =
385 add (tr js) $ add (fold cond) (fold body)
386 | JSFFI raw args <- js =
387 add (tr js) $ foldl' add acc $ map fold args
388 | JSAnnotation a js <- js =
389 add (tr js) $ fold js
390 | otherwise =
391 tr js
394transformJS :: (JS -> JS) -> JS -> JS
395transformJS tr js =
396 transformHelper js
397 where
398 transformHelper :: JS -> JS
399 transformHelper js
400 | JSFunction args body <- js = JSFunction args $ tr body
401 | JSSeq seq <- js = JSSeq $ map tr seq
402 | JSReturn ret <- js = JSReturn $ tr ret
403 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
404 | JSNew con args <- js = JSNew con $ map tr args
405 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
406 | JSPreOp op val <- js = JSPreOp op (tr val)
407 | JSPostOp op val <- js = JSPostOp op (tr val)
408 | JSProj obj field <- js = JSProj (tr obj) field
409 | JSArray vals <- js = JSArray $ map tr vals
410 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
411 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
412 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
413 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
414 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
415 | JSParens val <- js = JSParens $ tr val
416 | JSWhile cond body <- js = JSWhile (tr cond) (tr body)
417 | JSFFI raw args <- js = JSFFI raw (map tr args)
418 | JSAnnotation a js <- js = JSAnnotation a (tr js)
419 | otherwise = js
422moveJSDeclToTop :: String -> [JS] -> [JS]
423moveJSDeclToTop decl js = move ([], js)
424 where
425 move :: ([JS], [JS]) -> [JS]
426 move (front, js@(JSAnnotation _ (JSAlloc name _)):back)
427 | name == decl = js : front ++ back
429 move (front, js@(JSAlloc name _):back)
430 | name == decl = js : front ++ back
432 move (front, js:back) =
433 move (front ++ [js], back)
436jsSubst :: JS -> JS -> JS -> JS
437jsSubst var new old
438 | var == old = new
440jsSubst (JSIdent var) new (JSVar old)
441 | var == translateVariableName old = new
442 | otherwise = JSVar old
444jsSubst var new old@(JSIdent _)
445 | var == old = new
446 | otherwise = old
448jsSubst var new (JSArray fields) =
449 JSArray (map (jsSubst var new) fields)
451jsSubst var new (JSNew con vals) =
452 JSNew con $ map (jsSubst var new) vals
454jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
455 | var `notElem` args =
456 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
457 map (jsSubst (JSIdent var) new) vals
458 )
459 | otherwise =
460 JSApp (JSProj (JSFunction args body) "apply") (
461 map (jsSubst (JSIdent var) new) vals
462 )
464jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
465 | var /= arg =
466 JSApp (JSFunction [arg] (
467 jsSubst (JSIdent var) new body
468 )) $ map (jsSubst (JSIdent var) new) vals
469 | otherwise =
470 JSApp (JSFunction [arg] (
471 body
472 )) $ map (jsSubst (JSIdent var) new) vals
474jsSubst var new js = transformJS (jsSubst var new) js
477removeAllocations :: JS -> JS
478removeAllocations (JSSeq body) =
479 let opt = removeHelper (map removeAllocations body) in
480 case opt of
481 [ret] -> ret
482 _ -> JSSeq opt
483 where
484 removeHelper :: [JS] -> [JS]
485 removeHelper [js] = [js]
486 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
487 map (jsSubst (JSIdent name) val) (removeHelper js)
488 removeHelper (j:js) = j : removeHelper js
490removeAllocations js = transformJS removeAllocations js
493isJSConstant :: JS -> Bool
494isJSConstant js
495 | JSString _ <- js = True
496 | JSNum _ <- js = True
497 | JSType _ <- js = True
498 | JSNull <- js = True
499 | JSArray vals <- js = all isJSConstant vals
501 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
503 | otherwise = False
505isJSConstantConstructor :: [String] -> JS -> Bool
506isJSConstantConstructor constants js
507 | isJSConstant js =
508 True
509 | JSArray vals <- js =
510 all (isJSConstantConstructor constants) vals
511 | JSNew "__IDRRT__Con" args <- js =
512 all (isJSConstantConstructor constants) args
513 | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
514 , name `elem` constants =
515 True
516 | JSIdent name <- js
517 , name `elem` constants =
518 True
519 | otherwise = False
522inlineJS :: JS -> JS
523inlineJS = inlineAssign . inlineError . inlineApply . inlineCaseMatch . inlineJSLet
524 where
525 inlineJSLet :: JS -> JS
526 inlineJSLet (JSApp (JSFunction [arg] (JSReturn ret)) [val])
527 | opt <- inlineJSLet val =
528 inlineJS $ jsSubst (JSIdent arg) opt ret
530 inlineJSLet js = transformJS inlineJSLet js
533 inlineCaseMatch (JSReturn (JSApp (JSFunction ["cse"] body) [val]))
534 | opt <- inlineCaseMatch val =
535 inlineCaseMatch $ jsSubst (JSIdent "cse") opt body
537 inlineCaseMatch js = transformJS inlineCaseMatch js
540 inlineApply js
541 | JSApp (
542 JSProj (JSFunction args (JSReturn body)) "apply"
543 ) [JSThis, JSProj var "vars"] <- js =
544 inlineApply $ inlineApply' var args body 0
545 | JSReturn (JSApp (
546 JSProj (JSFunction args body@(JSCond _)) "apply"
547 ) [JSThis, JSProj var "vars"]) <- js =
548 inlineApply $ inlineApply' var args body 0
549 where
550 inlineApply' _ [] body _ = body
551 inlineApply' var (a:as) body n =
552 inlineApply' var as (
553 jsSubst (JSIdent a) (
554 JSIndex (JSProj var "vars") (JSNum (JSInt n))
555 ) body
556 ) (n + 1)
558 inlineApply js = transformJS inlineApply js
561 inlineError (JSReturn (JSApp (JSFunction [] error@(JSError _)) [])) =
562 inlineError error
564 inlineError js = transformJS inlineError js
567 inlineAssign (JSAssign lhs rhs)
568 | JSVar _ <- lhs
569 , JSVar _ <- rhs
570 , lhs == rhs =
571 lhs
573 inlineAssign (JSAssign lhs rhs)
574 | JSIdent _ <- lhs
575 , JSIdent _ <- rhs
576 , lhs == rhs =
577 lhs
579 inlineAssign js = transformJS inlineAssign js
582removeEval :: [JS] -> [JS]
583removeEval js =
584 let (ret, isReduced) = checkEval js in
585 if isReduced
586 then removeEvalApp ret
587 else ret
588 where
589 removeEvalApp js = catMaybes (map removeEvalApp' js)
590 where
591 removeEvalApp' :: JS -> Maybe JS
592 removeEvalApp' (JSAlloc "__IDR__mEVAL0" _) = Nothing
593 removeEvalApp' js = Just $ transformJS match js
594 where
595 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val
596 match js = transformJS match js
598 checkEval :: [JS] -> ([JS], Bool)
599 checkEval js = foldr f ([], False) $ map checkEval' js
600 where
601 f :: (Maybe JS, Bool) -> ([JS], Bool) -> ([JS], Bool)
602 f (Just js, isReduced) (ret, b) = (js : ret, isReduced || b)
603 f (Nothing, isReduced) (ret, b) = (ret, isReduced || b)
606 checkEval' :: JS -> (Maybe JS, Bool)
607 checkEval' (JSAlloc "__IDRLT__EVAL" (Just (JSApp (JSFunction [] (
608 JSSeq [ _
609 , JSReturn (JSIdent "t")
610 ]
611 )) []))) = (Nothing, True)
613 checkEval' js = (Just js, False)
616reduceJS :: [JS] -> [JS]
617reduceJS js = moveJSDeclToTop "__IDRRT__Con" $ reduceLoop [] ([], js)
620funName :: JS -> String
621funName (JSAlloc fun _) = fun
624elimDeadLoop :: [JS] -> [JS]
625elimDeadLoop js
626 | ret <- deadEvalApplyCases js
627 , ret /= js = elimDeadLoop ret
628 | otherwise = js
631deadEvalApplyCases :: [JS] -> [JS]
632deadEvalApplyCases js =
633 let tags = sort $ nub $ concatMap (getTags) js in
634 map (removeHelper tags) js
635 where
636 getTags :: JS -> [Int]
637 getTags = foldJS match (++) []
638 where
639 match js
640 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
641 | otherwise = []
644 removeHelper :: [Int] -> JS -> JS
645 removeHelper tags (JSAlloc fun (Just (
646 JSApp (JSFunction [] (JSSeq seq)) []))
647 ) =
648 (JSAlloc fun (Just (
649 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
650 )
652 removeHelper _ js = js
655 remover :: [Int] -> [JS] -> [JS]
656 remover tags (
657 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
658 )
659 | tag `notElem` tags = remover tags js
661 remover tags (j:js) = j : remover tags js
662 remover _ [] = []
665initConstructors :: [JS] -> [JS]
666initConstructors js =
667 let tags = nub $ sort $ concat (map getTags js) in
668 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
669 where
670 rearrangePrelude :: [JS] -> [JS]
671 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
674 getTags :: JS -> [Int]
675 getTags = foldJS match (++) []
676 where
677 match js
678 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
679 | otherwise = []
682 replaceConstructors :: [Int] -> [JS] -> [JS]
683 replaceConstructors tags js = map (replaceHelper tags) js
684 where
685 replaceHelper :: [Int] -> JS -> JS
686 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
687 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
689 replaceHelper tags js = transformJS (replaceHelper tags) js
692 createConstant :: Int -> JS
693 createConstant tag =
694 JSAlloc (idrCTRNamespace ++ show tag) (Just (
695 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
696 ))
699removeIDs :: [JS] -> [JS]
700removeIDs js =
701 case partition isID js of
702 ([], rest) -> rest
703 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
704 where isID :: JS -> Bool
705 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
706 | JSReturn (JSVar _) <- last body = True
708 isID _ = False
711 idFor :: JS -> (String, Int)
712 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
713 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
716 removeIDCall :: [(String, Int)] -> JS -> JS
717 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
718 JSReturn (JSApp (JSIdent fun) args)
719 )])
720 | Just pos <- lookup fun ids
721 , pos < length args = args !! pos
723 removeIDCall ids (JSNew _ [JSFunction [] (
724 JSReturn (JSApp (JSIdent fun) args)
725 )])
726 | Just pos <- lookup fun ids
727 , pos < length args = args !! pos
729 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
730 | Just pos <- lookup fun ids
731 , pos < length args = args !! pos
733 removeIDCall ids js = transformJS (removeIDCall ids) js
736inlineFunctions :: [JS] -> [JS]
737inlineFunctions js =
738 inlineHelper ([], js)
739 where
740 inlineHelper :: ([JS], [JS]) -> [JS]
741 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
742 | countAll fun front + countAll fun back == 0 =
743 inlineHelper (front, back)
744 | Just new <- inlineAble (
745 countAll fun front + countAll fun back
746 ) fun args body =
747 let f = map (inline fun args new) in
748 inlineHelper (f front, f back)
750 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
751 inlineHelper (front, []) = front
754 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
755 inlineAble 1 fun args (JSReturn body)
756 | nonRecur fun body =
757 if all (<= 1) (map ($ body) (map countIDOccurences args))
758 then Just body
759 else Nothing
761 inlineAble _ _ _ _ = Nothing
764 inline :: String -> [String] -> JS -> JS -> JS
765 inline fun args body js = inline' js
766 where
767 inline' :: JS -> JS
768 inline' (JSApp (JSIdent name) vals)
769 | name == fun =
770 let (js, phs) = insertPlaceHolders args body in
771 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
773 inline' js = transformJS inline' js
775 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
776 insertPlaceHolders args body = insertPlaceHolders' args body []
777 where
778 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
779 insertPlaceHolders' (a:as) body ph
780 | (body', ph') <- insertPlaceHolders' as body ph =
781 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
782 (jsSubst (JSIdent a) phvar body', phvar : ph')
784 insertPlaceHolders' [] body ph = (body, ph)
787 nonRecur :: String -> JS -> Bool
788 nonRecur name body = countInvokations name body == 0
791 countAll :: String -> [JS] -> Int
792 countAll name js = sum $ map (countInvokations name) js
795 countIDOccurences :: String -> JS -> Int
796 countIDOccurences name = foldJS match (+) 0
797 where
798 match :: JS -> Int
799 match js
800 | JSIdent ident <- js
801 , name == ident = 1
802 | otherwise = 0
805 countInvokations :: String -> JS -> Int
806 countInvokations name = foldJS match (+) 0
807 where
808 match :: JS -> Int
809 match js
810 | JSApp (JSIdent ident) _ <- js
811 , name == ident = 1
812 | JSNew con _ <- js
813 , name == con = 1
814 | otherwise = 0
817reduceContinuations :: JS -> JS
818reduceContinuations = inlineTC . reduceJS
819 where
820 reduceJS :: JS -> JS
821 reduceJS (JSNew "__IDRRT__Cont" [JSFunction [] (
822 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
823 )]) = reduceJS js
825 reduceJS js = transformJS reduceJS js
828 inlineTC :: JS -> JS
829 inlineTC js
830 | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
831 JSReturn (JSNew "__IDRRT__Cont" [JSFunction [] (
832 JSReturn ret@(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
833 JSReturn (JSNew "__IDRRT__Cont" _)
834 )])
835 )])
836 )] <- js = inlineTC ret
838 inlineTC js = transformJS inlineTC js
843reduceConstant :: JS -> JS
844reduceConstant
845 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
846 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
847 )])
848 | JSNum num <- val = val
849 | JSBinOp op lhs rhs <- val =
850 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
852 | JSApp (JSProj lhs op) [rhs] <- val
853 , op `elem` [ "subtract"
854 , "add"
855 , "multiply"
856 , "divide"
857 , "mod"
858 , "equals"
859 , "lesser"
860 , "lesserOrEquals"
861 , "greater"
862 , "greaterOrEquals"
863 ] = val
865reduceConstant (JSApp ident [(JSParens js)]) =
866 JSApp ident [reduceConstant js]
868reduceConstant js = transformJS reduceConstant js
871reduceConstants :: JS -> JS
872reduceConstants js
873 | ret <- reduceConstant js
874 , ret /= js = reduceConstants ret
875 | otherwise = js
878elimDuplicateEvals :: JS -> JS
879elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
880 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
881 where
882 elimHelper :: [JS] -> [JS]
883 elimHelper (j@(JSAlloc var (Just val)):js) =
884 j : map (jsSubst val (JSIdent var)) (elimHelper js)
885 elimHelper (j:js) =
886 j : elimHelper js
887 elimHelper [] = []
889elimDuplicateEvals js = js
892optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
893optimizeRuntimeCalls fun tc js =
894 optTC tc : map optHelper js
895 where
896 optHelper :: JS -> JS
897 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
898 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
899 ])
900 | n == fun = JSApp (JSIdent tc) $ map optHelper args
902 optHelper js = transformJS optHelper js
905 optTC :: String -> JS
906 optTC tc@"__IDRRT__EVALTC" =
907 JSAlloc tc (Just $ JSFunction ["arg0"] (
908 JSSeq [ JSAlloc "ret" $ Just (
909 JSTernary (
910 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
911 (hasProp "__IDRLT__EVAL" "arg0")
912 ) (JSApp
913 (JSIndex
914 (JSIdent "__IDRLT__EVAL")
915 (JSProj (JSIdent "arg0") "tag")
916 )
917 [JSIdent "arg0"]
918 ) (JSIdent "arg0")
919 )
920 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
921 JSAssign (JSIdent "ret") (
922 JSApp (JSProj (JSIdent "ret") "k") []
923 )
924 )
925 , JSReturn $ JSIdent "ret"
926 ]
927 ))
929 optTC tc@"__IDRRT__APPLYTC" =
930 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
931 JSSeq [ JSAlloc "ret" $ Just (
932 JSTernary (
933 (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
934 (hasProp "__IDRLT__APPLY" "fn0")
935 ) (JSApp
936 (JSIndex
937 (JSIdent "__IDRLT__APPLY")
938 (JSProj (JSIdent "fn0") "tag")
939 )
940 [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
941 ) JSNull
942 )
943 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
944 JSAssign (JSIdent "ret") (
945 JSApp (JSProj (JSIdent "ret") "k") []
946 )
947 )
948 , JSReturn $ JSIdent "ret"
949 ]
950 ))
953 hasProp :: String -> String -> JS
954 hasProp table var =
955 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
958unfoldLookupTable :: [JS] -> [JS]
959unfoldLookupTable input =
960 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
961 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
962 js = applyunfold in
963 adaptRuntime $ expandCons evals applys js
964 where
965 adaptRuntime :: [JS] -> [JS]
966 adaptRuntime =
967 adaptEvalTC . adaptApplyTC . adaptEval . adaptApply . adaptCon
970 adaptApply :: [JS] -> [JS]
971 adaptApply js = adaptApply' [] js
972 where
973 adaptApply' :: [JS] -> [JS] -> [JS]
974 adaptApply' front ((JSAlloc "__IDR__mAPPLY0" (Just _)):back) =
975 front ++ (new:back)
977 adaptApply' front (next:back) =
978 adaptApply' (front ++ [next]) back
980 adaptApply' front [] = front
982 new =
983 JSAlloc "__IDR__mAPPLY0" (Just $ JSFunction ["mfn0", "marg0"] (JSReturn $
984 JSTernary (
985 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
986 (JSProj (JSIdent "mfn0") "app")
987 ) (JSApp
988 (JSProj (JSIdent "mfn0") "app")
989 [JSIdent "mfn0", JSIdent "marg0"]
990 ) JSNull
991 )
992 )
995 adaptApplyTC :: [JS] -> [JS]
996 adaptApplyTC js = adaptApplyTC' [] js
997 where
998 adaptApplyTC' :: [JS] -> [JS] -> [JS]
999 adaptApplyTC' front ((JSAlloc "__IDRRT__APPLYTC" (Just _)):back) =
1000 front ++ (new:back)
1002 adaptApplyTC' front (next:back) =
1003 adaptApplyTC' (front ++ [next]) back
1005 adaptApplyTC' front [] = front
1007 new =
1008 JSAlloc "__IDRRT__APPLYTC" (Just $ JSFunction ["mfn0", "marg0"] (
1009 JSSeq [ JSAlloc "ret" $ Just (
1010 JSTernary (
1011 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1012 (JSProj (JSIdent "mfn0") "app")
1013 ) (JSApp
1014 (JSProj (JSIdent "mfn0") "app")
1015 [JSIdent "mfn0", JSIdent "marg0"]
1016 ) JSNull
1018 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1019 JSAssign (JSIdent "ret") (
1020 JSApp (JSProj (JSIdent "ret") "k") []
1023 , JSReturn $ JSIdent "ret"
1025 ))
1028 adaptEval :: [JS] -> [JS]
1029 adaptEval js = adaptEval' [] js
1030 where
1031 adaptEval' :: [JS] -> [JS] -> [JS]
1032 adaptEval' front ((JSAlloc "__IDR__mEVAL0" (Just _)):back) =
1033 front ++ (new:back)
1035 adaptEval' front (next:back) =
1036 adaptEval' (front ++ [next]) back
1038 adaptEval' front [] = front
1040 new =
1041 JSAlloc "__IDR__mEVAL0" (Just $ JSFunction ["marg0"] (JSReturn $
1042 JSTernary (
1043 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1044 (JSProj (JSIdent "marg0") "eval")
1045 ) (JSApp
1046 (JSProj (JSIdent "marg0") "eval")
1047 [JSIdent "marg0"]
1048 ) (JSIdent "marg0")
1053 adaptEvalTC :: [JS] -> [JS]
1054 adaptEvalTC js = adaptEvalTC' [] js
1055 where
1056 adaptEvalTC' :: [JS] -> [JS] -> [JS]
1057 adaptEvalTC' front ((JSAlloc "__IDRRT__EVALTC" (Just _)):back) =
1058 front ++ (new:back)
1060 adaptEvalTC' front (next:back) =
1061 adaptEvalTC' (front ++ [next]) back
1063 adaptEvalTC' front [] = front
1065 new =
1066 JSAlloc "__IDRRT__EVALTC" (Just $ JSFunction ["marg0"] (
1067 JSSeq [ JSAlloc "ret" $ Just (
1068 JSTernary (
1069 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1070 (JSProj (JSIdent "marg0") "eval")
1071 ) (JSApp
1072 (JSProj (JSIdent "marg0") "eval")
1073 [JSIdent "marg0"]
1074 ) (JSIdent "marg0")
1076 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
1077 JSAssign (JSIdent "ret") (
1078 JSApp (JSProj (JSIdent "ret") "k") []
1081 , JSReturn $ JSIdent "ret"
1083 ))
1086 adaptCon js =
1087 adaptCon' [] js
1088 where
1089 adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =
1090 front ++ (new:back)
1092 adaptCon' front (next:back) =
1093 adaptCon' (front ++ [next]) back
1095 adaptCon' front [] = front
1098 new =
1099 JSAnnotation JSConstructor $
1100 JSAlloc "__IDRRT__Con" (Just $
1101 JSFunction newArgs (
1102 JSSeq (map newVar newArgs)
1105 where
1106 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
1107 newArgs = ["tag", "eval", "app", "vars"]
1110 unfoldLT :: String -> [JS] -> ([Int], [JS])
1111 unfoldLT lt js =
1112 let (table, code) = extractLT lt js
1113 expanded = expandLT lt table in
1114 (map fst expanded, map snd expanded ++ code)
1117 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
1118 expandCons evals applys js =
1119 map expandCons' js
1120 where
1121 expandCons' :: JS -> JS
1122 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
1123 | evalid <- getId "__IDRLT__EVAL" tag evals
1124 , applyid <- getId "__IDRLT__APPLY" tag applys =
1125 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
1126 , maybe JSNull JSIdent evalid
1127 , maybe JSNull JSIdent applyid
1128 , JSArray (map expandCons' args)
1131 expandCons' js = transformJS expandCons' js
1134 getId :: String -> Int -> [Int] -> Maybe String
1135 getId lt tag entries
1136 | tag `elem` entries = Just $ ltIdentifier lt tag
1137 | otherwise = Nothing
1140 ltIdentifier :: String -> Int -> String
1141 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
1142 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
1145 extractLT :: String -> [JS] -> (JS, [JS])
1146 extractLT lt js =
1147 extractLT' ([], js)
1148 where
1149 extractLT' :: ([JS], [JS]) -> (JS, [JS])
1150 extractLT' (front, js@(JSAlloc fun _):back)
1151 | fun == lt = (js, front ++ back)
1153 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
1154 extractLT' (front, back) = (JSNoop, front ++ back)
1157 expandLT :: String -> JS -> [(Int, JS)]
1158 expandLT lt (
1159 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
1160 ) = catMaybes (map expandEntry seq)
1161 where
1162 expandEntry :: JS -> Maybe (Int, JS)
1163 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
1164 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
1166 expandEntry js = Nothing
1168 expandLT lt JSNoop = []
1171removeInstanceChecks :: JS -> JS
1172removeInstanceChecks (JSCond conds) =
1173 removeNoopConds $ JSCond $ eliminateDeadBranches $ map (
1174 removeHelper *** removeInstanceChecks
1175 ) conds
1176 where
1177 removeHelper (
1178 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
1179 ) = removeHelper check
1180 removeHelper js = js
1183 eliminateDeadBranches ((JSTrue, cond):_) = [(JSNoop, cond)]
1184 eliminateDeadBranches [(_, js)] = [(JSNoop, js)]
1185 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
1186 eliminateDeadBranches [] = []
1189 removeNoopConds :: JS -> JS
1190 removeNoopConds (JSCond [(JSNoop, js)]) = js
1191 removeNoopConds js = js
1193removeInstanceChecks js = transformJS removeInstanceChecks js
1196reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
1197reduceLoop reduced (cons, program) =
1198 case partition findConstructors program of
1199 ([], js) -> cons ++ js
1200 (candidates, rest) ->
1201 let names = reduced ++ map funName candidates in
1202 reduceLoop names (
1203 cons ++ map reduce candidates, map (reduceCall names) rest
1205 where findConstructors :: JS -> Bool
1206 findConstructors js
1207 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
1208 reducable $ last body
1209 | otherwise = False
1210 where reducable :: JS -> Bool
1211 reducable js
1212 | JSReturn ret <- js = reducable ret
1213 | JSNew _ args <- js = and $ map reducable args
1214 | JSArray fields <- js = and $ map reducable fields
1215 | JSNum _ <- js = True
1216 | JSNull <- js = True
1217 | JSIdent _ <- js = True
1218 | otherwise = False
1221 reduce :: JS -> JS
1222 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1223 | JSReturn js <- last body = (JSAlloc fun (Just js))
1225 reduce js = js
1228 reduceCall :: [String] -> JS -> JS
1229 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1230 JSReturn (JSApp id@(JSIdent ret) _)
1231 )])
1232 | ret `elem` funs = id
1234 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1235 | fun `elem` funs = id
1237 reduceCall funs js = transformJS (reduceCall funs) js
1240extractLocalConstructors :: [JS] -> [JS]
1241extractLocalConstructors js =
1242 concatMap extractLocalConstructors' js
1243 where
1244 globalCons :: [String]
1245 globalCons = concatMap (getGlobalCons) js
1248 extractLocalConstructors' :: JS -> [JS]
1249 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1250 addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1251 where
1252 cons :: [(JS, JS)]
1253 cons = zipWith genName (foldJS match (++) [] body) [1..]
1254 where
1255 genName :: JS -> Int -> (JS, JS)
1256 genName js id =
1257 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1259 match :: JS -> [JS]
1260 match js
1261 | JSNew "__IDRRT__Con" args <- js
1262 , all isConstant args = [js]
1263 | otherwise = []
1266 addCons :: [(JS, JS)] -> [JS] -> [JS]
1267 addCons [] js = js
1268 addCons (con@(_, name):cons) js
1269 | sum (map (countOccur name) js) > 0 =
1270 addCons cons ((allocCon con) : js)
1271 | otherwise =
1272 addCons cons js
1275 countOccur :: JS -> JS -> Int
1276 countOccur ident js = foldJS match (+) 0 js
1277 where
1278 match :: JS -> Int
1279 match js
1280 | js == ident = 1
1281 | otherwise = 0
1284 allocCon :: (JS, JS) -> JS
1285 allocCon (js, JSIdent name) =
1286 JSAlloc name (Just js)
1289 isConstant :: JS -> Bool
1290 isConstant js
1291 | JSNew "__IDRRT__Con" args <- js
1292 , all isConstant args =
1293 True
1294 | otherwise =
1295 isJSConstantConstructor globalCons js
1297 extractLocalConstructors' js = [js]
1300 getGlobalCons :: JS -> [String]
1301 getGlobalCons js = foldJS match (++) [] js
1302 where
1303 match :: JS -> [String]
1304 match js
1305 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1306 [name]
1307 | otherwise =
1308 []
1311evalCons :: [JS] -> [JS]
1312evalCons js =
1313 map (collapseCont . collapseTC . expandProj . evalCons') js
1314 where
1315 cons :: [(String, JS)]
1316 cons = concatMap getGlobalCons js
1318 evalCons' :: JS -> JS
1319 evalCons' js = transformJS match js
1320 where
1321 match :: JS -> JS
1322 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1323 | JSIdent name <- arg
1324 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1325 arg
1327 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1328 | JSIdent name <- arg
1329 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1330 arg
1332 match js = transformJS match js
1335 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1336 lookupConstructor ctr cons
1337 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1338 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1339 | otherwise = Nothing
1342 expandProj :: JS -> JS
1343 expandProj js = transformJS match js
1344 where
1345 match :: JS -> JS
1346 match (
1347 JSIndex (
1348 JSProj (JSIdent name) "vars"
1349 ) (
1350 JSNum (JSInt idx)
1353 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1354 args !! idx
1356 match js = transformJS match js
1359 collapseTC :: JS -> JS
1360 collapseTC js = transformJS match js
1361 where
1362 match :: JS -> JS
1363 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1364 JSReturn (JSIdent name)
1365 )])
1366 | Just _ <- lookup name cons = (JSIdent name)
1368 match js = transformJS match js
1371 collapseCont :: JS -> JS
1372 collapseCont js = transformJS match js
1373 where
1374 match :: JS -> JS
1375 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1376 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1377 )]) = collapseCont ret
1380 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1381 JSReturn (JSIdent name)
1382 )]) = JSIdent name
1384 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1385 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1386 )])
1387 | all collapsable args = ret
1388 where
1389 collapsable :: JS -> Bool
1390 collapsable (JSIdent _) = True
1391 collapsable js = isJSConstantConstructor (map fst cons) js
1394 match js = transformJS match js
1397getGlobalCons :: JS -> [(String, JS)]
1398getGlobalCons js = foldJS match (++) [] js
1399 where
1400 match :: JS -> [(String, JS)]
1401 match js
1402 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1403 [(name, con)]
1404 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1405 [(name, con)]
1406 | otherwise =
1407 []
1410getIncludes :: [FilePath] -> IO [String]
1411getIncludes = mapM readFile
1413codegenJavaScript :: CodeGenerator
1414codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)
1415 (includes ci) (outputFile ci) (outputType ci)
1417codegenNode :: CodeGenerator
1418codegenNode ci = codegenJS_all Node (simpleDecls ci)
1419 (includes ci) (outputFile ci) (outputType ci)
1421codegenJS_all
1422 :: JSTarget
1423 -> [(Name, SDecl)]
1424 -> [FilePath]
1425 -> FilePath
1426 -> OutputType
1427 -> IO ()
1428codegenJS_all target definitions includes filename outputType = do
1429 let (header, rt) = case target of
1430 Node ->
1431 ("#!/usr/bin/env node\n", "-node")
1432 JavaScript ->
1433 ("", "-browser")
1434 included <- getIncludes includes
1435 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1436 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1437 tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]
1438 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1439 writeFile filename $ header ++ (
1440 intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions
1443 setPermissions filename (emptyPermissions { readable = True
1444 , executable = target == Node
1445 , writable = True
1446 })
1447 where
1448 def :: [(String, SDecl)]
1449 def = map (first translateNamespace) definitions
1452 checkForBigInt :: [JS] -> Bool
1453 checkForBigInt js = occur
1454 where
1455 occur :: Bool
1456 occur = or $ map (foldJS match (||) False) js
1458 match :: JS -> Bool
1459 match (JSIdent "__IDRRT__bigInt") = True
1460 match (JSWord (JSWord64 _)) = True
1461 match (JSNum (JSInteger _)) = True
1462 match js = False
1465 runtime :: String -> String -> String -> [String]
1466 runtime jsbn idrRuntime tgtRuntime =
1467 if checkForBigInt optimized
1468 then [jsbn, idrRuntime, tgtRuntime]
1469 else [idrRuntime, tgtRuntime]
1472 optimized :: [JS]
1473 optimized = translate >>> optimize $ def
1474 where
1475 translate p =
1476 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1477 optimize p =
1478 foldl' (flip ($)) p opt
1480 opt =
1481 [ removeEval
1482 , map inlineJS
1483 , removeIDs
1484 , reduceJS
1485 , map reduceConstants
1486 , initConstructors
1487 , map removeAllocations
1488 , elimDeadLoop
1489 , map elimDuplicateEvals
1490 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1491 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1492 , map removeInstanceChecks
1493 , inlineFunctions
1494 , map reduceContinuations
1495 , extractLocalConstructors
1496 , unfoldLookupTable
1497 , evalCons
1500 functions :: [String]
1501 functions = map compileJS optimized
1503 prelude :: [JS]
1504 prelude =
1505 [ JSAnnotation JSConstructor $
1506 JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1507 JSAssign (JSProj JSThis "k") (JSIdent "k")
1508 ))
1509 , JSAnnotation JSConstructor $
1510 JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1511 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1512 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1514 ))
1517 mainLoop :: JS
1518 mainLoop =
1519 JSAlloc "main" $ Just $ JSFunction [] (
1520 case target of
1521 Node -> mainFun
1522 JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [
1523 JSString "DOMContentLoaded", JSFunction [] (
1524 mainFun
1525 ), JSFalse
1526 ])]
1528 where
1529 mainFun :: JS
1530 mainFun = jsTailcall $ jsCall runMain []
1533 isReady :: JS
1534 isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1537 readyState :: JS
1538 readyState = JSProj (JSIdent "document") "readyState"
1541 runMain :: String
1542 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1545 invokeLoop :: JS
1546 invokeLoop = jsCall "main" []
1549translateIdentifier :: String -> String
1550translateIdentifier =
1551 replaceReserved . concatMap replaceBadChars
1552 where replaceBadChars :: Char -> String
1553 replaceBadChars c
1554 | ' ' <- c = "_"
1555 | '_' <- c = "__"
1556 | isDigit c = '_' : show (ord c)
1557 | not (isLetter c && isAscii c) = '_' : show (ord c)
1558 | otherwise = [c]
1559 replaceReserved s
1560 | s `elem` reserved = '_' : s
1561 | otherwise = s
1564 reserved = [ "break"
1565 , "case"
1566 , "catch"
1567 , "continue"
1568 , "debugger"
1569 , "default"
1570 , "delete"
1571 , "do"
1572 , "else"
1573 , "finally"
1574 , "for"
1575 , "function"
1576 , "if"
1577 , "in"
1578 , "instanceof"
1579 , "new"
1580 , "return"
1581 , "switch"
1582 , "this"
1583 , "throw"
1584 , "try"
1585 , "typeof"
1586 , "var"
1587 , "void"
1588 , "while"
1589 , "with"
1591 , "class"
1592 , "enum"
1593 , "export"
1594 , "extends"
1595 , "import"
1596 , "super"
1598 , "implements"
1599 , "interface"
1600 , "let"
1601 , "package"
1602 , "private"
1603 , "protected"
1604 , "public"
1605 , "static"
1606 , "yield"
1610translateNamespace :: Name -> String
1611translateNamespace (UN _) = idrNamespace
1612translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1613translateNamespace (MN _ _) = idrNamespace
1614translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1615translateNamespace NErased = idrNamespace
1618translateName :: Name -> String
1619translateName (UN name) = 'u' : translateIdentifier (str name)
1620translateName (NS name _) = 'n' : translateName name
1621translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1622translateName (SN name) = 's' : translateSpecialName name
1623translateName NErased = "e"
1626translateSpecialName :: SpecialName -> String
1627translateSpecialName name
1628 | WhereN i m n <- name =
1629 'w' : translateName m ++ translateName n ++ show i
1630 | InstanceN n s <- name =
1631 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1632 | ParentN n s <- name =
1633 'p' : translateName n ++ translateIdentifier (str s)
1634 | MethodN n <- name =
1635 'm' : translateName n
1636 | CaseN n <- name =
1637 'c' : translateName n
1640translateConstant :: Const -> JS
1641translateConstant (I i) = JSNum (JSInt i)
1642translateConstant (Fl f) = JSNum (JSFloat f)
1643translateConstant (Ch c) = JSString $ translateChar c
1644translateConstant (Str s) = JSString $ concatMap translateChar s
1645translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1646translateConstant StrType = JSType JSStringTy
1647translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1648translateConstant (AType ATFloat) = JSType JSFloatTy
1649translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1650translateConstant PtrType = JSType JSPtrTy
1651translateConstant Forgot = JSType JSForgotTy
1652translateConstant (BI i) = jsBigInt $ JSString (show i)
1653translateConstant (B8 b) = JSWord (JSWord8 b)
1654translateConstant (B16 b) = JSWord (JSWord16 b)
1655translateConstant (B32 b) = JSWord (JSWord32 b)
1656translateConstant (B64 b) = JSWord (JSWord64 b)
1657translateConstant c =
1658 jsError $ "Unimplemented Constant: " ++ show c
1661translateChar :: Char -> String
1662translateChar ch
1663 | '\a' <- ch = "\\u0007"
1664 | '\b' <- ch = "\\b"
1665 | '\f' <- ch = "\\f"
1666 | '\n' <- ch = "\\n"
1667 | '\r' <- ch = "\\r"
1668 | '\t' <- ch = "\\t"
1669 | '\v' <- ch = "\\v"
1670 | '\SO' <- ch = "\\u000E"
1671 | '\DEL' <- ch = "\\u007F"
1672 | '\\' <- ch = "\\\\"
1673 | '\"' <- ch = "\\\""
1674 | '\'' <- ch = "\\\'"
1675 | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
1676 | otherwise = [ch]
1677 where
1678 fill :: String -> String
1679 fill s = if length s == 1
1680 then '0' : s
1681 else s
1683 asciiTab =
1684 ['\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL',
1685 '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI',
1686 '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB',
1687 '\CAN', '\EM', '\SUB', '\ESC', '\FS', '\GS', '\RS', '\US']
1690translateDeclaration :: (String, SDecl) -> [JS]
1691translateDeclaration (path, SFun name params stackSize body)
1692 | (MN _ ap) <- name
1693 , (SChkCase var cases) <- body
1694 , ap == txt "APPLY" =
1695 [ lookupTable "APPLY" [] var cases
1696 , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1697 JSTernary (
1698 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1699 (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1700 ) (JSApp
1701 (JSIndex
1702 (JSIdent (idrLTNamespace ++ "APPLY"))
1703 (JSProj (JSIdent "mfn0") "tag")
1705 [JSIdent "mfn0", JSIdent "marg0"]
1706 ) JSNull
1710 | (MN _ ev) <- name
1711 , (SChkCase var cases) <- body
1712 , ev == txt "EVAL" =
1713 [ lookupTable "EVAL" [] var cases
1714 , jsDecl $ JSFunction ["marg0"] (JSReturn $
1715 JSTernary (
1716 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1717 (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1718 ) (JSApp
1719 (JSIndex
1720 (JSIdent (idrLTNamespace ++ "EVAL"))
1721 (JSProj (JSIdent "marg0") "tag")
1723 [JSIdent "marg0"]
1724 ) (JSIdent "marg0")
1727 | otherwise =
1728 let fun = translateExpression body in
1729 [jsDecl $ jsFun fun]
1731 where
1732 hasProp :: String -> String -> JS
1733 hasProp table var =
1734 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1737 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1738 caseFun aux var cse =
1739 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1740 jsFunAux aux c
1743 getTag :: SAlt -> Maybe Int
1744 getTag (SConCase _ tag _ _ _) = Just tag
1745 getTag _ = Nothing
1748 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1749 lookupTable table aux var cases =
1750 JSAlloc (idrLTNamespace ++ table) $ Just (
1751 JSApp (JSFunction [] (
1752 JSSeq $ [
1753 JSAlloc "t" $ Just (JSArray [])
1754 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1755 JSReturn (JSIdent "t")
1757 )) []
1759 where
1760 assignEntries :: [(Int, JS)] -> [JS]
1761 assignEntries entries =
1762 map (\(tag, fun) ->
1763 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1764 ) entries
1767 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1768 lookupEntry aux var alt = do
1769 tag <- getTag alt
1770 return (tag, caseFun aux var alt)
1773 jsDecl :: JS -> JS
1774 jsDecl = JSAlloc (path ++ translateName name) . Just
1777 jsFun body = jsFunAux [] body
1780 jsFunAux :: [(LVar, String)] -> JS -> JS
1781 jsFunAux aux body =
1782 JSFunction (p ++ map snd aux) (
1783 JSSeq $
1784 zipWith assignVar [0..] p ++
1785 map assignAux aux ++
1786 [JSReturn body]
1788 where
1789 assignVar :: Int -> String -> JS
1790 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1793 assignAux :: (LVar, String) -> JS
1794 assignAux (Loc var, val) =
1795 JSAlloc (jsVar var) (Just $ JSIdent val)
1798 p :: [String]
1799 p = map translateName params
1802translateVariableName :: LVar -> String
1803translateVariableName (Loc i) =
1804 jsVar i
1807translateExpression :: SExp -> JS
1808translateExpression (SLet name value body) =
1809 jsLet (translateVariableName name) (
1810 translateExpression value
1811 ) (translateExpression body)
1813translateExpression (SConst cst) =
1814 translateConstant cst
1816translateExpression (SV var) =
1817 JSVar var
1819translateExpression (SApp tc name vars)
1820 | False <- tc =
1821 jsTailcall $ translateFunctionCall name vars
1822 | True <- tc =
1823 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1824 JSReturn $ translateFunctionCall name vars
1825 )]
1826 where
1827 translateFunctionCall name vars =
1828 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1830translateExpression (SOp op vars)
1831 | LNoOp <- op = JSVar (last vars)
1833 | (LZExt (ITFixed IT8) ITNative) <- op = JSVar (last vars)
1835 | (LLSHR (ITFixed IT8)) <- op
1836 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" lhs rhs
1838 | (LLSHR (ITFixed IT16)) <- op
1839 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" lhs rhs
1841 | (LLSHR (ITFixed IT32)) <- op
1842 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" lhs rhs
1844 | (LLSHR (ITFixed IT64)) <- op
1845 , (lhs:rhs:_) <- vars =
1846 jsMeth (JSVar lhs) "shiftRight" [JSVar rhs]
1848 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1849 | (LPlus (ATInt ITBig)) <- op
1850 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1851 | (LMinus (ATInt ITBig)) <- op
1852 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1853 | (LTimes (ATInt ITBig)) <- op
1854 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1855 | (LSDiv (ATInt ITBig)) <- op
1856 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1857 | (LSRem (ATInt ITBig)) <- op
1858 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1859 | (LEq (ATInt ITBig)) <- op
1860 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1861 | (LSLt (ATInt ITBig)) <- op
1862 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1863 | (LSLe (ATInt ITBig)) <- op
1864 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1865 | (LSGt (ATInt ITBig)) <- op
1866 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1867 | (LSGe (ATInt ITBig)) <- op
1868 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1870 | (LPlus ATFloat) <- op
1871 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1872 | (LMinus ATFloat) <- op
1873 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1874 | (LTimes ATFloat) <- op
1875 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1876 | (LSDiv ATFloat) <- op
1877 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1878 | (LEq ATFloat) <- op
1879 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1880 | (LSLt ATFloat) <- op
1881 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1882 | (LSLe ATFloat) <- op
1883 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1884 | (LSGt ATFloat) <- op
1885 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1886 | (LSGe ATFloat) <- op
1887 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1889 | (LPlus (ATInt ITChar)) <- op
1890 , (lhs:rhs:_) <- vars =
1891 jsCall "__IDRRT__fromCharCode" [
1892 JSBinOp "+" (
1893 jsCall "__IDRRT__charCode" [JSVar lhs]
1894 ) (
1895 jsCall "__IDRRT__charCode" [JSVar rhs]
1899 | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op
1900 , (arg:_) <- vars =
1901 JSParens $ JSBinOp "&" (JSVar arg) (JSNum (JSInt 0xFF))
1903 | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op
1904 , (arg:_) <- vars =
1905 JSParens $ JSBinOp "&" (JSVar arg) (JSNum (JSInt 0xFFFF))
1907 | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op
1908 , (arg:_) <- vars =
1909 jsMeth (jsMeth (JSVar arg) "and" [
1910 jsBigInt (JSString $ show 0xFFFFFFFF)
1911 ]) "intValue" []
1913 | (LTrunc ITBig (ITFixed IT64)) <- op
1914 , (arg:_) <- vars =
1915 jsMeth (JSVar arg) "and" [
1916 jsBigInt (JSString $ show 0xFFFFFFFF)
1919 | (LAnd (ITFixed IT64)) <- op
1920 , (lhs:rhs:_) <- vars =
1921 jsMeth (JSVar lhs) "and" [JSVar rhs]
1923 | (LPlus (ATInt (ITFixed IT64))) <- op
1924 , (lhs:rhs:_) <- vars =
1925 jsMeth (jsMeth (JSVar lhs) "add" [JSVar rhs]) "and" [
1926 jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)
1929 | (LPlus _) <- op
1930 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1931 | (LMinus _) <- op
1932 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1933 | (LTimes _) <- op
1934 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1935 | (LSDiv _) <- op
1936 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1937 | (LSRem _) <- op
1938 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1939 | (LEq _) <- op
1940 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1941 | (LSLt _) <- op
1942 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1943 | (LSLe _) <- op
1944 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1945 | (LSGt _) <- op
1946 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1947 | (LSGe _) <- op
1948 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1949 | (LAnd _) <- op
1950 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1951 | (LOr _) <- op
1952 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1953 | (LXOr _) <- op
1954 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1955 | (LSHL _) <- op
1956 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1957 | (LASHR _) <- op
1958 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1959 | (LCompl _) <- op
1960 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
1962 | LStrConcat <- op
1963 , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
1964 | LStrEq <- op
1965 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1966 | LStrLt <- op
1967 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1968 | LStrLen <- op
1969 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1971 | (LStrInt ITNative) <- op
1972 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1973 | (LIntStr ITNative) <- op
1974 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1975 | (LSExt ITNative ITBig) <- op
1976 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1977 | (LTrunc ITBig ITNative) <- op
1978 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1979 | (LIntStr ITBig) <- op
1980 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1981 | (LStrInt ITBig) <- op
1982 , (arg:_) <- vars = jsBigInt $ JSVar arg
1983 | LFloatStr <- op
1984 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1985 | LStrFloat <- op
1986 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1987 | (LIntFloat ITNative) <- op
1988 , (arg:_) <- vars = JSVar arg
1989 | (LFloatInt ITNative) <- op
1990 , (arg:_) <- vars = JSVar arg
1991 | (LChInt ITNative) <- op
1992 , (arg:_) <- vars = jsCall "__IDRRT__charCode" [JSVar arg]
1993 | (LIntCh ITNative) <- op
1994 , (arg:_) <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]
1996 | LFExp <- op
1997 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1998 | LFLog <- op
1999 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
2000 | LFSin <- op
2001 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
2002 | LFCos <- op
2003 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
2004 | LFTan <- op
2005 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
2006 | LFASin <- op
2007 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
2008 | LFACos <- op
2009 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
2010 | LFATan <- op
2011 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
2012 | LFSqrt <- op
2013 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
2014 | LFFloor <- op
2015 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
2016 | LFCeil <- op
2017 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
2019 | LStrCons <- op
2020 , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]
2021 | LStrHead <- op
2022 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
2023 | LStrRev <- op
2024 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
2025 | LStrIndex <- op
2026 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
2027 | LStrTail <- op
2028 , (arg:_) <- vars = let v = translateVariableName arg in
2029 JSApp (JSProj (JSIdent v) "substr") [
2030 JSNum (JSInt 1),
2031 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
2033 | LNullPtr <- op
2034 , (_) <- vars = JSNull
2036 where
2037 translateBinaryOp :: String -> LVar -> LVar -> JS
2038 translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)
2041 invokeMeth :: LVar -> String -> [LVar] -> JS
2042 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
2044translateExpression (SError msg) =
2045 jsError msg
2047translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
2048 jsCall (idrRTNamespace ++ "print") [JSVar var]
2050translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =
2051 JSBinOp "==" (JSVar var) JSNull
2053translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =
2054 JSBinOp "==" (JSVar lhs) (JSVar rhs)
2056translateExpression (SForeign _ _ "idris_time" []) =
2057 JSRaw "(new Date()).getTime()"
2059translateExpression (SForeign _ _ fun args) =
2060 JSFFI fun (map generateWrapper args)
2061 where
2062 generateWrapper (ffunc, name)
2063 | FFunction <- ffunc =
2064 JSApp (
2065 JSIdent $ idrRTNamespace ++ "ffiWrap"
2066 ) [JSIdent $ translateVariableName name]
2067 | FFunctionIO <- ffunc =
2068 JSApp (
2069 JSIdent $ idrRTNamespace ++ "ffiWrap"
2070 ) [JSIdent $ translateVariableName name]
2072 generateWrapper (_, name) =
2073 JSIdent $ translateVariableName name
2075translateExpression patterncase
2076 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
2077 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
2078 where
2079 caseHelper var cases param =
2080 JSApp (JSFunction [param] (
2081 JSCond $ map (expandCase param . translateCaseCond param) cases
2082 )) [JSVar var]
2085 expandCase :: String -> (Cond, JS) -> (JS, JS)
2086 expandCase _ (RawCond cond, branch) = (cond, branch)
2087 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
2088 expandCase var (CaseCond caseTy, branch)
2089 | ConCase tag <- caseTy =
2090 let checkCon = JSIdent var `jsInstanceOf` jsCon
2091 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
2092 (checkCon `jsAnd` checkTag, branch)
2094 | TypeCase ty <- caseTy =
2095 let checkTy = JSIdent var `jsInstanceOf` jsType
2096 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
2097 (checkTy `jsAnd` checkTag, branch)
2099translateExpression (SCon i name vars) =
2100 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
2101 , JSArray $ map JSVar vars
2104translateExpression (SUpdate var@(Loc i) e) =
2105 JSAssign (JSVar var) (translateExpression e)
2107translateExpression (SProj var i) =
2108 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
2110translateExpression SNothing = JSNull
2112translateExpression e =
2113 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
2116data CaseType = ConCase Int
2117 | TypeCase JSType
2118 | DefaultCase
2119 deriving Eq
2122data Cond = CaseCond CaseType
2123 | RawCond JS
2126translateCaseCond :: String -> SAlt -> (Cond, JS)
2127translateCaseCond _ cse@(SDefaultCase _) =
2128 (CaseCond DefaultCase, translateCase Nothing cse)
2130translateCaseCond var cse@(SConstCase ty _)
2131 | StrType <- ty = matchHelper JSStringTy
2132 | PtrType <- ty = matchHelper JSPtrTy
2133 | Forgot <- ty = matchHelper JSForgotTy
2134 | (AType ATFloat) <- ty = matchHelper JSFloatTy
2135 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
2136 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
2137 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
2138 where
2139 matchHelper :: JSType -> (Cond, JS)
2140 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
2142translateCaseCond var cse@(SConstCase cst@(BI _) _) =
2143 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
2144 (RawCond cond, translateCase Nothing cse)
2146translateCaseCond var cse@(SConstCase cst _) =
2147 let cond = JSIdent var `jsEq` translateConstant cst in
2148 (RawCond cond, translateCase Nothing cse)
2150translateCaseCond var cse@(SConCase _ tag _ _ _) =
2151 (CaseCond $ ConCase tag, translateCase (Just var) cse)
2154translateCase :: Maybe String -> SAlt -> JS
2155translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
2156translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
2157translateCase (Just var) (SConCase a _ _ vars e) =
2158 let params = map jsVar [a .. (a + length vars)] in
2159 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
2160 JSThis, JSProj (JSIdent var) "vars"