git.iko.soy/Idris-dev
on 3e07c44 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1640 lines 52 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__"
27data JSTarget = Node | JavaScript deriving Eq
29data JSType = JSIntTy
30 | JSStringTy
31 | JSIntegerTy
32 | JSFloatTy
33 | JSCharTy
34 | JSPtrTy
35 | JSForgotTy
36 deriving Eq
38data JSInteger = JSBigZero
39 | JSBigOne
40 | JSBigInt Integer
41 deriving Eq
43data JSNum = JSInt Int
44 | JSFloat Double
45 | JSInteger JSInteger
46 deriving Eq
48data JS = JSRaw String
49 | JSIdent String
50 | JSFunction [String] JS
51 | JSType JSType
52 | JSSeq [JS]
53 | JSReturn JS
54 | JSApp JS [JS]
55 | JSNew String [JS]
56 | JSError String
57 | JSOp String JS JS
58 | JSProj JS String
59 | JSVar LVar
60 | JSNull
61 | JSThis
62 | JSTrue
63 | JSFalse
64 | JSArray [JS]
65 | JSObject [(String, JS)]
66 | JSString String
67 | JSChar String
68 | JSNum JSNum
69 | JSAssign JS JS
70 | JSAlloc String (Maybe JS)
71 | JSIndex JS JS
72 | JSCond [(JS, JS)]
73 | JSTernary JS JS JS
74 deriving Eq
76compileJS :: JS -> String
77compileJS (JSRaw code) =
78 code
80compileJS (JSIdent ident) =
81 ident
83compileJS (JSFunction args body) =
84 "function("
85 ++ intercalate "," args
86 ++ "){\n"
87 ++ compileJS body
88 ++ "\n}"
90compileJS (JSType ty)
91 | JSIntTy <- ty = idrRTNamespace ++ "Int"
92 | JSStringTy <- ty = idrRTNamespace ++ "String"
93 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
94 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
95 | JSCharTy <- ty = idrRTNamespace ++ "Char"
96 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
97 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
99compileJS (JSSeq seq) =
100 intercalate ";\n" (map compileJS seq)
102compileJS (JSReturn val) =
103 "return " ++ compileJS val
105compileJS (JSApp lhs rhs)
106 | JSFunction {} <- lhs =
107 concat ["(", compileJS lhs, ")(", args, ")"]
108 | otherwise =
109 concat [compileJS lhs, "(", args, ")"]
110 where args :: String
111 args = intercalate "," $ map compileJS rhs
113compileJS (JSNew name args) =
114 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
116compileJS (JSError exc) =
117 "(function(){throw '" ++ exc ++ "';})()"
119compileJS (JSOp op lhs rhs) =
120 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
122compileJS (JSProj obj field)
123 | JSFunction {} <- obj =
124 concat ["(", compileJS obj, ").", field]
125 | JSAssign {} <- obj =
126 concat ["(", compileJS obj, ").", field]
127 | otherwise =
128 compileJS obj ++ '.' : field
130compileJS (JSVar var) =
131 translateVariableName var
133compileJS JSNull =
134 "null"
136compileJS JSThis =
137 "this"
139compileJS JSTrue =
140 "true"
142compileJS JSFalse =
143 "false"
145compileJS (JSArray elems) =
146 "[" ++ intercalate "," (map compileJS elems) ++ "]"
148compileJS (JSObject fields) =
149 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
150 where
151 compileField :: (String, JS) -> String
152 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
154compileJS (JSString str) =
155 show str
157compileJS (JSChar chr) =
158 chr
160compileJS (JSNum num)
161 | JSInt i <- num = show i
162 | JSFloat f <- num = show f
163 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
164 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
165 | JSInteger (JSBigInt i) <- num = show i
167compileJS (JSAssign lhs rhs) =
168 compileJS lhs ++ "=" ++ compileJS rhs
170compileJS (JSAlloc name val) =
171 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
173compileJS (JSIndex lhs rhs) =
174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
176compileJS (JSCond branches) =
177 intercalate " else " $ map createIfBlock (eliminateDeadBranches branches)
178 where
179 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
180 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
181 eliminateDeadBranches [] = []
183 createIfBlock (JSTrue, e) =
184 "{\n"
185 ++ "return " ++ compileJS e
186 ++ ";\n}"
187 createIfBlock (cond, e) =
188 "if (" ++ compileJS cond ++") {\n"
189 ++ "return " ++ compileJS e
190 ++ ";\n}"
192compileJS (JSTernary cond true false) =
193 let c = compileJS cond
194 t = compileJS true
195 f = compileJS false in
196 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
198jsTailcall :: JS -> JS
199jsTailcall call =
200 jsCall (idrRTNamespace ++ "tailcall") [
201 JSFunction [] (JSReturn call)
202 ]
204jsCall :: String -> [JS] -> JS
205jsCall fun = JSApp (JSIdent fun)
207jsMeth :: JS -> String -> [JS] -> JS
208jsMeth obj meth =
209 JSApp (JSProj obj meth)
211jsInstanceOf :: JS -> JS -> JS
212jsInstanceOf = JSOp "instanceof"
214jsEq :: JS -> JS -> JS
215jsEq = JSOp "=="
217jsAnd :: JS -> JS -> JS
218jsAnd = JSOp "&&"
220jsType :: JS
221jsType = JSIdent $ idrRTNamespace ++ "Type"
223jsCon :: JS
224jsCon = JSIdent $ idrRTNamespace ++ "Con"
226jsTag :: JS -> JS
227jsTag obj = JSProj obj "tag"
229jsTypeTag :: JS -> JS
230jsTypeTag obj = JSProj obj "type"
232jsBigInt :: JS -> JS
233jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
234jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
235jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
237jsVar :: Int -> String
238jsVar = ("__var_" ++) . show
240jsLet :: String -> JS -> JS -> JS
241jsLet name value body =
242 JSApp (
243 JSFunction [name] (
244 JSReturn body
245 )
246 ) [value]
249jsSubst :: JS -> JS -> JS -> JS
250jsSubst var new old
251 | var == old = new
253jsSubst (JSIdent var) new (JSVar old)
254 | var == translateVariableName old = new
255 | otherwise = JSVar old
257jsSubst var new old@(JSIdent _)
258 | var == old = new
259 | otherwise = old
261jsSubst var new (JSArray fields) =
262 JSArray (map (jsSubst var new) fields)
264jsSubst var new (JSNew con vals) =
265 JSNew con $ map (jsSubst var new) vals
267jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
268 | var `notElem` args =
269 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
270 map (jsSubst (JSIdent var) new) vals
271 )
272 | otherwise =
273 JSApp (JSProj (JSFunction args body) "apply") (
274 map (jsSubst (JSIdent var) new) vals
275 )
277jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
278 | var /= arg =
279 JSApp (JSFunction [arg] (
280 jsSubst (JSIdent var) new body
281 )) $ map (jsSubst (JSIdent var) new) vals
282 | otherwise =
283 JSApp (JSFunction [arg] (
284 body
285 )) $ map (jsSubst (JSIdent var) new) vals
287jsSubst var new (JSApp lhs rhs) =
288 JSApp (jsSubst var new lhs) (map (jsSubst var new) rhs)
290jsSubst var new (JSFunction [] body) =
291 JSFunction [] (jsSubst var new body)
293jsSubst var new (JSReturn ret) =
294 JSReturn $ jsSubst var new ret
296jsSubst var new (JSProj obj field) =
297 JSProj (jsSubst var new obj) field
299jsSubst var new (JSSeq body) =
300 JSSeq $ map (jsSubst var new) body
302jsSubst var new (JSOp op lhs rhs) =
303 JSOp op (jsSubst var new lhs) (jsSubst var new rhs)
305jsSubst var new (JSIndex obj field) =
306 JSIndex (jsSubst var new obj) (jsSubst var new field)
308jsSubst var new (JSCond conds) =
309 JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)
311jsSubst var new (JSAssign lhs rhs) =
312 JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
314jsSubst var new (JSAlloc val (Just js)) =
315 JSAlloc val (Just (jsSubst var new js))
317jsSubst _ _ js = js
320removeAllocations :: JS -> JS
321removeAllocations (JSSeq body) =
322 let opt = removeHelper (map removeAllocations body) in
323 case opt of
324 [ret] -> ret
325 _ -> JSSeq opt
326 where
327 removeHelper :: [JS] -> [JS]
328 removeHelper [js] = [js]
329 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
330 map (jsSubst (JSIdent name) val) (removeHelper js)
331 removeHelper (j:js) = j : removeHelper js
333removeAllocations (JSFunction args body) =
334 JSFunction args $ removeAllocations body
336removeAllocations (JSReturn ret) =
337 JSReturn $ removeAllocations ret
339removeAllocations (JSApp fun args) =
340 JSApp (removeAllocations fun) (map removeAllocations args)
342removeAllocations (JSNew con args) =
343 JSNew con $ map removeAllocations args
345removeAllocations (JSOp op lhs rhs) =
346 JSOp op (removeAllocations lhs) (removeAllocations rhs)
348removeAllocations (JSProj obj field) =
349 JSProj (removeAllocations obj) field
351removeAllocations (JSArray vals) =
352 JSArray $ map removeAllocations vals
354removeAllocations (JSAssign lhs rhs) =
355 JSAssign (removeAllocations lhs) (removeAllocations rhs)
357removeAllocations (JSAlloc name (Just val)) =
358 JSAlloc name $ Just (removeAllocations val)
360removeAllocations (JSIndex val idx) =
361 JSIndex (removeAllocations val) (removeAllocations idx)
363removeAllocations (JSCond conds) =
364 JSCond $ map (removeAllocations *** removeAllocations) conds
366removeAllocations (JSTernary c t f) =
367 JSTernary (removeAllocations c) (removeAllocations t) (removeAllocations f)
369removeAllocations js = js
372isJSConstant :: JS -> Bool
373isJSConstant js
374 | JSString _ <- js = True
375 | JSChar _ <- js = True
376 | JSNum _ <- js = True
377 | JSType _ <- js = True
379 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
380 | otherwise = False
382inlineJS :: JS -> JS
383inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
384 inlineJS $ jsSubst (JSIdent "cse") val body
386inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
387 JSSeq [ JSAlloc arg (Just (inlineJS val))
388 , inlineJS cond
389 ]
391inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
392 JSThis,JSProj var "vars"
393 ])
394 | var /= JSIdent "cse" =
395 inlineApply args body 0
396 where
397 inlineApply [] body _ = inlineJS body
398 inlineApply (a:as) body n =
399 inlineApply as (
400 jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
401 ) (n + 1)
403inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
404 | isJSConstant val = val
406inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
407 JSFunction [] (JSReturn val)
408 ])
409 | isJSConstant val = val
411inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
412 | JSNew con [tag, vals] <- ret
413 , opt <- inlineJS val =
414 JSNew con [tag, jsSubst (JSIdent arg) opt vals]
416 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
417 , opt <- inlineJS val =
418 JSNew con [JSFunction [] (
419 JSReturn (
420 JSApp (
421 jsSubst (JSIdent arg) opt fun
422 ) (
423 map (jsSubst (JSIdent arg) opt) vars
424 )
425 )
426 )]
428 | JSApp (JSProj obj field) args <- ret
429 , opt <- inlineJS val =
430 JSApp (
431 JSProj (jsSubst (JSIdent arg) opt obj) field
432 ) (
433 map (jsSubst (JSIdent arg) opt) args
434 )
436 | JSIndex (JSProj obj field) idx <- ret
437 , opt <- inlineJS val =
438 JSIndex (JSProj (
439 jsSubst (JSIdent arg) opt obj
440 ) field
441 ) (jsSubst (JSIdent arg) opt idx)
443 | JSOp op lhs rhs <- ret
444 , opt <- inlineJS val =
445 JSOp op (jsSubst (JSIdent arg) opt lhs) $
446 (jsSubst (JSIdent arg) opt rhs)
448 | JSApp (JSIdent fun) args <- ret
449 , opt <- inlineJS val =
450 JSApp (JSIdent fun) $ map (jsSubst (JSIdent arg) opt) args
452inlineJS (JSApp fun args) =
453 JSApp (inlineJS fun) (map inlineJS args)
455inlineJS (JSNew con args) =
456 JSNew con $ map inlineJS args
458inlineJS (JSArray fields) =
459 JSArray (map inlineJS fields)
461inlineJS (JSAssign lhs rhs) =
462 JSAssign (inlineJS lhs) (inlineJS rhs)
464inlineJS (JSSeq seq) =
465 JSSeq (map inlineJS seq)
467inlineJS (JSFunction args body) =
468 JSFunction args (inlineJS body)
470inlineJS (JSProj (JSFunction args body) field) =
471 JSProj (JSFunction args (inlineJS body)) field
473inlineJS (JSReturn js) =
474 JSReturn $ inlineJS js
476inlineJS (JSAlloc name (Just js)) =
477 JSAlloc name (Just $ inlineJS js)
479inlineJS (JSCond cases) =
480 JSCond (map (second inlineJS) cases)
482inlineJS (JSObject fields) =
483 JSObject (map (second inlineJS) fields)
485inlineJS (JSOp op lhs rhs) =
486 JSOp op (inlineJS lhs) (inlineJS rhs)
488inlineJS js = js
490reduceJS :: [JS] -> [JS]
491reduceJS js = reduceLoop [] ([], js)
493funName :: JS -> String
494funName (JSAlloc fun _) = fun
496elimDeadLoop :: [JS] -> [JS]
497elimDeadLoop js
498 | ret <- deadEvalApplyCases js
499 , ret /= js = elimDeadLoop ret
500 | otherwise = js
502deadEvalApplyCases :: [JS] -> [JS]
503deadEvalApplyCases js =
504 let tags = sort $ nub $ concatMap (getTags) js in
505 map (removeHelper tags) js
506 where
507 getTags :: JS -> [Int]
508 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =
509 tag : getTags args
511 getTags (JSNew _ args) = concatMap getTags args
513 getTags (JSFunction _ body) = getTags body
515 getTags (JSReturn ret) = getTags ret
517 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
519 getTags (JSSeq seq) = concatMap getTags seq
521 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
523 getTags (JSProj obj _) = getTags obj
525 getTags (JSArray vals) = concatMap getTags vals
527 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
529 getTags (JSAlloc _ (Just val)) = getTags val
531 getTags (JSCond conds) =
532 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
534 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
536 getTags js = []
537 removeHelper :: [Int] -> JS -> JS
538 removeHelper tags (JSAlloc fun (Just (
539 JSApp (JSFunction [] (JSSeq seq)) []))
540 ) =
541 (JSAlloc fun (Just (
542 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
543 )
545 removeHelper _ js = js
547 remover :: [Int] -> [JS] -> [JS]
548 remover tags (
549 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
550 )
551 | tag `notElem` tags = remover tags js
553 remover tags (j:js) = j : remover tags js
554 remover _ [] = []
557initConstructors :: [JS] -> [JS]
558initConstructors js =
559 let tags = nub $ sort $ concat (map getTags js) in
560 map createConstant tags ++ replaceConstructors tags js
561 where
562 getTags :: JS -> [Int]
563 getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
565 getTags (JSNew _ args) = concatMap getTags args
567 getTags (JSFunction _ body) = getTags body
569 getTags (JSReturn ret) = getTags ret
571 getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
573 getTags (JSSeq seq) = concatMap getTags seq
575 getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
577 getTags (JSProj obj _) = getTags obj
579 getTags (JSArray vals) = concatMap getTags vals
581 getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
583 getTags (JSAlloc _ (Just val)) = getTags val
585 getTags (JSCond conds) =
586 concatMap (uncurry (++)) $ map (getTags *** getTags) conds
588 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
590 getTags js = []
592 replaceConstructors :: [Int] -> [JS] -> [JS]
593 replaceConstructors tags js = map (replaceHelper tags) js
594 where
595 replaceHelper :: [Int] -> JS -> JS
596 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
597 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
599 replaceHelper tags (JSNew con args) =
600 JSNew con $ map (replaceHelper tags) args
602 replaceHelper tags (JSFunction fun body) =
603 JSFunction fun (replaceHelper tags body)
605 replaceHelper tags (JSReturn ret) =
606 JSReturn (replaceHelper tags ret)
608 replaceHelper tags (JSApp lhs rhs) =
609 JSApp (replaceHelper tags lhs) (map (replaceHelper tags) rhs)
611 replaceHelper tags (JSSeq seq) =
612 JSSeq $ map (replaceHelper tags) seq
614 replaceHelper tags (JSOp op lhs rhs) =
615 JSOp op (replaceHelper tags lhs) (replaceHelper tags rhs)
617 replaceHelper tags (JSProj obj field) =
618 JSProj (replaceHelper tags obj) field
620 replaceHelper tags (JSArray vals) =
621 JSArray $ map (replaceHelper tags) vals
623 replaceHelper tags (JSAssign lhs rhs) =
624 JSAssign (replaceHelper tags lhs) (replaceHelper tags rhs)
626 replaceHelper tags (JSAlloc var (Just val)) =
627 JSAlloc var $ Just (replaceHelper tags val)
629 replaceHelper tags (JSCond conds) =
630 JSCond (map ((replaceHelper tags) *** (replaceHelper tags)) conds)
632 replaceHelper tags (JSTernary c t f) =
633 JSTernary (replaceHelper tags c) (
634 replaceHelper tags t
635 ) (
636 replaceHelper tags f
637 )
639 replaceHelper tags js = js
641 createConstant :: Int -> JS
642 createConstant tag =
643 JSAlloc ("__IDRCTR__" ++ show tag) (Just (
644 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
645 ))
647removeIDs :: [JS] -> [JS]
648removeIDs js =
649 case partition isID js of
650 ([], rest) -> rest
651 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
652 where isID :: JS -> Bool
653 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
654 | JSReturn (JSVar _) <- last body = True
656 isID _ = False
658 idFor :: JS -> (String, Int)
659 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
660 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
662 removeIDCall :: [(String, Int)] -> JS -> JS
663 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
664 JSReturn (JSApp (JSIdent fun) args)
665 )])
666 | Just pos <- lookup fun ids
667 , pos < length args = args !! pos
669 removeIDCall ids (JSNew _ [JSFunction [] (
670 JSReturn (JSApp (JSIdent fun) args)
671 )])
672 | Just pos <- lookup fun ids
673 , pos < length args = args !! pos
675 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
676 | Just pos <- lookup fun ids
677 , pos < length args = args !! pos
679 removeIDCall ids (JSAlloc fun (Just body)) =
680 JSAlloc fun (Just $ removeIDCall ids body)
682 removeIDCall ids (JSReturn js) =
683 JSReturn $ removeIDCall ids js
685 removeIDCall ids (JSSeq js) =
686 JSSeq $ map (removeIDCall ids) js
688 removeIDCall ids (JSNew con args) =
689 JSNew con $ map (removeIDCall ids) args
691 removeIDCall ids (JSFunction args body) =
692 JSFunction args $ removeIDCall ids body
694 removeIDCall ids (JSApp fun args) =
695 JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args
697 removeIDCall ids (JSProj obj field) =
698 JSProj (removeIDCall ids obj) field
700 removeIDCall ids (JSCond conds) =
701 JSCond $ map (removeIDCall ids *** removeIDCall ids) conds
703 removeIDCall ids (JSAssign lhs rhs) =
704 JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)
706 removeIDCall ids (JSArray fields) =
707 JSArray $ map (removeIDCall ids) fields
709 removeIDCall _ js = js
711inlineFunctions :: [JS] -> [JS]
712inlineFunctions js =
713 let funs = collectFunctions js
714 occurences = map ((id . fst) &&& countAll js) funs in
715 removeDeadFunctions occurences js
716 where
717 removeDeadFunctions :: [(String, (Int, JS))] -> [JS] -> [JS]
718 removeDeadFunctions _ [] = []
719 removeDeadFunctions funOccur ((JSAlloc fun (Just (JSFunction _ _))):js)
720 | Just (o, _) <- lookup fun funOccur
721 , o == 0 = removeDeadFunctions funOccur js
723 removeDeadFunctions funOccur (j:js) = j : removeDeadFunctions funOccur js
726 collectFunctions :: [JS] -> [(String, JS)]
727 collectFunctions js =
728 catMaybes $ map collectHelper js
731 collectHelper :: JS -> Maybe (String, JS)
732 collectHelper (JSAlloc fun (Just js@(JSFunction _ body)))
733 | fun /= "main" && nonRecur fun body = Just (fun, js)
734 collectHelper _ = Nothing
737 nonRecur :: String -> JS -> Bool
738 nonRecur name body = countInvokations name body == 0
741 countAll :: [JS] -> (String, JS) -> (Int, JS)
742 countAll js (name, fun) = (sum $ map (countInvokations name) js, fun)
745 countInvokations :: String -> JS -> Int
746 countInvokations name (JSApp (JSIdent ident) args)
747 | name == ident = 1 + (sum $ map (countInvokations name) args)
748 | otherwise = sum $ map (countInvokations name) args
750 countInvokations name (JSApp lhs rhs) =
751 countInvokations name lhs + (sum $ map (countInvokations name) rhs)
753 countInvokations name (JSFunction _ body) =
754 countInvokations name body
756 countInvokations name (JSSeq seq) =
757 sum $ map (countInvokations name) seq
759 countInvokations name (JSReturn ret) =
760 countInvokations name ret
762 countInvokations name (JSNew _ args) =
763 sum $ map (countInvokations name) args
765 countInvokations name (JSOp _ lhs rhs) =
766 countInvokations name lhs + countInvokations name rhs
768 countInvokations name (JSProj obj _) =
769 countInvokations name obj
771 countInvokations name (JSArray vals) =
772 sum $ map (countInvokations name) vals
774 countInvokations name (JSAssign _ rhs) =
775 countInvokations name rhs
777 countInvokations name (JSAlloc _ (Just js)) =
778 countInvokations name js
780 countInvokations name (JSIndex lhs rhs) =
781 countInvokations name lhs + countInvokations name rhs
783 countInvokations name (JSCond conds) =
784 sum $ map (uncurry (+)) (
785 map (countInvokations name *** countInvokations name) conds
786 )
788 countInvokations name (JSTernary c t f) =
789 sum $ [ countInvokations name c
790 , countInvokations name t
791 , countInvokations name f
792 ]
794 countInvokations _ _ = 0
797reduceConstant :: JS -> JS
798reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
799 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
800 )]) = JSNum num
802reduceConstant (JSReturn ret) =
803 JSReturn (reduceConstant ret)
805reduceConstant (JSApp fun args) =
806 JSApp (reduceConstant fun) (map reduceConstant args)
808reduceConstant (JSArray fields) =
809 JSArray (map reduceConstant fields)
811reduceConstant (JSAlloc name (Just val)) =
812 JSAlloc name $ Just (reduceConstant val)
814reduceConstant (JSNew con args) =
815 JSNew con (map reduceConstant args)
817reduceConstant (JSProj obj field) =
818 JSProj (reduceConstant obj) field
820reduceConstant (JSCond conds) =
821 JSCond $ map (reduceConstant *** reduceConstant) conds
823reduceConstant (JSSeq seq) =
824 JSSeq $ map reduceConstant seq
826reduceConstant (JSFunction args body) =
827 JSFunction args (reduceConstant body)
829reduceConstant js = js
831reduceConstants :: JS -> JS
832reduceConstants js
833 | ret <- reduceConstant js
834 , ret /= js = reduceConstants ret
835 | otherwise = js
838elimDuplicateEvals :: JS -> JS
839elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
840 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
841 where
842 elimHelper :: [JS] -> [JS]
843 elimHelper (j@(JSAlloc var (Just val)):js) =
844 j : map (jsSubst val (JSIdent var)) (elimHelper js)
845 elimHelper (j:js) =
846 j : elimHelper js
847 elimHelper [] = []
849elimDuplicateEvals js = js
851optimizeEvalTailcalls :: (String, String) -> JS -> JS
852optimizeEvalTailcalls (fun, tc) js =
853 optHelper js
854 where
855 optHelper :: JS -> JS
856 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
857 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
858 ])
859 | n == fun = JSApp (JSIdent tc) $ map optHelper args
861 optHelper (JSFunction args body) =
862 JSFunction args $ optHelper body
864 optHelper (JSSeq seq) =
865 JSSeq $ map optHelper seq
867 optHelper (JSReturn ret) =
868 JSReturn $ optHelper ret
870 optHelper (JSApp lhs rhs) =
871 JSApp (optHelper lhs) (map optHelper rhs)
873 optHelper (JSNew con args) =
874 JSNew con $ map optHelper args
876 optHelper (JSOp op lhs rhs) =
877 JSOp op (optHelper lhs) (optHelper rhs)
879 optHelper (JSProj obj field) =
880 JSProj (optHelper obj) field
882 optHelper (JSArray vals) =
883 JSArray $ map optHelper vals
885 optHelper (JSAssign lhs rhs) =
886 JSAssign (optHelper lhs) (optHelper rhs)
888 optHelper (JSAlloc var (Just val)) =
889 JSAlloc var (Just $ optHelper val)
891 optHelper (JSIndex lhs rhs) =
892 JSIndex (optHelper lhs) (optHelper rhs)
894 optHelper (JSCond conds) =
895 JSCond $ map (optHelper *** optHelper) conds
897 optHelper (JSTernary c t f) =
898 JSTernary (
899 optHelper c
900 ) (
901 optHelper t
902 ) (
903 optHelper f
904 )
906 optHelper js = js
909removeInstanceChecks :: JS -> JS
910removeInstanceChecks (JSCond conds) =
911 JSCond $ map (removeHelper *** removeInstanceChecks) conds
912 where
913 removeHelper (
914 JSOp "&&" (JSOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
915 ) = removeHelper check
916 removeHelper js = js
918removeInstanceChecks (JSFunction args body) =
919 JSFunction args $ removeInstanceChecks body
921removeInstanceChecks (JSSeq seq) =
922 JSSeq $ map removeInstanceChecks seq
924removeInstanceChecks (JSReturn ret) =
925 JSReturn $ removeInstanceChecks ret
927removeInstanceChecks (JSApp lhs rhs) =
928 JSApp (removeInstanceChecks lhs) $ map removeInstanceChecks rhs
930removeInstanceChecks (JSNew con args) =
931 JSNew con $ map removeInstanceChecks args
933removeInstanceChecks (JSOp op lhs rhs) =
934 JSOp op (removeInstanceChecks lhs) (removeInstanceChecks rhs)
936removeInstanceChecks (JSProj obj field) =
937 JSProj (removeInstanceChecks obj) field
939removeInstanceChecks (JSArray vals) =
940 JSArray $ map removeInstanceChecks vals
942removeInstanceChecks (JSAssign lhs rhs) =
943 JSAssign (removeInstanceChecks lhs) (removeInstanceChecks rhs)
945removeInstanceChecks (JSAlloc var (Just val)) =
946 JSAlloc var (Just $ removeInstanceChecks val)
948removeInstanceChecks (JSIndex lhs rhs) =
949 JSIndex (removeInstanceChecks lhs) (removeInstanceChecks rhs)
951removeInstanceChecks (JSTernary c t f) =
952 JSTernary (
953 removeInstanceChecks c
954 ) (
955 removeInstanceChecks t
956 ) (
957 removeInstanceChecks f
958 )
960removeInstanceChecks js = js
962reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
963reduceLoop reduced (cons, program) =
964 case partition findConstructors program of
965 ([], js) -> cons ++ js
966 (candidates, rest) ->
967 let names = reduced ++ map funName candidates in
968 reduceLoop names (
969 cons ++ map reduce candidates, map (reduceCall names) rest
970 )
971 where findConstructors :: JS -> Bool
972 findConstructors js
973 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
974 reducable $ last body
975 | otherwise = False
976 where reducable :: JS -> Bool
977 reducable (JSReturn js) = reducable js
978 reducable (JSNew _ args) = and $ map reducable args
979 reducable (JSArray fields) = and $ map reducable fields
980 reducable (JSNum _) = True
981 reducable JSNull = True
982 reducable (JSIdent _) = True
983 reducable _ = False
985 reduce :: JS -> JS
986 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
987 | JSReturn js <- last body = (JSAlloc fun (Just js))
989 reduce js = js
991 reduceCall :: [String] -> JS -> JS
992 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
993 JSReturn (JSApp id@(JSIdent ret) _)
994 )])
995 | ret `elem` funs = id
997 reduceCall funs js@(JSApp id@(JSIdent fun) _)
998 | fun `elem` funs = id
1000 reduceCall funs (JSAlloc fun (Just body)) =
1001 JSAlloc fun (Just $ reduceCall funs body)
1003 reduceCall funs (JSReturn js) =
1004 JSReturn $ reduceCall funs js
1006 reduceCall funs (JSSeq js) =
1007 JSSeq $ map (reduceCall funs) js
1009 reduceCall funs (JSNew con args) =
1010 JSNew con $ map (reduceCall funs) args
1012 reduceCall funs (JSFunction args body) =
1013 JSFunction args $ reduceCall funs body
1015 reduceCall funs (JSApp fun args) =
1016 JSApp (reduceCall funs fun) $ map (reduceCall funs) args
1018 reduceCall funs (JSProj obj field) =
1019 JSProj (reduceCall funs obj) field
1021 reduceCall funs (JSIndex obj idx) =
1022 JSIndex (reduceCall funs obj) (reduceCall funs idx)
1024 reduceCall funs (JSOp op rhs lhs) =
1025 JSOp op (reduceCall funs rhs) (reduceCall funs lhs)
1027 reduceCall funs (JSCond conds) =
1028 JSCond $ map (reduceCall funs *** reduceCall funs) conds
1030 reduceCall funs (JSAssign lhs rhs) =
1031 JSAssign (reduceCall funs lhs) (reduceCall funs rhs)
1033 reduceCall funs (JSArray fields) =
1034 JSArray $ map (reduceCall funs) fields
1036 reduceCall _ js = js
1038optimizeJS :: JS -> JS
1039optimizeJS = inlineLoop
1040 where inlineLoop :: JS -> JS
1041 inlineLoop js
1042 | opt <- inlineJS js
1043 , opt /= js = inlineLoop opt
1044 | otherwise = js
1046codegenJavaScript
1047 :: JSTarget
1048 -> [(Name, SDecl)]
1049 -> FilePath
1050 -> OutputType
1051 -> IO ()
1052codegenJavaScript target definitions filename outputType = do
1053 let (header, runtime) = case target of
1054 Node ->
1055 ("#!/usr/bin/env node\n", "-node")
1056 JavaScript ->
1057 ("", "-browser")
1058 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1059 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1060 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
1061 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1062 writeFile filename $ header ++ (
1063 intercalate "\n" $ [ jsbn
1064 , idrRuntime
1065 , tgtRuntime
1066 ] ++ functions
1069 setPermissions filename (emptyPermissions { readable = True
1070 , executable = target == Node
1071 , writable = True
1072 })
1073 where
1074 def :: [(String, SDecl)]
1075 def = map (first translateNamespace) definitions
1077 functions :: [String]
1078 functions =
1079 let translated =
1080 concatMap translateDeclaration def ++ [mainLoop, invokeLoop]
1082 optimized = map optimizeJS translated
1083 idsRemoved = removeIDs optimized
1084 reduced = reduceJS idsRemoved
1085 constRemoved = map reduceConstants reduced
1086 constrInit = initConstructors constRemoved
1087 removeAlloc = map removeAllocations constrInit
1088 deadElim = elimDeadLoop removeAlloc
1089 inlined = inlineFunctions deadElim
1090 elimDup = map elimDuplicateEvals inlined
1091 evalTC = map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC")) elimDup
1092 applyTC = map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC")) evalTC
1093 remChecks = map removeInstanceChecks applyTC
1094 js = remChecks in
1095 map compileJS js
1097 mainLoop :: JS
1098 mainLoop =
1099 JSAlloc "main" $ Just $ JSFunction [] (
1100 case target of
1101 Node -> mainFun
1102 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
1103 JSString "DOMContentLoaded", JSFunction [] (
1104 mainFun
1105 ), JSFalse
1108 where
1109 mainFun :: JS
1110 mainFun = jsTailcall $ jsCall runMain []
1112 runMain :: String
1113 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1115 invokeLoop :: JS
1116 invokeLoop = jsCall "main" []
1118translateIdentifier :: String -> String
1119translateIdentifier =
1120 replaceReserved . concatMap replaceBadChars
1121 where replaceBadChars :: Char -> String
1122 replaceBadChars c
1123 | ' ' <- c = "_"
1124 | '_' <- c = "__"
1125 | isDigit c = '_' : show (ord c)
1126 | not (isLetter c && isAscii c) = '_' : show (ord c)
1127 | otherwise = [c]
1128 replaceReserved s
1129 | s `elem` reserved = '_' : s
1130 | otherwise = s
1131 reserved = [ "break"
1132 , "case"
1133 , "catch"
1134 , "continue"
1135 , "debugger"
1136 , "default"
1137 , "delete"
1138 , "do"
1139 , "else"
1140 , "finally"
1141 , "for"
1142 , "function"
1143 , "if"
1144 , "in"
1145 , "instanceof"
1146 , "new"
1147 , "return"
1148 , "switch"
1149 , "this"
1150 , "throw"
1151 , "try"
1152 , "typeof"
1153 , "var"
1154 , "void"
1155 , "while"
1156 , "with"
1158 , "class"
1159 , "enum"
1160 , "export"
1161 , "extends"
1162 , "import"
1163 , "super"
1165 , "implements"
1166 , "interface"
1167 , "let"
1168 , "package"
1169 , "private"
1170 , "protected"
1171 , "public"
1172 , "static"
1173 , "yield"
1176translateNamespace :: Name -> String
1177translateNamespace (UN _) = idrNamespace
1178translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1179translateNamespace (MN _ _) = idrNamespace
1180translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1181translateNamespace NErased = idrNamespace
1183translateName :: Name -> String
1184translateName (UN name) = 'u' : translateIdentifier (str name)
1185translateName (NS name _) = 'n' : translateName name
1186translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1187translateName (SN name) = 's' : translateSpecialName name
1188translateName NErased = "e"
1190translateSpecialName :: SpecialName -> String
1191translateSpecialName name
1192 | WhereN i m n <- name =
1193 'w' : translateName m ++ translateName n ++ show i
1194 | InstanceN n s <- name =
1195 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1196 | ParentN n s <- name =
1197 'p' : translateName n ++ translateIdentifier (str s)
1198 | MethodN n <- name =
1199 'm' : translateName n
1200 | CaseN n <- name =
1201 'c' : translateName n
1203translateConstant :: Const -> JS
1204translateConstant (I i) = JSNum (JSInt i)
1205translateConstant (Fl f) = JSNum (JSFloat f)
1206translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1207translateConstant (Ch '\a') = JSChar "'\\u0007'"
1208translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1209translateConstant (Ch c) = JSString [c]
1210translateConstant (Str s) = JSString s
1211translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1212translateConstant StrType = JSType JSStringTy
1213translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1214translateConstant (AType ATFloat) = JSType JSFloatTy
1215translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1216translateConstant PtrType = JSType JSPtrTy
1217translateConstant Forgot = JSType JSForgotTy
1218translateConstant (BI i) = jsBigInt $ JSString (show i)
1219translateConstant c =
1220 JSError $ "Unimplemented Constant: " ++ show c
1222translateDeclaration :: (String, SDecl) -> [JS]
1223translateDeclaration (path, SFun name params stackSize body)
1224 | (MN _ ap) <- name
1225 , (SLet var val next) <- body
1226 , (SChkCase cvar cases) <- next
1227 , ap == txt "APPLY" =
1228 let lvar = translateVariableName var
1229 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
1230 [ lookupTable [(var, "chk")] var cases
1231 , jsDecl $ JSFunction ["fn0", "arg0"] (
1232 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1233 , JSAlloc (translateVariableName var) (
1234 Just $ translateExpression val
1236 , JSReturn $ (JSTernary (
1237 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1238 (hasProp lookupTableName (translateVariableName var))
1239 ) (JSIdent $
1240 lookupTableName ++ lookup
1241 ) JSNull
1247 | (MN _ ev) <- name
1248 , (SChkCase var cases) <- body
1249 , ev == txt "EVAL" =
1250 [ lookupTable [] var cases
1251 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1252 JSTernary (
1253 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1254 (hasProp lookupTableName "arg0")
1255 ) (JSApp
1256 (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1257 [JSIdent "arg0"]
1258 ) (JSIdent "arg0")
1261 | otherwise =
1262 let fun = translateExpression body in
1263 [jsDecl $ jsFun fun]
1265 where
1266 hasProp :: String -> String -> JS
1267 hasProp table var =
1268 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1270 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1271 caseFun aux var cse =
1272 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
1274 getTag :: SAlt -> Maybe Int
1275 getTag (SConCase _ tag _ _ _) = Just tag
1276 getTag _ = Nothing
1278 lookupTableName :: String
1279 lookupTableName = idrLTNamespace ++ translateName name
1281 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
1282 lookupTable aux var cases =
1283 JSAlloc lookupTableName $ Just (
1284 JSApp (JSFunction [] (
1285 JSSeq $ [
1286 JSAlloc "t" $ Just (JSArray [])
1287 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1288 JSReturn (JSIdent "t")
1290 )) []
1292 where
1293 assignEntries :: [(Int, JS)] -> [JS]
1294 assignEntries entries =
1295 map (\(tag, fun) ->
1296 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1297 ) entries
1299 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1300 lookupEntry aux var alt = do
1301 tag <- getTag alt
1302 return (tag, caseFun aux var alt)
1304 jsDecl :: JS -> JS
1305 jsDecl = JSAlloc (path ++ translateName name) . Just
1307 jsFun body = jsFunAux [] body
1309 jsFunAux :: [(LVar, String)] -> JS -> JS
1310 jsFunAux aux body =
1311 JSFunction (p ++ map snd aux) (
1312 JSSeq $
1313 zipWith assignVar [0..] p ++
1314 map assignAux aux ++
1315 [JSReturn body]
1317 where
1318 assignVar :: Int -> String -> JS
1319 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1321 assignAux :: (LVar, String) -> JS
1322 assignAux (Loc var, val) =
1323 JSAlloc (jsVar var) (Just $ JSIdent val)
1325 p :: [String]
1326 p = map translateName params
1328translateVariableName :: LVar -> String
1329translateVariableName (Loc i) =
1330 jsVar i
1332translateExpression :: SExp -> JS
1333translateExpression (SLet name value body) =
1334 jsLet (translateVariableName name) (
1335 translateExpression value
1336 ) (translateExpression body)
1338translateExpression (SConst cst) =
1339 translateConstant cst
1341translateExpression (SV var) =
1342 JSVar var
1344translateExpression (SApp tc name vars)
1345 | False <- tc =
1346 jsTailcall $ translateFunctionCall name vars
1347 | True <- tc =
1348 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1349 JSReturn $ translateFunctionCall name vars
1350 )]
1351 where
1352 translateFunctionCall name vars =
1353 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1355translateExpression (SOp op vars)
1356 | LNoOp <- op = JSVar (last vars)
1358 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1359 | (LPlus (ATInt ITBig)) <- op
1360 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1361 | (LMinus (ATInt ITBig)) <- op
1362 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1363 | (LTimes (ATInt ITBig)) <- op
1364 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1365 | (LSDiv (ATInt ITBig)) <- op
1366 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1367 | (LSRem (ATInt ITBig)) <- op
1368 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1369 | (LEq (ATInt ITBig)) <- op
1370 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1371 | (LSLt (ATInt ITBig)) <- op
1372 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1373 | (LSLe (ATInt ITBig)) <- op
1374 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1375 | (LSGt (ATInt ITBig)) <- op
1376 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1377 | (LSGe (ATInt ITBig)) <- op
1378 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1380 | (LPlus ATFloat) <- op
1381 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1382 | (LMinus ATFloat) <- op
1383 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1384 | (LTimes ATFloat) <- op
1385 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1386 | (LSDiv ATFloat) <- op
1387 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1388 | (LEq ATFloat) <- op
1389 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1390 | (LSLt ATFloat) <- op
1391 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1392 | (LSLe ATFloat) <- op
1393 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1394 | (LSGt ATFloat) <- op
1395 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1396 | (LSGe ATFloat) <- op
1397 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1399 | (LPlus _) <- op
1400 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1401 | (LMinus _) <- op
1402 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1403 | (LTimes _) <- op
1404 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1405 | (LSDiv _) <- op
1406 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1407 | (LSRem _) <- op
1408 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1409 | (LEq _) <- op
1410 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1411 | (LSLt _) <- op
1412 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1413 | (LSLe _) <- op
1414 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1415 | (LSGt _) <- op
1416 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1417 | (LSGe _) <- op
1418 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1419 | (LAnd _) <- op
1420 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1421 | (LOr _) <- op
1422 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1423 | (LXOr _) <- op
1424 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1425 | (LSHL _) <- op
1426 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1427 | (LASHR _) <- op
1428 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1429 | (LCompl _) <- op
1430 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
1432 | LStrConcat <- op
1433 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1434 | LStrEq <- op
1435 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1436 | LStrLt <- op
1437 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1438 | LStrLen <- op
1439 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1441 | (LStrInt ITNative) <- op
1442 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1443 | (LIntStr ITNative) <- op
1444 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1445 | (LSExt ITNative ITBig) <- op
1446 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1447 | (LTrunc ITBig ITNative) <- op
1448 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1449 | (LIntStr ITBig) <- op
1450 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1451 | (LStrInt ITBig) <- op
1452 , (arg:_) <- vars = jsBigInt $ JSVar arg
1453 | LFloatStr <- op
1454 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1455 | LStrFloat <- op
1456 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1457 | (LIntFloat ITNative) <- op
1458 , (arg:_) <- vars = JSVar arg
1459 | (LFloatInt ITNative) <- op
1460 , (arg:_) <- vars = JSVar arg
1461 | (LChInt ITNative) <- op
1462 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1463 | (LIntCh ITNative) <- op
1464 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1466 | LFExp <- op
1467 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1468 | LFLog <- op
1469 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1470 | LFSin <- op
1471 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1472 | LFCos <- op
1473 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1474 | LFTan <- op
1475 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1476 | LFASin <- op
1477 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1478 | LFACos <- op
1479 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1480 | LFATan <- op
1481 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1482 | LFSqrt <- op
1483 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1484 | LFFloor <- op
1485 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1486 | LFCeil <- op
1487 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1489 | LStrCons <- op
1490 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1491 | LStrHead <- op
1492 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1493 | LStrRev <- op
1494 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1495 | LStrIndex <- op
1496 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1497 | LStrTail <- op
1498 , (arg:_) <- vars = let v = translateVariableName arg in
1499 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1500 | LNullPtr <- op
1501 , (_) <- vars = JSNull
1503 where
1504 translateBinaryOp :: String -> LVar -> LVar -> JS
1505 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1507 invokeMeth :: LVar -> String -> [LVar] -> JS
1508 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1510translateExpression (SError msg) =
1511 JSError msg
1513translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1514 jsCall (idrRTNamespace ++ "print") [JSVar var]
1516translateExpression (SForeign _ _ fun args) =
1517 ffi fun (map generateWrapper args)
1518 where
1519 generateWrapper (ffunc, name)
1520 | FFunction <- ffunc =
1521 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1522 | FFunctionIO <- ffunc =
1523 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1525 generateWrapper (_, name) =
1526 translateVariableName name
1528translateExpression patterncase
1529 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1530 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1531 where
1532 caseHelper var cases param =
1533 JSApp (JSFunction [param] (
1534 JSCond $ map (expandCase param . translateCaseCond param) cases
1535 )) [JSVar var]
1537 expandCase :: String -> (Cond, JS) -> (JS, JS)
1538 expandCase _ (RawCond cond, branch) = (cond, branch)
1539 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1540 expandCase var (CaseCond caseTy, branch)
1541 | ConCase tag <- caseTy =
1542 let checkCon = JSIdent var `jsInstanceOf` jsCon
1543 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1544 (checkCon `jsAnd` checkTag, branch)
1546 | TypeCase ty <- caseTy =
1547 let checkTy = JSIdent var `jsInstanceOf` jsType
1548 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1549 (checkTy `jsAnd` checkTag, branch)
1551translateExpression (SCon i name vars) =
1552 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1553 , JSArray $ map JSVar vars
1556translateExpression (SUpdate var@(Loc i) e) =
1557 JSAssign (JSVar var) (translateExpression e)
1559translateExpression (SProj var i) =
1560 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1562translateExpression SNothing = JSNull
1564translateExpression e =
1565 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1567data FFI = FFICode Char | FFIArg Int | FFIError String
1569ffi :: String -> [String] -> JS
1570ffi code args = let parsed = ffiParse code in
1571 case ffiError parsed of
1572 Just err -> JSError err
1573 Nothing -> JSRaw $ renderFFI parsed args
1574 where
1575 ffiParse :: String -> [FFI]
1576 ffiParse "" = []
1577 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1578 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1579 ffiParse ('%':s:ss)
1580 | isDigit s =
1581 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1582 | otherwise =
1583 [FFIError "Invalid positional argument"]
1584 ffiParse (s:ss) = FFICode s : ffiParse ss
1586 ffiError :: [FFI] -> Maybe String
1587 ffiError [] = Nothing
1588 ffiError ((FFIError s):xs) = Just s
1589 ffiError (x:xs) = ffiError xs
1591 renderFFI :: [FFI] -> [String] -> String
1592 renderFFI [] _ = ""
1593 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1594 renderFFI ((FFIArg i) : fs) args
1595 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1596 | otherwise = "Argument index out of bounds"
1598data CaseType = ConCase Int
1599 | TypeCase JSType
1600 | DefaultCase
1601 deriving Eq
1603data Cond = CaseCond CaseType
1604 | RawCond JS
1606translateCaseCond :: String -> SAlt -> (Cond, JS)
1607translateCaseCond _ cse@(SDefaultCase _) =
1608 (CaseCond DefaultCase, translateCase Nothing cse)
1610translateCaseCond var cse@(SConstCase ty _)
1611 | StrType <- ty = matchHelper JSStringTy
1612 | PtrType <- ty = matchHelper JSPtrTy
1613 | Forgot <- ty = matchHelper JSForgotTy
1614 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1615 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1616 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1617 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1618 where
1619 matchHelper :: JSType -> (Cond, JS)
1620 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1622translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1623 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1624 (RawCond cond, translateCase Nothing cse)
1626translateCaseCond var cse@(SConstCase cst _) =
1627 let cond = JSIdent var `jsEq` translateConstant cst in
1628 (RawCond cond, translateCase Nothing cse)
1630translateCaseCond var cse@(SConCase _ tag _ _ _) =
1631 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1633translateCase :: Maybe String -> SAlt -> JS
1634translateCase _ (SDefaultCase e) = translateExpression e
1635translateCase _ (SConstCase _ e) = translateExpression e
1636translateCase (Just var) (SConCase a _ _ vars e) =
1637 let params = map jsVar [a .. (a + length vars)] in
1638 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1639 JSThis, JSProj (JSIdent var) "vars"