git.iko.soy/Idris-dev
on c712ddb help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1859 lines 58 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, 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 Data.List
18import Data.Maybe
19import System.IO
20import System.Directory
22idrNamespace :: String
23idrNamespace = "__IDR__"
24idrRTNamespace = "__IDRRT__"
25idrLTNamespace = "__IDRLT__"
26idrCTRNamespace = "__IDRCTR__"
29data JSTarget = Node | JavaScript deriving Eq
32data JSType = JSIntTy
33 | JSStringTy
34 | JSIntegerTy
35 | JSFloatTy
36 | JSCharTy
37 | JSPtrTy
38 | JSForgotTy
39 deriving Eq
42data JSInteger = JSBigZero
43 | JSBigOne
44 | JSBigInt Integer
45 deriving Eq
48data JSNum = JSInt Int
49 | JSFloat Double
50 | JSInteger JSInteger
51 deriving Eq
54data JS = JSRaw String
55 | JSIdent String
56 | JSFunction [String] JS
57 | JSType JSType
58 | JSSeq [JS]
59 | JSReturn JS
60 | JSApp JS [JS]
61 | JSNew String [JS]
62 | JSError String
63 | JSBinOp String JS JS
64 | JSPreOp String JS
65 | JSPostOp String JS
66 | JSProj JS String
67 | JSVar LVar
68 | JSNull
69 | JSThis
70 | JSTrue
71 | JSFalse
72 | JSArray [JS]
73 | JSString String
74 | JSChar String
75 | JSNum JSNum
76 | JSAssign JS JS
77 | JSAlloc String (Maybe JS)
78 | JSIndex JS JS
79 | JSCond [(JS, JS)]
80 | JSTernary JS JS JS
81 | JSParens JS
82 | JSWhile JS JS
83 | JSNoop
84 deriving Eq
87compileJS :: JS -> String
88compileJS JSNoop = ""
90compileJS (JSRaw code) =
91 code
93compileJS (JSIdent ident) =
94 ident
96compileJS (JSFunction args body) =
97 "function("
98 ++ intercalate "," args
99 ++ "){\n"
100 ++ compileJS body
101 ++ "\n}"
103compileJS (JSType ty)
104 | JSIntTy <- ty = idrRTNamespace ++ "Int"
105 | JSStringTy <- ty = idrRTNamespace ++ "String"
106 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
107 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
108 | JSCharTy <- ty = idrRTNamespace ++ "Char"
109 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
110 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
112compileJS (JSSeq seq) =
113 intercalate ";\n" (map compileJS seq)
115compileJS (JSReturn val) =
116 "return " ++ compileJS val
118compileJS (JSApp lhs rhs)
119 | JSFunction {} <- lhs =
120 concat ["(", compileJS lhs, ")(", args, ")"]
121 | otherwise =
122 concat [compileJS lhs, "(", args, ")"]
123 where args :: String
124 args = intercalate "," $ map compileJS rhs
126compileJS (JSNew name args) =
127 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
129compileJS (JSError exc) =
130 "throw new Error(\"" ++ exc ++ "\")"
132compileJS (JSBinOp op lhs rhs) =
133 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
135compileJS (JSPreOp op val) =
136 op ++ compileJS val
138compileJS (JSProj obj field)
139 | JSFunction {} <- obj =
140 concat ["(", compileJS obj, ").", field]
141 | JSAssign {} <- obj =
142 concat ["(", compileJS obj, ").", field]
143 | otherwise =
144 compileJS obj ++ '.' : field
146compileJS (JSVar var) =
147 translateVariableName var
149compileJS JSNull =
150 "null"
152compileJS JSThis =
153 "this"
155compileJS JSTrue =
156 "true"
158compileJS JSFalse =
159 "false"
161compileJS (JSArray elems) =
162 "[" ++ intercalate "," (map compileJS elems) ++ "]"
164compileJS (JSString str) =
165 show str
167compileJS (JSChar chr) =
168 chr
170compileJS (JSNum num)
171 | JSInt i <- num = show i
172 | JSFloat f <- num = show f
173 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
174 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
175 | JSInteger (JSBigInt i) <- num = show i
177compileJS (JSAssign lhs rhs) =
178 compileJS lhs ++ "=" ++ compileJS rhs
180compileJS (JSAlloc name val) =
181 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
183compileJS (JSIndex lhs rhs) =
184 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
186compileJS (JSCond branches) =
187 intercalate " else " $ map createIfBlock branches
188 where
189 createIfBlock (JSTrue, e) =
190 "if (true) {\n"
191 ++ compileJS e
192 ++ ";\n}"
193 createIfBlock (cond, e) =
194 "if (" ++ compileJS cond ++") {\n"
195 ++ compileJS e
196 ++ ";\n}"
198compileJS (JSTernary cond true false) =
199 let c = compileJS cond
200 t = compileJS true
201 f = compileJS false in
202 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
204compileJS (JSParens js) =
205 "(" ++ compileJS js ++ ")"
207compileJS (JSWhile cond body) =
208 "while (" ++ compileJS cond ++ ") {\n"
209 ++ compileJS body
210 ++ "\n}"
212jsTailcall :: JS -> JS
213jsTailcall call =
214 jsCall (idrRTNamespace ++ "tailcall") [
215 JSFunction [] (JSReturn call)
216 ]
219jsCall :: String -> [JS] -> JS
220jsCall fun = JSApp (JSIdent fun)
223jsMeth :: JS -> String -> [JS] -> JS
224jsMeth obj meth =
225 JSApp (JSProj obj meth)
228jsInstanceOf :: JS -> JS -> JS
229jsInstanceOf = JSBinOp "instanceof"
232jsEq :: JS -> JS -> JS
233jsEq = JSBinOp "=="
236jsAnd :: JS -> JS -> JS
237jsAnd = JSBinOp "&&"
240jsOr :: JS -> JS -> JS
241jsOr = JSBinOp "||"
244jsType :: JS
245jsType = JSIdent $ idrRTNamespace ++ "Type"
248jsCon :: JS
249jsCon = JSIdent $ idrRTNamespace ++ "Con"
252jsTag :: JS -> JS
253jsTag obj = JSProj obj "tag"
256jsTypeTag :: JS -> JS
257jsTypeTag obj = JSProj obj "type"
260jsBigInt :: JS -> JS
261jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
262jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
263jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
266jsVar :: Int -> String
267jsVar = ("__var_" ++) . show
270jsLet :: String -> JS -> JS -> JS
271jsLet name value body =
272 JSApp (
273 JSFunction [name] (
274 JSReturn body
275 )
276 ) [value]
279jsError :: String -> JS
280jsError err = JSApp (JSFunction [] (JSError err)) []
283foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
284foldJS tr add acc js =
285 fold js
286 where
287 fold js
288 | JSFunction args body <- js =
289 add (tr js) (fold body)
290 | JSSeq seq <- js =
291 add (tr js) $ foldl' add acc (map fold seq)
292 | JSReturn ret <- js =
293 add (tr js) (fold ret)
294 | JSApp lhs rhs <- js =
295 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
296 | JSNew _ args <- js =
297 add (tr js) $ foldl' add acc $ map fold args
298 | JSBinOp _ lhs rhs <- js =
299 add (tr js) $ add (fold lhs) (fold rhs)
300 | JSPreOp _ val <- js =
301 add (tr js) $ fold val
302 | JSPostOp _ val <- js =
303 add (tr js) $ fold val
304 | JSProj obj _ <- js =
305 add (tr js) (fold obj)
306 | JSArray vals <- js =
307 add (tr js) $ foldl' add acc $ map fold vals
308 | JSAssign lhs rhs <- js =
309 add (tr js) $ add (fold lhs) (fold rhs)
310 | JSIndex lhs rhs <- js =
311 add (tr js) $ add (fold lhs) (fold rhs)
312 | JSAlloc _ val <- js =
313 add (tr js) $ fromMaybe acc $ fmap fold val
314 | JSTernary c t f <- js =
315 add (tr js) $ add (fold c) (add (fold t) (fold f))
316 | JSParens val <- js =
317 add (tr js) $ fold val
318 | JSCond conds <- js =
319 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
320 | JSWhile cond body <- js =
321 add (tr js) $ add (fold cond) (fold body)
322 | otherwise =
323 tr js
326transformJS :: (JS -> JS) -> JS -> JS
327transformJS tr js =
328 transformHelper js
329 where
330 transformHelper :: JS -> JS
331 transformHelper js
332 | JSFunction args body <- js = JSFunction args $ tr body
333 | JSSeq seq <- js = JSSeq $ map tr seq
334 | JSReturn ret <- js = JSReturn $ tr ret
335 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
336 | JSNew con args <- js = JSNew con $ map tr args
337 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
338 | JSPreOp op val <- js = JSPreOp op (tr val)
339 | JSPostOp op val <- js = JSPostOp op (tr val)
340 | JSProj obj field <- js = JSProj (tr obj) field
341 | JSArray vals <- js = JSArray $ map tr vals
342 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
343 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
344 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
345 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
346 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
347 | JSParens val <- js = JSParens $ tr val
348 | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
349 | otherwise = js
352moveJSDeclToTop :: String -> [JS] -> [JS]
353moveJSDeclToTop decl js = move ([], js)
354 where
355 move :: ([JS], [JS]) -> [JS]
356 move (front, js@(JSAlloc name _):back)
357 | name == decl = js : front ++ back
359 move (front, js:back) =
360 move (front ++ [js], back)
363jsSubst :: JS -> JS -> JS -> JS
364jsSubst var new old
365 | var == old = new
367jsSubst (JSIdent var) new (JSVar old)
368 | var == translateVariableName old = new
369 | otherwise = JSVar old
371jsSubst var new old@(JSIdent _)
372 | var == old = new
373 | otherwise = old
375jsSubst var new (JSArray fields) =
376 JSArray (map (jsSubst var new) fields)
378jsSubst var new (JSNew con vals) =
379 JSNew con $ map (jsSubst var new) vals
381jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
382 | var `notElem` args =
383 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
384 map (jsSubst (JSIdent var) new) vals
385 )
386 | otherwise =
387 JSApp (JSProj (JSFunction args body) "apply") (
388 map (jsSubst (JSIdent var) new) vals
389 )
391jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
392 | var /= arg =
393 JSApp (JSFunction [arg] (
394 jsSubst (JSIdent var) new body
395 )) $ map (jsSubst (JSIdent var) new) vals
396 | otherwise =
397 JSApp (JSFunction [arg] (
398 body
399 )) $ map (jsSubst (JSIdent var) new) vals
401jsSubst var new js = transformJS (jsSubst var new) js
404removeAllocations :: JS -> JS
405removeAllocations (JSSeq body) =
406 let opt = removeHelper (map removeAllocations body) in
407 case opt of
408 [ret] -> ret
409 _ -> JSSeq opt
410 where
411 removeHelper :: [JS] -> [JS]
412 removeHelper [js] = [js]
413 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
414 map (jsSubst (JSIdent name) val) (removeHelper js)
415 removeHelper (j:js) = j : removeHelper js
417removeAllocations js = transformJS removeAllocations js
420isJSConstant :: JS -> Bool
421isJSConstant js
422 | JSString _ <- js = True
423 | JSChar _ <- js = True
424 | JSNum _ <- js = True
425 | JSType _ <- js = True
426 | JSNull <- js = True
427 | JSArray vals <- js = all isJSConstant vals
429 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
431 | otherwise = False
433isJSConstantConstructor :: [String] -> JS -> Bool
434isJSConstantConstructor constants js
435 | isJSConstant js =
436 True
437 | JSArray vals <- js =
438 all (isJSConstantConstructor constants) vals
439 | JSNew "__IDRRT__Con" args <- js =
440 all (isJSConstantConstructor constants) args
441 | JSIndex (JSProj (JSIdent name) "vars") (JSNum _) <- js
442 , name `elem` constants =
443 True
444 | JSIdent name <- js
445 , name `elem` constants =
446 True
447 | otherwise = False
450inlineJS :: JS -> JS
451inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
452inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
453 inlineJS $ jsSubst (JSIdent "cse") val body
456inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
457 inlineJS $ JSSeq [ JSAlloc arg (Just val)
458 , cond
459 ]
461inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
462 JSThis,JSProj var "vars"
463 ])
464 | var /= JSIdent "cse" =
465 inlineJS $ inlineApply args body 0
466 where
467 inlineApply [] body _ = inlineJS body
468 inlineApply (a:as) body n =
469 inlineApply as (
470 jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
471 ) (n + 1)
473inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
474 | isJSConstant val = val
476inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
477 JSFunction [] (JSReturn val)
478 ])
479 | isJSConstant val = val
481inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
482 | JSNew con [tag, vals] <- ret
483 , opt <- inlineJS val =
484 inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
486 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
487 , opt <- inlineJS val =
488 inlineJS $ JSNew con [JSFunction [] (
489 JSReturn (
490 JSApp (
491 inlineJS $ jsSubst (JSIdent arg) opt fun
492 ) (
493 map (inlineJS . jsSubst (JSIdent arg) opt) vars
494 )
495 )
496 )]
498 | JSApp (JSProj obj field) args <- ret
499 , opt <- inlineJS val =
500 inlineJS $ JSApp (
501 inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
502 ) (
503 map (inlineJS . jsSubst (JSIdent arg) opt) args
504 )
506 | JSIndex (JSProj obj field) idx <- ret
507 , opt <- inlineJS val =
508 inlineJS $ JSIndex (JSProj (
509 inlineJS $ jsSubst (JSIdent arg) opt obj
510 ) field
511 ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
513 | JSBinOp op lhs rhs <- ret
514 , opt <- inlineJS val =
515 inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
516 (inlineJS $ jsSubst (JSIdent arg) opt rhs)
518 | JSApp (JSIdent fun) args <- ret
519 , opt <- inlineJS val =
520 inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
522inlineJS js = transformJS inlineJS js
525reduceJS :: [JS] -> [JS]
526reduceJS js = reduceLoop [] ([], js)
529funName :: JS -> String
530funName (JSAlloc fun _) = fun
533elimDeadLoop :: [JS] -> [JS]
534elimDeadLoop js
535 | ret <- deadEvalApplyCases js
536 , ret /= js = elimDeadLoop ret
537 | otherwise = js
540deadEvalApplyCases :: [JS] -> [JS]
541deadEvalApplyCases js =
542 let tags = sort $ nub $ concatMap (getTags) js in
543 map (removeHelper tags) js
544 where
545 getTags :: JS -> [Int]
546 getTags = foldJS match (++) []
547 where
548 match js
549 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
550 | otherwise = []
553 removeHelper :: [Int] -> JS -> JS
554 removeHelper tags (JSAlloc fun (Just (
555 JSApp (JSFunction [] (JSSeq seq)) []))
556 ) =
557 (JSAlloc fun (Just (
558 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
559 )
561 removeHelper _ js = js
564 remover :: [Int] -> [JS] -> [JS]
565 remover tags (
566 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
567 )
568 | tag `notElem` tags = remover tags js
570 remover tags (j:js) = j : remover tags js
571 remover _ [] = []
574initConstructors :: [JS] -> [JS]
575initConstructors js =
576 let tags = nub $ sort $ concat (map getTags js) in
577 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
578 where
579 rearrangePrelude :: [JS] -> [JS]
580 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
583 getTags :: JS -> [Int]
584 getTags = foldJS match (++) []
585 where
586 match js
587 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
588 | otherwise = []
591 replaceConstructors :: [Int] -> [JS] -> [JS]
592 replaceConstructors tags js = map (replaceHelper tags) js
593 where
594 replaceHelper :: [Int] -> JS -> JS
595 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
596 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
598 replaceHelper tags js = transformJS (replaceHelper tags) js
601 createConstant :: Int -> JS
602 createConstant tag =
603 JSAlloc (idrCTRNamespace ++ show tag) (Just (
604 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
605 ))
608removeIDs :: [JS] -> [JS]
609removeIDs js =
610 case partition isID js of
611 ([], rest) -> rest
612 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
613 where isID :: JS -> Bool
614 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
615 | JSReturn (JSVar _) <- last body = True
617 isID _ = False
620 idFor :: JS -> (String, Int)
621 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
622 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
625 removeIDCall :: [(String, Int)] -> JS -> JS
626 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
627 JSReturn (JSApp (JSIdent fun) args)
628 )])
629 | Just pos <- lookup fun ids
630 , pos < length args = args !! pos
632 removeIDCall ids (JSNew _ [JSFunction [] (
633 JSReturn (JSApp (JSIdent fun) args)
634 )])
635 | Just pos <- lookup fun ids
636 , pos < length args = args !! pos
638 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
639 | Just pos <- lookup fun ids
640 , pos < length args = args !! pos
642 removeIDCall ids js = transformJS (removeIDCall ids) js
645inlineFunctions :: [JS] -> [JS]
646inlineFunctions js =
647 inlineHelper ([], js)
648 where
649 inlineHelper :: ([JS], [JS]) -> [JS]
650 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
651 | countAll fun front + countAll fun back == 0 =
652 inlineHelper (front, back)
653 | Just new <- inlineAble (
654 countAll fun front + countAll fun back
655 ) fun args body =
656 let f = map (inline fun args new) in
657 inlineHelper (f front, f back)
659 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
660 inlineHelper (front, []) = front
663 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
664 inlineAble 1 fun args (JSReturn body)
665 | nonRecur fun body =
666 if all (<= 1) (map ($ body) (map countIDOccurences args))
667 then Just body
668 else Nothing
670 inlineAble _ _ _ _ = Nothing
673 inline :: String -> [String] -> JS -> JS -> JS
674 inline fun args body js = inline' js
675 where
676 inline' :: JS -> JS
677 inline' (JSApp (JSIdent name) vals)
678 | name == fun =
679 let (js, phs) = insertPlaceHolders args body in
680 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
682 inline' js = transformJS inline' js
684 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
685 insertPlaceHolders args body = insertPlaceHolders' args body []
686 where
687 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
688 insertPlaceHolders' (a:as) body ph
689 | (body', ph') <- insertPlaceHolders' as body ph =
690 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
691 (jsSubst (JSIdent a) phvar body', phvar : ph')
693 insertPlaceHolders' [] body ph = (body, ph)
696 nonRecur :: String -> JS -> Bool
697 nonRecur name body = countInvokations name body == 0
700 countAll :: String -> [JS] -> Int
701 countAll name js = sum $ map (countInvokations name) js
704 countIDOccurences :: String -> JS -> Int
705 countIDOccurences name = foldJS match (+) 0
706 where
707 match :: JS -> Int
708 match js
709 | JSIdent ident <- js
710 , name == ident = 1
711 | otherwise = 0
714 countInvokations :: String -> JS -> Int
715 countInvokations name = foldJS match (+) 0
716 where
717 match :: JS -> Int
718 match js
719 | JSApp (JSIdent ident) _ <- js
720 , name == ident = 1
721 | JSNew con _ <- js
722 , name == con = 1
723 | otherwise = 0
726reduceContinuations :: JS -> JS
727reduceContinuations = transformJS reduceHelper
728 where
729 reduceHelper :: JS -> JS
730 reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
731 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
732 )]) = js
734 reduceHelper js = transformJS reduceHelper js
737reduceConstant :: JS -> JS
738reduceConstant
739 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
740 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
741 )])
742 | JSNum num <- val = val
743 | JSBinOp op lhs rhs <- val =
744 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
746 | JSApp (JSProj lhs op) [rhs] <- val
747 , op `elem` [ "subtract"
748 , "add"
749 , "multiply"
750 , "divide"
751 , "mod"
752 , "equals"
753 , "lesser"
754 , "lesserOrEquals"
755 , "greater"
756 , "greaterOrEquals"
757 ] = val
759reduceConstant (JSApp ident [(JSParens js)]) =
760 JSApp ident [reduceConstant js]
762reduceConstant js = transformJS reduceConstant js
765reduceConstants :: JS -> JS
766reduceConstants js
767 | ret <- reduceConstant js
768 , ret /= js = reduceConstants ret
769 | otherwise = js
772elimDuplicateEvals :: JS -> JS
773elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
774 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
775 where
776 elimHelper :: [JS] -> [JS]
777 elimHelper (j@(JSAlloc var (Just val)):js) =
778 j : map (jsSubst val (JSIdent var)) (elimHelper js)
779 elimHelper (j:js) =
780 j : elimHelper js
781 elimHelper [] = []
783elimDuplicateEvals js = js
786optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
787optimizeRuntimeCalls fun tc js =
788 optTC tc : map optHelper js
789 where
790 optHelper :: JS -> JS
791 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
792 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
793 ])
794 | n == fun = JSApp (JSIdent tc) $ map optHelper args
796 optHelper js = transformJS optHelper js
799 optTC :: String -> JS
800 optTC tc@"__IDRRT__EVALTC" =
801 JSAlloc tc (Just $ JSFunction ["arg0"] (
802 JSSeq [ JSAlloc "ret" $ Just (
803 JSTernary (
804 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
805 (hasProp "__IDRLT__EVAL" "arg0")
806 ) (JSApp
807 (JSIndex
808 (JSIdent "__IDRLT__EVAL")
809 (JSProj (JSIdent "arg0") "tag")
810 )
811 [JSIdent "arg0"]
812 ) (JSIdent "arg0")
813 )
814 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
815 JSAssign (JSIdent "ret") (
816 JSApp (JSProj (JSIdent "ret") "k") []
817 )
818 )
819 , JSReturn $ JSIdent "ret"
820 ]
821 ))
823 optTC tc@"__IDRRT__APPLYTC" =
824 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
825 JSSeq [ JSAlloc "ev" $ Just (JSApp
826 (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
827 )
828 , JSAlloc "ret" $ Just (
829 JSTernary (
830 (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
831 (hasProp "__IDRLT__APPLY" "ev")
832 ) (JSApp
833 (JSIndex
834 (JSIdent "__IDRLT__APPLY")
835 (JSProj (JSIdent "ev") "tag")
836 )
837 [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
838 ) JSNull
839 )
840 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
841 JSAssign (JSIdent "ret") (
842 JSApp (JSProj (JSIdent "ret") "k") []
843 )
844 )
845 , JSReturn $ JSIdent "ret"
846 ]
847 ))
850 hasProp :: String -> String -> JS
851 hasProp table var =
852 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
855unfoldLookupTable :: [JS] -> [JS]
856unfoldLookupTable input =
857 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
858 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
859 js = applyunfold in
860 adaptRuntime $ expandCons evals applys js
861 where
862 adaptRuntime :: [JS] -> [JS]
863 adaptRuntime =
864 adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
867 adaptApply var = map (jsSubst (
868 JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
869 ) (JSProj (JSIdent var) "app"))
872 adaptEval = map (jsSubst (
873 JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
874 ) (JSProj (JSIdent "arg0") "eval"))
877 adaptCon js =
878 adaptCon' [] js
879 where
880 adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
881 front ++ (new:back)
883 adaptCon' front (next:back) =
884 adaptCon' (front ++ [next]) back
886 adaptCon' front [] = front
889 new =
890 JSAlloc "__IDRRT__Con" (Just $
891 JSFunction newArgs (
892 JSSeq (map newVar newArgs)
893 )
894 )
895 where
896 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
897 newArgs = ["tag", "eval", "app", "vars"]
900 unfoldLT :: String -> [JS] -> ([Int], [JS])
901 unfoldLT lt js =
902 let (table, code) = extractLT lt js
903 expanded = expandLT lt table in
904 (map fst expanded, map snd expanded ++ code)
907 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
908 expandCons evals applys js =
909 map expandCons' js
910 where
911 expandCons' :: JS -> JS
912 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
913 | evalid <- getId "__IDRLT__EVAL" tag evals
914 , applyid <- getId "__IDRLT__APPLY" tag applys =
915 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
916 , maybe JSNull JSIdent evalid
917 , maybe JSNull JSIdent applyid
918 , JSArray (map expandCons' args)
919 ]
921 expandCons' js = transformJS expandCons' js
924 getId :: String -> Int -> [Int] -> Maybe String
925 getId lt tag entries
926 | tag `elem` entries = Just $ ltIdentifier lt tag
927 | otherwise = Nothing
930 ltIdentifier :: String -> Int -> String
931 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
932 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
935 extractLT :: String -> [JS] -> (JS, [JS])
936 extractLT lt js =
937 extractLT' ([], js)
938 where
939 extractLT' :: ([JS], [JS]) -> (JS, [JS])
940 extractLT' (front, js@(JSAlloc fun _):back)
941 | fun == lt = (js, front ++ back)
943 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
944 extractLT' (front, back) = (JSNoop, front ++ back)
947 expandLT :: String -> JS -> [(Int, JS)]
948 expandLT lt (
949 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
950 ) = catMaybes (map expandEntry seq)
951 where
952 expandEntry :: JS -> Maybe (Int, JS)
953 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
954 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
956 expandEntry js = Nothing
958 expandLT lt JSNoop = []
961removeInstanceChecks :: JS -> JS
962removeInstanceChecks (JSCond conds) =
963 JSCond $ eliminateDeadBranches $ map (
964 removeHelper *** removeInstanceChecks
965 ) conds
966 where
967 removeHelper (
968 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
969 ) = removeHelper check
970 removeHelper js = js
973 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
974 eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
975 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
976 eliminateDeadBranches [] = []
978removeInstanceChecks js = transformJS removeInstanceChecks js
981reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
982reduceLoop reduced (cons, program) =
983 case partition findConstructors program of
984 ([], js) -> cons ++ js
985 (candidates, rest) ->
986 let names = reduced ++ map funName candidates in
987 reduceLoop names (
988 cons ++ map reduce candidates, map (reduceCall names) rest
989 )
990 where findConstructors :: JS -> Bool
991 findConstructors js
992 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
993 reducable $ last body
994 | otherwise = False
995 where reducable :: JS -> Bool
996 reducable js
997 | JSReturn ret <- js = reducable ret
998 | JSNew _ args <- js = and $ map reducable args
999 | JSArray fields <- js = and $ map reducable fields
1000 | JSNum _ <- js = True
1001 | JSNull <- js = True
1002 | JSIdent _ <- js = True
1003 | otherwise = False
1006 reduce :: JS -> JS
1007 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1008 | JSReturn js <- last body = (JSAlloc fun (Just js))
1010 reduce js = js
1013 reduceCall :: [String] -> JS -> JS
1014 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1015 JSReturn (JSApp id@(JSIdent ret) _)
1016 )])
1017 | ret `elem` funs = id
1019 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1020 | fun `elem` funs = id
1022 reduceCall funs js = transformJS (reduceCall funs) js
1025optimizeJS :: JS -> JS
1026optimizeJS = inlineLoop
1027 where inlineLoop :: JS -> JS
1028 inlineLoop js
1029 | opt <- inlineJS js
1030 , opt /= js = inlineLoop opt
1031 | otherwise = js
1034extractLocalConstructors :: [JS] -> [JS]
1035extractLocalConstructors js =
1036 concatMap extractLocalConstructors' js
1037 where
1038 globalCons :: [String]
1039 globalCons = concatMap (getGlobalCons) js
1042 extractLocalConstructors' :: JS -> [JS]
1043 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1044 addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1045 where
1046 cons :: [(JS, JS)]
1047 cons = zipWith genName (foldJS match (++) [] body) [1..]
1048 where
1049 genName :: JS -> Int -> (JS, JS)
1050 genName js id =
1051 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1053 match :: JS -> [JS]
1054 match js
1055 | JSNew "__IDRRT__Con" args <- js
1056 , all isConstant args = [js]
1057 | otherwise = []
1060 addCons :: [(JS, JS)] -> [JS] -> [JS]
1061 addCons [] js = js
1062 addCons (con@(_, name):cons) js
1063 | sum (map (countOccur name) js) > 0 =
1064 addCons cons ((allocCon con) : js)
1065 | otherwise =
1066 addCons cons js
1069 countOccur :: JS -> JS -> Int
1070 countOccur ident js = foldJS match (+) 0 js
1071 where
1072 match :: JS -> Int
1073 match js
1074 | js == ident = 1
1075 | otherwise = 0
1078 allocCon :: (JS, JS) -> JS
1079 allocCon (js, JSIdent name) =
1080 JSAlloc name (Just js)
1083 isConstant :: JS -> Bool
1084 isConstant js
1085 | JSNew "__IDRRT__Con" args <- js
1086 , all isConstant args =
1087 True
1088 | otherwise =
1089 isJSConstantConstructor globalCons js
1091 extractLocalConstructors' js = [js]
1094 getGlobalCons :: JS -> [String]
1095 getGlobalCons js = foldJS match (++) [] js
1096 where
1097 match :: JS -> [String]
1098 match js
1099 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1100 [name]
1101 | otherwise =
1102 []
1105evalCons :: [JS] -> [JS]
1106evalCons js =
1107 map (collapseCont . collapseTC . expandProj . evalCons') js
1108 where
1109 cons :: [(String, JS)]
1110 cons = concatMap getGlobalCons js
1112 evalCons' :: JS -> JS
1113 evalCons' js = transformJS match js
1114 where
1115 match :: JS -> JS
1116 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1117 | JSIdent name <- arg
1118 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1119 arg
1121 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1122 | JSIdent name <- arg
1123 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1124 arg
1126 match js = transformJS match js
1129 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1130 lookupConstructor ctr cons
1131 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1132 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1133 | otherwise = Nothing
1136 expandProj :: JS -> JS
1137 expandProj js = transformJS match js
1138 where
1139 match :: JS -> JS
1140 match (
1141 JSIndex (
1142 JSProj (JSIdent name) "vars"
1143 ) (
1144 JSNum (JSInt idx)
1147 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1148 args !! idx
1150 match js = transformJS match js
1153 collapseTC :: JS -> JS
1154 collapseTC js = transformJS match js
1155 where
1156 match :: JS -> JS
1157 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1158 JSReturn (JSIdent name)
1159 )])
1160 | Just _ <- lookup name cons = (JSIdent name)
1162 match js = transformJS match js
1165 collapseCont :: JS -> JS
1166 collapseCont js = transformJS match js
1167 where
1168 match :: JS -> JS
1169 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1170 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1171 )]) = collapseCont ret
1174 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1175 JSReturn (JSIdent name)
1176 )]) = JSIdent name
1178 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1179 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1180 )])
1181 | all collapsable args = ret
1182 where
1183 collapsable :: JS -> Bool
1184 collapsable (JSIdent _) = True
1185 collapsable js = isJSConstantConstructor (map fst cons) js
1188 match js = transformJS match js
1191getGlobalCons :: JS -> [(String, JS)]
1192getGlobalCons js = foldJS match (++) [] js
1193 where
1194 match :: JS -> [(String, JS)]
1195 match js
1196 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1197 [(name, con)]
1198 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1199 [(name, con)]
1200 | otherwise =
1201 []
1204codegenJavaScript
1205 :: JSTarget
1206 -> [(Name, SDecl)]
1207 -> FilePath
1208 -> OutputType
1209 -> IO ()
1210codegenJavaScript target definitions filename outputType = do
1211 let (header, runtime) = case target of
1212 Node ->
1213 ("#!/usr/bin/env node\n", "-node")
1214 JavaScript ->
1215 ("", "-browser")
1216 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1217 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1218 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
1219 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1220 writeFile filename $ header ++ (
1221 intercalate "\n" $ [ jsbn
1222 , idrRuntime
1223 , tgtRuntime
1224 ] ++ functions
1227 setPermissions filename (emptyPermissions { readable = True
1228 , executable = target == Node
1229 , writable = True
1230 })
1231 where
1232 def :: [(String, SDecl)]
1233 def = map (first translateNamespace) definitions
1236 functions :: [String]
1237 functions = translate >>> optimize >>> compile $ def
1238 where
1239 translate p =
1240 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1241 optimize p =
1242 foldl' (flip ($)) p opt
1243 compile =
1244 map compileJS
1246 opt = []
1247 {-[ map optimizeJS-}
1248 {-, removeIDs-}
1249 {-, reduceJS-}
1250 {-, map reduceConstants-}
1251 {-, initConstructors-}
1252 {-, map removeAllocations-}
1253 {-, elimDeadLoop-}
1254 {-, map elimDuplicateEvals-}
1255 {-, optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"-}
1256 {-, optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"-}
1257 {-, map removeInstanceChecks-}
1258 {-, inlineFunctions-}
1259 {-, map reduceContinuations-}
1260 {-, extractLocalConstructors-}
1261 {-, unfoldLookupTable-}
1262 {-, evalCons-}
1263 {-]-}
1265 prelude :: [JS]
1266 prelude =
1267 [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1268 JSAssign (JSProj JSThis "k") (JSIdent "k")
1269 ))
1270 , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1271 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1272 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1274 ))
1277 mainLoop :: JS
1278 mainLoop =
1279 JSAlloc "main" $ Just $ JSFunction [] (
1280 case target of
1281 Node -> mainFun
1282 JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [
1283 JSString "DOMContentLoaded", JSFunction [] (
1284 mainFun
1285 ), JSFalse
1286 ])]
1288 where
1289 mainFun :: JS
1290 mainFun = jsTailcall $ jsCall runMain []
1293 isReady :: JS
1294 isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1297 readyState :: JS
1298 readyState = JSProj (JSIdent "document") "readyState"
1301 runMain :: String
1302 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1305 invokeLoop :: JS
1306 invokeLoop = jsCall "main" []
1309translateIdentifier :: String -> String
1310translateIdentifier =
1311 replaceReserved . concatMap replaceBadChars
1312 where replaceBadChars :: Char -> String
1313 replaceBadChars c
1314 | ' ' <- c = "_"
1315 | '_' <- c = "__"
1316 | isDigit c = '_' : show (ord c)
1317 | not (isLetter c && isAscii c) = '_' : show (ord c)
1318 | otherwise = [c]
1319 replaceReserved s
1320 | s `elem` reserved = '_' : s
1321 | otherwise = s
1324 reserved = [ "break"
1325 , "case"
1326 , "catch"
1327 , "continue"
1328 , "debugger"
1329 , "default"
1330 , "delete"
1331 , "do"
1332 , "else"
1333 , "finally"
1334 , "for"
1335 , "function"
1336 , "if"
1337 , "in"
1338 , "instanceof"
1339 , "new"
1340 , "return"
1341 , "switch"
1342 , "this"
1343 , "throw"
1344 , "try"
1345 , "typeof"
1346 , "var"
1347 , "void"
1348 , "while"
1349 , "with"
1351 , "class"
1352 , "enum"
1353 , "export"
1354 , "extends"
1355 , "import"
1356 , "super"
1358 , "implements"
1359 , "interface"
1360 , "let"
1361 , "package"
1362 , "private"
1363 , "protected"
1364 , "public"
1365 , "static"
1366 , "yield"
1370translateNamespace :: Name -> String
1371translateNamespace (UN _) = idrNamespace
1372translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1373translateNamespace (MN _ _) = idrNamespace
1374translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1375translateNamespace NErased = idrNamespace
1378translateName :: Name -> String
1379translateName (UN name) = 'u' : translateIdentifier (str name)
1380translateName (NS name _) = 'n' : translateName name
1381translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1382translateName (SN name) = 's' : translateSpecialName name
1383translateName NErased = "e"
1386translateSpecialName :: SpecialName -> String
1387translateSpecialName name
1388 | WhereN i m n <- name =
1389 'w' : translateName m ++ translateName n ++ show i
1390 | InstanceN n s <- name =
1391 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1392 | ParentN n s <- name =
1393 'p' : translateName n ++ translateIdentifier (str s)
1394 | MethodN n <- name =
1395 'm' : translateName n
1396 | CaseN n <- name =
1397 'c' : translateName n
1400translateConstant :: Const -> JS
1401translateConstant (I i) = JSNum (JSInt i)
1402translateConstant (Fl f) = JSNum (JSFloat f)
1403translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1404translateConstant (Ch '\a') = JSChar "'\\u0007'"
1405translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1406translateConstant (Ch c) = JSString [c]
1407translateConstant (Str s) = JSString s
1408translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1409translateConstant StrType = JSType JSStringTy
1410translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1411translateConstant (AType ATFloat) = JSType JSFloatTy
1412translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1413translateConstant PtrType = JSType JSPtrTy
1414translateConstant Forgot = JSType JSForgotTy
1415translateConstant (BI i) = jsBigInt $ JSString (show i)
1416translateConstant c =
1417 jsError $ "Unimplemented Constant: " ++ show c
1420translateDeclaration :: (String, SDecl) -> [JS]
1421translateDeclaration (path, SFun name params stackSize body)
1422 {-| (MN _ ap) <- name-}
1423 {-, (SLet var val next) <- body-}
1424 {-, (SChkCase cvar cases) <- next-}
1425 {-, ap == txt "APPLY" =-}
1426 {-let lvar = translateVariableName var-}
1427 {-lookup t = (JSApp-}
1428 {-(JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))-}
1429 {-[JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in-}
1430 {-[ lookupTable "APPLY" [(var, "chk")] var cases-}
1431 {-, jsDecl $ JSFunction ["fn0", "arg0"] (-}
1432 {-JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")-}
1433 {-, JSAlloc (translateVariableName var) (-}
1434 {-Just $ translateExpression val-}
1435 {-)-}
1436 {-, JSReturn $ (JSTernary (-}
1437 {-(JSVar var `jsInstanceOf` jsCon) `jsAnd`-}
1438 {-(hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))-}
1439 {-) (lookup (idrLTNamespace ++ "APPLY")) JSNull)-}
1440 {-]-}
1441 {-)-}
1442 {-]-}
1444 {-| (MN _ ev) <- name-}
1445 {-, (SChkCase var cases) <- body-}
1446 {-, ev == txt "EVAL" =-}
1447 {-[ lookupTable "EVAL" [] var cases-}
1448 {-, jsDecl $ JSFunction ["arg0"] (JSReturn $-}
1449 {-JSTernary (-}
1450 {-(JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`-}
1451 {-(hasProp (idrLTNamespace ++ "EVAL") "arg0")-}
1452 {-) (JSApp-}
1453 {-(JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))-}
1454 {-[JSIdent "arg0"]-}
1455 {-) (JSIdent "arg0")-}
1456 {-)-}
1457 {-]-}
1458 | otherwise =
1459 let fun = translateExpression body in
1460 [jsDecl $ jsFun fun]
1462 where
1463 hasProp :: String -> String -> JS
1464 hasProp table var =
1465 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1468 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1469 caseFun aux var cse =
1470 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1471 jsFunAux aux c
1474 getTag :: SAlt -> Maybe Int
1475 getTag (SConCase _ tag _ _ _) = Just tag
1476 getTag _ = Nothing
1479 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1480 lookupTable table aux var cases =
1481 JSAlloc (idrLTNamespace ++ table) $ Just (
1482 JSApp (JSFunction [] (
1483 JSSeq $ [
1484 JSAlloc "t" $ Just (JSArray [])
1485 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1486 JSReturn (JSIdent "t")
1488 )) []
1490 where
1491 assignEntries :: [(Int, JS)] -> [JS]
1492 assignEntries entries =
1493 map (\(tag, fun) ->
1494 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1495 ) entries
1498 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1499 lookupEntry aux var alt = do
1500 tag <- getTag alt
1501 return (tag, caseFun aux var alt)
1504 jsDecl :: JS -> JS
1505 jsDecl = JSAlloc (path ++ translateName name) . Just
1508 jsFun body = jsFunAux [] body
1511 jsFunAux :: [(LVar, String)] -> JS -> JS
1512 jsFunAux aux body =
1513 JSFunction (p ++ map snd aux) (
1514 JSSeq $
1515 zipWith assignVar [0..] p ++
1516 map assignAux aux ++
1517 [JSReturn body]
1519 where
1520 assignVar :: Int -> String -> JS
1521 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1524 assignAux :: (LVar, String) -> JS
1525 assignAux (Loc var, val) =
1526 JSAlloc (jsVar var) (Just $ JSIdent val)
1529 p :: [String]
1530 p = map translateName params
1533translateVariableName :: LVar -> String
1534translateVariableName (Loc i) =
1535 jsVar i
1538translateExpression :: SExp -> JS
1539translateExpression (SLet name value body) =
1540 jsLet (translateVariableName name) (
1541 translateExpression value
1542 ) (translateExpression body)
1544translateExpression (SConst cst) =
1545 translateConstant cst
1547translateExpression (SV var) =
1548 JSVar var
1550translateExpression (SApp tc name vars)
1551 | False <- tc =
1552 jsTailcall $ translateFunctionCall name vars
1553 | True <- tc =
1554 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1555 JSReturn $ translateFunctionCall name vars
1556 )]
1557 where
1558 translateFunctionCall name vars =
1559 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1561translateExpression (SOp op vars)
1562 | LNoOp <- op = JSVar (last vars)
1564 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1565 | (LPlus (ATInt ITBig)) <- op
1566 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1567 | (LMinus (ATInt ITBig)) <- op
1568 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1569 | (LTimes (ATInt ITBig)) <- op
1570 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1571 | (LSDiv (ATInt ITBig)) <- op
1572 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1573 | (LSRem (ATInt ITBig)) <- op
1574 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1575 | (LEq (ATInt ITBig)) <- op
1576 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1577 | (LSLt (ATInt ITBig)) <- op
1578 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1579 | (LSLe (ATInt ITBig)) <- op
1580 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1581 | (LSGt (ATInt ITBig)) <- op
1582 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1583 | (LSGe (ATInt ITBig)) <- op
1584 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1586 | (LPlus ATFloat) <- op
1587 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1588 | (LMinus ATFloat) <- op
1589 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1590 | (LTimes ATFloat) <- op
1591 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1592 | (LSDiv ATFloat) <- op
1593 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1594 | (LEq ATFloat) <- op
1595 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1596 | (LSLt ATFloat) <- op
1597 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1598 | (LSLe ATFloat) <- op
1599 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1600 | (LSGt ATFloat) <- op
1601 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1602 | (LSGe ATFloat) <- op
1603 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1605 | (LPlus _) <- op
1606 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1607 | (LMinus _) <- op
1608 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1609 | (LTimes _) <- op
1610 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1611 | (LSDiv _) <- op
1612 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1613 | (LSRem _) <- op
1614 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1615 | (LEq _) <- op
1616 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1617 | (LSLt _) <- op
1618 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1619 | (LSLe _) <- op
1620 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1621 | (LSGt _) <- op
1622 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1623 | (LSGe _) <- op
1624 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1625 | (LAnd _) <- op
1626 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1627 | (LOr _) <- op
1628 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1629 | (LXOr _) <- op
1630 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1631 | (LSHL _) <- op
1632 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1633 | (LASHR _) <- op
1634 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1635 | (LCompl _) <- op
1636 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
1638 | LStrConcat <- op
1639 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1640 | LStrEq <- op
1641 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1642 | LStrLt <- op
1643 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1644 | LStrLen <- op
1645 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1647 | (LStrInt ITNative) <- op
1648 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1649 | (LIntStr ITNative) <- op
1650 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1651 | (LSExt ITNative ITBig) <- op
1652 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1653 | (LTrunc ITBig ITNative) <- op
1654 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1655 | (LIntStr ITBig) <- op
1656 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1657 | (LStrInt ITBig) <- op
1658 , (arg:_) <- vars = jsBigInt $ JSVar arg
1659 | LFloatStr <- op
1660 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1661 | LStrFloat <- op
1662 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1663 | (LIntFloat ITNative) <- op
1664 , (arg:_) <- vars = JSVar arg
1665 | (LFloatInt ITNative) <- op
1666 , (arg:_) <- vars = JSVar arg
1667 | (LChInt ITNative) <- op
1668 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1669 | (LIntCh ITNative) <- op
1670 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1672 | LFExp <- op
1673 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1674 | LFLog <- op
1675 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1676 | LFSin <- op
1677 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1678 | LFCos <- op
1679 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1680 | LFTan <- op
1681 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1682 | LFASin <- op
1683 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1684 | LFACos <- op
1685 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1686 | LFATan <- op
1687 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1688 | LFSqrt <- op
1689 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1690 | LFFloor <- op
1691 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1692 | LFCeil <- op
1693 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1695 | LStrCons <- op
1696 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1697 | LStrHead <- op
1698 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1699 | LStrRev <- op
1700 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1701 | LStrIndex <- op
1702 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1703 | LStrTail <- op
1704 , (arg:_) <- vars = let v = translateVariableName arg in
1705 JSApp (JSProj (JSIdent v) "substr") [
1706 JSNum (JSInt 1),
1707 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
1709 | LNullPtr <- op
1710 , (_) <- vars = JSNull
1712 where
1713 translateBinaryOp :: String -> LVar -> LVar -> JS
1714 translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
1717 invokeMeth :: LVar -> String -> [LVar] -> JS
1718 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1720translateExpression (SError msg) =
1721 jsError msg
1723translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1724 jsCall (idrRTNamespace ++ "print") [JSVar var]
1726translateExpression (SForeign _ _ fun args) =
1727 ffi fun (map generateWrapper args)
1728 where
1729 generateWrapper (ffunc, name)
1730 | FFunction <- ffunc =
1731 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1732 | FFunctionIO <- ffunc =
1733 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1735 generateWrapper (_, name) =
1736 translateVariableName name
1738translateExpression patterncase
1739 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1740 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1741 where
1742 caseHelper var cases param =
1743 JSApp (JSFunction [param] (
1744 JSCond $ map (expandCase param . translateCaseCond param) cases
1745 )) [JSVar var]
1748 expandCase :: String -> (Cond, JS) -> (JS, JS)
1749 expandCase _ (RawCond cond, branch) = (cond, branch)
1750 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1751 expandCase var (CaseCond caseTy, branch)
1752 | ConCase tag <- caseTy =
1753 let checkCon = JSIdent var `jsInstanceOf` jsCon
1754 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1755 (checkCon `jsAnd` checkTag, branch)
1757 | TypeCase ty <- caseTy =
1758 let checkTy = JSIdent var `jsInstanceOf` jsType
1759 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1760 (checkTy `jsAnd` checkTag, branch)
1762translateExpression (SCon i name vars) =
1763 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1764 , JSArray $ map JSVar vars
1767translateExpression (SUpdate var@(Loc i) e) =
1768 JSAssign (JSVar var) (translateExpression e)
1770translateExpression (SProj var i) =
1771 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1773translateExpression SNothing = JSNull
1775translateExpression e =
1776 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1779data FFI = FFICode Char | FFIArg Int | FFIError String
1782ffi :: String -> [String] -> JS
1783ffi code args = let parsed = ffiParse code in
1784 case ffiError parsed of
1785 Just err -> jsError err
1786 Nothing -> JSRaw $ renderFFI parsed args
1787 where
1788 ffiParse :: String -> [FFI]
1789 ffiParse "" = []
1790 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1791 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1792 ffiParse ('%':s:ss)
1793 | isDigit s =
1794 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1795 | otherwise =
1796 [FFIError "Invalid positional argument"]
1797 ffiParse (s:ss) = FFICode s : ffiParse ss
1800 ffiError :: [FFI] -> Maybe String
1801 ffiError [] = Nothing
1802 ffiError ((FFIError s):xs) = Just s
1803 ffiError (x:xs) = ffiError xs
1806 renderFFI :: [FFI] -> [String] -> String
1807 renderFFI [] _ = ""
1808 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1809 renderFFI ((FFIArg i) : fs) args
1810 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1811 | otherwise = "Argument index out of bounds"
1814data CaseType = ConCase Int
1815 | TypeCase JSType
1816 | DefaultCase
1817 deriving Eq
1820data Cond = CaseCond CaseType
1821 | RawCond JS
1824translateCaseCond :: String -> SAlt -> (Cond, JS)
1825translateCaseCond _ cse@(SDefaultCase _) =
1826 (CaseCond DefaultCase, translateCase Nothing cse)
1828translateCaseCond var cse@(SConstCase ty _)
1829 | StrType <- ty = matchHelper JSStringTy
1830 | PtrType <- ty = matchHelper JSPtrTy
1831 | Forgot <- ty = matchHelper JSForgotTy
1832 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1833 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1834 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1835 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1836 where
1837 matchHelper :: JSType -> (Cond, JS)
1838 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1840translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1841 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1842 (RawCond cond, translateCase Nothing cse)
1844translateCaseCond var cse@(SConstCase cst _) =
1845 let cond = JSIdent var `jsEq` translateConstant cst in
1846 (RawCond cond, translateCase Nothing cse)
1848translateCaseCond var cse@(SConCase _ tag _ _ _) =
1849 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1852translateCase :: Maybe String -> SAlt -> JS
1853translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
1854translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
1855translateCase (Just var) (SConCase a _ _ vars e) =
1856 let params = map jsVar [a .. (a + length vars)] in
1857 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1858 JSThis, JSProj (JSIdent var) "vars"