git.iko.soy/Idris-dev
on 407cf60 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1855 lines 57 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 (JSNoop, e) =
190 "{\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 = moveJSDeclToTop "__IDRRT__Con" $ 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 "ret" $ Just (
826 JSTernary (
827 (JSIdent "fn0" `jsInstanceOf` jsCon) `jsAnd`
828 (hasProp "__IDRLT__APPLY" "fn0")
829 ) (JSApp
830 (JSIndex
831 (JSIdent "__IDRLT__APPLY")
832 (JSProj (JSIdent "fn0") "tag")
833 )
834 [JSIdent "fn0", JSIdent "arg0", JSIdent "fn0"]
835 ) JSNull
836 )
837 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
838 JSAssign (JSIdent "ret") (
839 JSApp (JSProj (JSIdent "ret") "k") []
840 )
841 )
842 , JSReturn $ JSIdent "ret"
843 ]
844 ))
847 hasProp :: String -> String -> JS
848 hasProp table var =
849 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
852unfoldLookupTable :: [JS] -> [JS]
853unfoldLookupTable input =
854 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
855 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
856 js = applyunfold in
857 adaptRuntime $ expandCons evals applys js
858 where
859 adaptRuntime :: [JS] -> [JS]
860 adaptRuntime =
861 adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
864 adaptApply var = map (jsSubst (
865 JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
866 ) (JSProj (JSIdent var) "app"))
869 adaptEval = map (jsSubst (
870 JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
871 ) (JSProj (JSIdent "arg0") "eval"))
874 adaptCon js =
875 adaptCon' [] js
876 where
877 adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
878 front ++ (new:back)
880 adaptCon' front (next:back) =
881 adaptCon' (front ++ [next]) back
883 adaptCon' front [] = front
886 new =
887 JSAlloc "__IDRRT__Con" (Just $
888 JSFunction newArgs (
889 JSSeq (map newVar newArgs)
890 )
891 )
892 where
893 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
894 newArgs = ["tag", "eval", "app", "vars"]
897 unfoldLT :: String -> [JS] -> ([Int], [JS])
898 unfoldLT lt js =
899 let (table, code) = extractLT lt js
900 expanded = expandLT lt table in
901 (map fst expanded, map snd expanded ++ code)
904 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
905 expandCons evals applys js =
906 map expandCons' js
907 where
908 expandCons' :: JS -> JS
909 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
910 | evalid <- getId "__IDRLT__EVAL" tag evals
911 , applyid <- getId "__IDRLT__APPLY" tag applys =
912 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
913 , maybe JSNull JSIdent evalid
914 , maybe JSNull JSIdent applyid
915 , JSArray (map expandCons' args)
916 ]
918 expandCons' js = transformJS expandCons' js
921 getId :: String -> Int -> [Int] -> Maybe String
922 getId lt tag entries
923 | tag `elem` entries = Just $ ltIdentifier lt tag
924 | otherwise = Nothing
927 ltIdentifier :: String -> Int -> String
928 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
929 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
932 extractLT :: String -> [JS] -> (JS, [JS])
933 extractLT lt js =
934 extractLT' ([], js)
935 where
936 extractLT' :: ([JS], [JS]) -> (JS, [JS])
937 extractLT' (front, js@(JSAlloc fun _):back)
938 | fun == lt = (js, front ++ back)
940 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
941 extractLT' (front, back) = (JSNoop, front ++ back)
944 expandLT :: String -> JS -> [(Int, JS)]
945 expandLT lt (
946 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
947 ) = catMaybes (map expandEntry seq)
948 where
949 expandEntry :: JS -> Maybe (Int, JS)
950 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
951 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
953 expandEntry js = Nothing
955 expandLT lt JSNoop = []
958removeInstanceChecks :: JS -> JS
959removeInstanceChecks (JSCond conds) =
960 JSCond $ eliminateDeadBranches $ map (
961 removeHelper *** removeInstanceChecks
962 ) conds
963 where
964 removeHelper (
965 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
966 ) = removeHelper check
967 removeHelper js = js
970 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
971 eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
972 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
973 eliminateDeadBranches [] = []
975removeInstanceChecks js = transformJS removeInstanceChecks js
978reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
979reduceLoop reduced (cons, program) =
980 case partition findConstructors program of
981 ([], js) -> cons ++ js
982 (candidates, rest) ->
983 let names = reduced ++ map funName candidates in
984 reduceLoop names (
985 cons ++ map reduce candidates, map (reduceCall names) rest
986 )
987 where findConstructors :: JS -> Bool
988 findConstructors js
989 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
990 reducable $ last body
991 | otherwise = False
992 where reducable :: JS -> Bool
993 reducable js
994 | JSReturn ret <- js = reducable ret
995 | JSNew _ args <- js = and $ map reducable args
996 | JSArray fields <- js = and $ map reducable fields
997 | JSNum _ <- js = True
998 | JSNull <- js = True
999 | JSIdent _ <- js = True
1000 | otherwise = False
1003 reduce :: JS -> JS
1004 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
1005 | JSReturn js <- last body = (JSAlloc fun (Just js))
1007 reduce js = js
1010 reduceCall :: [String] -> JS -> JS
1011 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1012 JSReturn (JSApp id@(JSIdent ret) _)
1013 )])
1014 | ret `elem` funs = id
1016 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1017 | fun `elem` funs = id
1019 reduceCall funs js = transformJS (reduceCall funs) js
1022optimizeJS :: JS -> JS
1023optimizeJS = inlineLoop
1024 where inlineLoop :: JS -> JS
1025 inlineLoop js
1026 | opt <- inlineJS js
1027 , opt /= js = inlineLoop opt
1028 | otherwise = js
1031extractLocalConstructors :: [JS] -> [JS]
1032extractLocalConstructors js =
1033 concatMap extractLocalConstructors' js
1034 where
1035 globalCons :: [String]
1036 globalCons = concatMap (getGlobalCons) js
1039 extractLocalConstructors' :: JS -> [JS]
1040 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1041 addCons cons [foldr (uncurry jsSubst) js (reverse cons)]
1042 where
1043 cons :: [(JS, JS)]
1044 cons = zipWith genName (foldJS match (++) [] body) [1..]
1045 where
1046 genName :: JS -> Int -> (JS, JS)
1047 genName js id =
1048 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1050 match :: JS -> [JS]
1051 match js
1052 | JSNew "__IDRRT__Con" args <- js
1053 , all isConstant args = [js]
1054 | otherwise = []
1057 addCons :: [(JS, JS)] -> [JS] -> [JS]
1058 addCons [] js = js
1059 addCons (con@(_, name):cons) js
1060 | sum (map (countOccur name) js) > 0 =
1061 addCons cons ((allocCon con) : js)
1062 | otherwise =
1063 addCons cons js
1066 countOccur :: JS -> JS -> Int
1067 countOccur ident js = foldJS match (+) 0 js
1068 where
1069 match :: JS -> Int
1070 match js
1071 | js == ident = 1
1072 | otherwise = 0
1075 allocCon :: (JS, JS) -> JS
1076 allocCon (js, JSIdent name) =
1077 JSAlloc name (Just js)
1080 isConstant :: JS -> Bool
1081 isConstant js
1082 | JSNew "__IDRRT__Con" args <- js
1083 , all isConstant args =
1084 True
1085 | otherwise =
1086 isJSConstantConstructor globalCons js
1088 extractLocalConstructors' js = [js]
1091 getGlobalCons :: JS -> [String]
1092 getGlobalCons js = foldJS match (++) [] js
1093 where
1094 match :: JS -> [String]
1095 match js
1096 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1097 [name]
1098 | otherwise =
1099 []
1102evalCons :: [JS] -> [JS]
1103evalCons js =
1104 map (collapseCont . collapseTC . expandProj . evalCons') js
1105 where
1106 cons :: [(String, JS)]
1107 cons = concatMap getGlobalCons js
1109 evalCons' :: JS -> JS
1110 evalCons' js = transformJS match js
1111 where
1112 match :: JS -> JS
1113 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1114 | JSIdent name <- arg
1115 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1116 arg
1118 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1119 | JSIdent name <- arg
1120 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1121 arg
1123 match js = transformJS match js
1126 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1127 lookupConstructor ctr cons
1128 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1129 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1130 | otherwise = Nothing
1133 expandProj :: JS -> JS
1134 expandProj js = transformJS match js
1135 where
1136 match :: JS -> JS
1137 match (
1138 JSIndex (
1139 JSProj (JSIdent name) "vars"
1140 ) (
1141 JSNum (JSInt idx)
1144 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1145 args !! idx
1147 match js = transformJS match js
1150 collapseTC :: JS -> JS
1151 collapseTC js = transformJS match js
1152 where
1153 match :: JS -> JS
1154 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1155 JSReturn (JSIdent name)
1156 )])
1157 | Just _ <- lookup name cons = (JSIdent name)
1159 match js = transformJS match js
1162 collapseCont :: JS -> JS
1163 collapseCont js = transformJS match js
1164 where
1165 match :: JS -> JS
1166 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1167 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1168 )]) = collapseCont ret
1171 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1172 JSReturn (JSIdent name)
1173 )]) = JSIdent name
1175 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1176 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1177 )])
1178 | all collapsable args = ret
1179 where
1180 collapsable :: JS -> Bool
1181 collapsable (JSIdent _) = True
1182 collapsable js = isJSConstantConstructor (map fst cons) js
1185 match js = transformJS match js
1188getGlobalCons :: JS -> [(String, JS)]
1189getGlobalCons js = foldJS match (++) [] js
1190 where
1191 match :: JS -> [(String, JS)]
1192 match js
1193 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1194 [(name, con)]
1195 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1196 [(name, con)]
1197 | otherwise =
1198 []
1201codegenJavaScript
1202 :: JSTarget
1203 -> [(Name, SDecl)]
1204 -> FilePath
1205 -> OutputType
1206 -> IO ()
1207codegenJavaScript target definitions filename outputType = do
1208 let (header, runtime) = case target of
1209 Node ->
1210 ("#!/usr/bin/env node\n", "-node")
1211 JavaScript ->
1212 ("", "-browser")
1213 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1214 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1215 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
1216 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1217 writeFile filename $ header ++ (
1218 intercalate "\n" $ [ jsbn
1219 , idrRuntime
1220 , tgtRuntime
1221 ] ++ functions
1224 setPermissions filename (emptyPermissions { readable = True
1225 , executable = target == Node
1226 , writable = True
1227 })
1228 where
1229 def :: [(String, SDecl)]
1230 def = map (first translateNamespace) definitions
1233 functions :: [String]
1234 functions = translate >>> optimize >>> compile $ def
1235 where
1236 translate p =
1237 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1238 optimize p =
1239 foldl' (flip ($)) p opt
1240 compile =
1241 map compileJS
1243 opt = []
1244 {-[ map optimizeJS-}
1245 {-, removeIDs-}
1246 {-, reduceJS-}
1247 {-, map reduceConstants-}
1248 {-, initConstructors-}
1249 {-, map removeAllocations-}
1250 {-, elimDeadLoop-}
1251 {-, map elimDuplicateEvals-}
1252 {-, optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"-}
1253 {-, optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"-}
1254 {-, map removeInstanceChecks-}
1255 {-, inlineFunctions-}
1256 {-, map reduceContinuations-}
1257 {-, extractLocalConstructors-}
1258 {-, unfoldLookupTable-}
1259 {-, evalCons-}
1260 {-]-}
1262 prelude :: [JS]
1263 prelude =
1264 [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1265 JSAssign (JSProj JSThis "k") (JSIdent "k")
1266 ))
1267 , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1268 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1269 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1271 ))
1274 mainLoop :: JS
1275 mainLoop =
1276 JSAlloc "main" $ Just $ JSFunction [] (
1277 case target of
1278 Node -> mainFun
1279 JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [
1280 JSString "DOMContentLoaded", JSFunction [] (
1281 mainFun
1282 ), JSFalse
1283 ])]
1285 where
1286 mainFun :: JS
1287 mainFun = jsTailcall $ jsCall runMain []
1290 isReady :: JS
1291 isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"
1294 readyState :: JS
1295 readyState = JSProj (JSIdent "document") "readyState"
1298 runMain :: String
1299 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1302 invokeLoop :: JS
1303 invokeLoop = jsCall "main" []
1306translateIdentifier :: String -> String
1307translateIdentifier =
1308 replaceReserved . concatMap replaceBadChars
1309 where replaceBadChars :: Char -> String
1310 replaceBadChars c
1311 | ' ' <- c = "_"
1312 | '_' <- c = "__"
1313 | isDigit c = '_' : show (ord c)
1314 | not (isLetter c && isAscii c) = '_' : show (ord c)
1315 | otherwise = [c]
1316 replaceReserved s
1317 | s `elem` reserved = '_' : s
1318 | otherwise = s
1321 reserved = [ "break"
1322 , "case"
1323 , "catch"
1324 , "continue"
1325 , "debugger"
1326 , "default"
1327 , "delete"
1328 , "do"
1329 , "else"
1330 , "finally"
1331 , "for"
1332 , "function"
1333 , "if"
1334 , "in"
1335 , "instanceof"
1336 , "new"
1337 , "return"
1338 , "switch"
1339 , "this"
1340 , "throw"
1341 , "try"
1342 , "typeof"
1343 , "var"
1344 , "void"
1345 , "while"
1346 , "with"
1348 , "class"
1349 , "enum"
1350 , "export"
1351 , "extends"
1352 , "import"
1353 , "super"
1355 , "implements"
1356 , "interface"
1357 , "let"
1358 , "package"
1359 , "private"
1360 , "protected"
1361 , "public"
1362 , "static"
1363 , "yield"
1367translateNamespace :: Name -> String
1368translateNamespace (UN _) = idrNamespace
1369translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1370translateNamespace (MN _ _) = idrNamespace
1371translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1372translateNamespace NErased = idrNamespace
1375translateName :: Name -> String
1376translateName (UN name) = 'u' : translateIdentifier (str name)
1377translateName (NS name _) = 'n' : translateName name
1378translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1379translateName (SN name) = 's' : translateSpecialName name
1380translateName NErased = "e"
1383translateSpecialName :: SpecialName -> String
1384translateSpecialName name
1385 | WhereN i m n <- name =
1386 'w' : translateName m ++ translateName n ++ show i
1387 | InstanceN n s <- name =
1388 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1389 | ParentN n s <- name =
1390 'p' : translateName n ++ translateIdentifier (str s)
1391 | MethodN n <- name =
1392 'm' : translateName n
1393 | CaseN n <- name =
1394 'c' : translateName n
1397translateConstant :: Const -> JS
1398translateConstant (I i) = JSNum (JSInt i)
1399translateConstant (Fl f) = JSNum (JSFloat f)
1400translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1401translateConstant (Ch '\a') = JSChar "'\\u0007'"
1402translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1403translateConstant (Ch c) = JSString [c]
1404translateConstant (Str s) = JSString s
1405translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1406translateConstant StrType = JSType JSStringTy
1407translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1408translateConstant (AType ATFloat) = JSType JSFloatTy
1409translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1410translateConstant PtrType = JSType JSPtrTy
1411translateConstant Forgot = JSType JSForgotTy
1412translateConstant (BI i) = jsBigInt $ JSString (show i)
1413translateConstant c =
1414 jsError $ "Unimplemented Constant: " ++ show c
1417translateDeclaration :: (String, SDecl) -> [JS]
1418translateDeclaration (path, SFun name params stackSize body)
1419 | (MN _ ap) <- name
1420 , (SChkCase var cases) <- body
1421 , ap == txt "APPLY" =
1422 [ lookupTable "APPLY" [] var cases
1423 , jsDecl $ JSFunction ["mfn0", "marg0"] (JSReturn $
1424 JSTernary (
1425 (JSIdent "mfn0" `jsInstanceOf` jsCon) `jsAnd`
1426 (hasProp (idrLTNamespace ++ "APPLY") "mfn0")
1427 ) (JSApp
1428 (JSIndex
1429 (JSIdent (idrLTNamespace ++ "APPLY"))
1430 (JSProj (JSIdent "mfn0") "tag")
1432 [JSIdent "mfn0", JSIdent "marg0"]
1433 ) JSNull
1437 | (MN _ ev) <- name
1438 , (SChkCase var cases) <- body
1439 , ev == txt "EVAL" =
1440 [ lookupTable "EVAL" [] var cases
1441 , jsDecl $ JSFunction ["marg0"] (JSReturn $
1442 JSTernary (
1443 (JSIdent "marg0" `jsInstanceOf` jsCon) `jsAnd`
1444 (hasProp (idrLTNamespace ++ "EVAL") "marg0")
1445 ) (JSApp
1446 (JSIndex
1447 (JSIdent (idrLTNamespace ++ "EVAL"))
1448 (JSProj (JSIdent "marg0") "tag")
1450 [JSIdent "marg0"]
1451 ) (JSIdent "marg0")
1454 | otherwise =
1455 let fun = translateExpression body in
1456 [jsDecl $ jsFun fun]
1458 where
1459 hasProp :: String -> String -> JS
1460 hasProp table var =
1461 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1464 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1465 caseFun aux var cse =
1466 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1467 jsFunAux aux c
1470 getTag :: SAlt -> Maybe Int
1471 getTag (SConCase _ tag _ _ _) = Just tag
1472 getTag _ = Nothing
1475 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1476 lookupTable table aux var cases =
1477 JSAlloc (idrLTNamespace ++ table) $ Just (
1478 JSApp (JSFunction [] (
1479 JSSeq $ [
1480 JSAlloc "t" $ Just (JSArray [])
1481 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1482 JSReturn (JSIdent "t")
1484 )) []
1486 where
1487 assignEntries :: [(Int, JS)] -> [JS]
1488 assignEntries entries =
1489 map (\(tag, fun) ->
1490 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1491 ) entries
1494 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1495 lookupEntry aux var alt = do
1496 tag <- getTag alt
1497 return (tag, caseFun aux var alt)
1500 jsDecl :: JS -> JS
1501 jsDecl = JSAlloc (path ++ translateName name) . Just
1504 jsFun body = jsFunAux [] body
1507 jsFunAux :: [(LVar, String)] -> JS -> JS
1508 jsFunAux aux body =
1509 JSFunction (p ++ map snd aux) (
1510 JSSeq $
1511 zipWith assignVar [0..] p ++
1512 map assignAux aux ++
1513 [JSReturn body]
1515 where
1516 assignVar :: Int -> String -> JS
1517 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1520 assignAux :: (LVar, String) -> JS
1521 assignAux (Loc var, val) =
1522 JSAlloc (jsVar var) (Just $ JSIdent val)
1525 p :: [String]
1526 p = map translateName params
1529translateVariableName :: LVar -> String
1530translateVariableName (Loc i) =
1531 jsVar i
1534translateExpression :: SExp -> JS
1535translateExpression (SLet name value body) =
1536 jsLet (translateVariableName name) (
1537 translateExpression value
1538 ) (translateExpression body)
1540translateExpression (SConst cst) =
1541 translateConstant cst
1543translateExpression (SV var) =
1544 JSVar var
1546translateExpression (SApp tc name vars)
1547 | False <- tc =
1548 jsTailcall $ translateFunctionCall name vars
1549 | True <- tc =
1550 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1551 JSReturn $ translateFunctionCall name vars
1552 )]
1553 where
1554 translateFunctionCall name vars =
1555 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1557translateExpression (SOp op vars)
1558 | LNoOp <- op = JSVar (last vars)
1560 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1561 | (LPlus (ATInt ITBig)) <- op
1562 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1563 | (LMinus (ATInt ITBig)) <- op
1564 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1565 | (LTimes (ATInt ITBig)) <- op
1566 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1567 | (LSDiv (ATInt ITBig)) <- op
1568 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1569 | (LSRem (ATInt ITBig)) <- op
1570 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1571 | (LEq (ATInt ITBig)) <- op
1572 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1573 | (LSLt (ATInt ITBig)) <- op
1574 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1575 | (LSLe (ATInt ITBig)) <- op
1576 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1577 | (LSGt (ATInt ITBig)) <- op
1578 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1579 | (LSGe (ATInt ITBig)) <- op
1580 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1582 | (LPlus ATFloat) <- op
1583 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1584 | (LMinus ATFloat) <- op
1585 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1586 | (LTimes ATFloat) <- op
1587 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1588 | (LSDiv ATFloat) <- op
1589 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1590 | (LEq ATFloat) <- op
1591 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1592 | (LSLt ATFloat) <- op
1593 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1594 | (LSLe ATFloat) <- op
1595 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1596 | (LSGt ATFloat) <- op
1597 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1598 | (LSGe ATFloat) <- op
1599 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1601 | (LPlus _) <- op
1602 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1603 | (LMinus _) <- op
1604 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1605 | (LTimes _) <- op
1606 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1607 | (LSDiv _) <- op
1608 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1609 | (LSRem _) <- op
1610 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1611 | (LEq _) <- op
1612 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1613 | (LSLt _) <- op
1614 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1615 | (LSLe _) <- op
1616 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1617 | (LSGt _) <- op
1618 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1619 | (LSGe _) <- op
1620 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1621 | (LAnd _) <- op
1622 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1623 | (LOr _) <- op
1624 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1625 | (LXOr _) <- op
1626 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1627 | (LSHL _) <- op
1628 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1629 | (LASHR _) <- op
1630 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1631 | (LCompl _) <- op
1632 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)
1634 | LStrConcat <- op
1635 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1636 | LStrEq <- op
1637 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1638 | LStrLt <- op
1639 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1640 | LStrLen <- op
1641 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1643 | (LStrInt ITNative) <- op
1644 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1645 | (LIntStr ITNative) <- op
1646 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1647 | (LSExt ITNative ITBig) <- op
1648 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1649 | (LTrunc ITBig ITNative) <- op
1650 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1651 | (LIntStr ITBig) <- op
1652 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1653 | (LStrInt ITBig) <- op
1654 , (arg:_) <- vars = jsBigInt $ JSVar arg
1655 | LFloatStr <- op
1656 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1657 | LStrFloat <- op
1658 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1659 | (LIntFloat ITNative) <- op
1660 , (arg:_) <- vars = JSVar arg
1661 | (LFloatInt ITNative) <- op
1662 , (arg:_) <- vars = JSVar arg
1663 | (LChInt ITNative) <- op
1664 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1665 | (LIntCh ITNative) <- op
1666 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1668 | LFExp <- op
1669 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1670 | LFLog <- op
1671 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1672 | LFSin <- op
1673 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1674 | LFCos <- op
1675 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1676 | LFTan <- op
1677 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1678 | LFASin <- op
1679 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1680 | LFACos <- op
1681 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1682 | LFATan <- op
1683 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1684 | LFSqrt <- op
1685 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1686 | LFFloor <- op
1687 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1688 | LFCeil <- op
1689 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1691 | LStrCons <- op
1692 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1693 | LStrHead <- op
1694 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1695 | LStrRev <- op
1696 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1697 | LStrIndex <- op
1698 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1699 | LStrTail <- op
1700 , (arg:_) <- vars = let v = translateVariableName arg in
1701 JSApp (JSProj (JSIdent v) "substr") [
1702 JSNum (JSInt 1),
1703 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))
1705 | LNullPtr <- op
1706 , (_) <- vars = JSNull
1708 where
1709 translateBinaryOp :: String -> LVar -> LVar -> JS
1710 translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
1713 invokeMeth :: LVar -> String -> [LVar] -> JS
1714 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1716translateExpression (SError msg) =
1717 jsError msg
1719translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1720 jsCall (idrRTNamespace ++ "print") [JSVar var]
1722translateExpression (SForeign _ _ fun args) =
1723 ffi fun (map generateWrapper args)
1724 where
1725 generateWrapper (ffunc, name)
1726 | FFunction <- ffunc =
1727 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1728 | FFunctionIO <- ffunc =
1729 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1731 generateWrapper (_, name) =
1732 translateVariableName name
1734translateExpression patterncase
1735 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1736 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1737 where
1738 caseHelper var cases param =
1739 JSApp (JSFunction [param] (
1740 JSCond $ map (expandCase param . translateCaseCond param) cases
1741 )) [JSVar var]
1744 expandCase :: String -> (Cond, JS) -> (JS, JS)
1745 expandCase _ (RawCond cond, branch) = (cond, branch)
1746 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1747 expandCase var (CaseCond caseTy, branch)
1748 | ConCase tag <- caseTy =
1749 let checkCon = JSIdent var `jsInstanceOf` jsCon
1750 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1751 (checkCon `jsAnd` checkTag, branch)
1753 | TypeCase ty <- caseTy =
1754 let checkTy = JSIdent var `jsInstanceOf` jsType
1755 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1756 (checkTy `jsAnd` checkTag, branch)
1758translateExpression (SCon i name vars) =
1759 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1760 , JSArray $ map JSVar vars
1763translateExpression (SUpdate var@(Loc i) e) =
1764 JSAssign (JSVar var) (translateExpression e)
1766translateExpression (SProj var i) =
1767 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1769translateExpression SNothing = JSNull
1771translateExpression e =
1772 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1775data FFI = FFICode Char | FFIArg Int | FFIError String
1778ffi :: String -> [String] -> JS
1779ffi code args = let parsed = ffiParse code in
1780 case ffiError parsed of
1781 Just err -> jsError err
1782 Nothing -> JSRaw $ renderFFI parsed args
1783 where
1784 ffiParse :: String -> [FFI]
1785 ffiParse "" = []
1786 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1787 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1788 ffiParse ('%':s:ss)
1789 | isDigit s =
1790 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1791 | otherwise =
1792 [FFIError "Invalid positional argument"]
1793 ffiParse (s:ss) = FFICode s : ffiParse ss
1796 ffiError :: [FFI] -> Maybe String
1797 ffiError [] = Nothing
1798 ffiError ((FFIError s):xs) = Just s
1799 ffiError (x:xs) = ffiError xs
1802 renderFFI :: [FFI] -> [String] -> String
1803 renderFFI [] _ = ""
1804 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1805 renderFFI ((FFIArg i) : fs) args
1806 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1807 | otherwise = "Argument index out of bounds"
1810data CaseType = ConCase Int
1811 | TypeCase JSType
1812 | DefaultCase
1813 deriving Eq
1816data Cond = CaseCond CaseType
1817 | RawCond JS
1820translateCaseCond :: String -> SAlt -> (Cond, JS)
1821translateCaseCond _ cse@(SDefaultCase _) =
1822 (CaseCond DefaultCase, translateCase Nothing cse)
1824translateCaseCond var cse@(SConstCase ty _)
1825 | StrType <- ty = matchHelper JSStringTy
1826 | PtrType <- ty = matchHelper JSPtrTy
1827 | Forgot <- ty = matchHelper JSForgotTy
1828 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1829 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1830 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1831 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1832 where
1833 matchHelper :: JSType -> (Cond, JS)
1834 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1836translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1837 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1838 (RawCond cond, translateCase Nothing cse)
1840translateCaseCond var cse@(SConstCase cst _) =
1841 let cond = JSIdent var `jsEq` translateConstant cst in
1842 (RawCond cond, translateCase Nothing cse)
1844translateCaseCond var cse@(SConCase _ tag _ _ _) =
1845 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1848translateCase :: Maybe String -> SAlt -> JS
1849translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
1850translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
1851translateCase (Just var) (SConCase a _ _ vars e) =
1852 let params = map jsVar [a .. (a + length vars)] in
1853 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1854 JSThis, JSProj (JSIdent var) "vars"