git.iko.soy/Idris-dev
on ad178cf help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
1816 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 deriving Eq
86compileJS :: JS -> String
87compileJS (JSRaw code) =
88 code
90compileJS (JSIdent ident) =
91 ident
93compileJS (JSFunction args body) =
94 "function("
95 ++ intercalate "," args
96 ++ "){\n"
97 ++ compileJS body
98 ++ "\n}"
100compileJS (JSType ty)
101 | JSIntTy <- ty = idrRTNamespace ++ "Int"
102 | JSStringTy <- ty = idrRTNamespace ++ "String"
103 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
104 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
105 | JSCharTy <- ty = idrRTNamespace ++ "Char"
106 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
107 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
109compileJS (JSSeq seq) =
110 intercalate ";\n" (map compileJS seq)
112compileJS (JSReturn val) =
113 "return " ++ compileJS val
115compileJS (JSApp lhs rhs)
116 | JSFunction {} <- lhs =
117 concat ["(", compileJS lhs, ")(", args, ")"]
118 | otherwise =
119 concat [compileJS lhs, "(", args, ")"]
120 where args :: String
121 args = intercalate "," $ map compileJS rhs
123compileJS (JSNew name args) =
124 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
126compileJS (JSError exc) =
127 "throw new Error(\"" ++ exc ++ "\")"
129compileJS (JSBinOp op lhs rhs) =
130 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
132compileJS (JSProj obj field)
133 | JSFunction {} <- obj =
134 concat ["(", compileJS obj, ").", field]
135 | JSAssign {} <- obj =
136 concat ["(", compileJS obj, ").", field]
137 | otherwise =
138 compileJS obj ++ '.' : field
140compileJS (JSVar var) =
141 translateVariableName var
143compileJS JSNull =
144 "null"
146compileJS JSThis =
147 "this"
149compileJS JSTrue =
150 "true"
152compileJS JSFalse =
153 "false"
155compileJS (JSArray elems) =
156 "[" ++ intercalate "," (map compileJS elems) ++ "]"
158compileJS (JSString str) =
159 show str
161compileJS (JSChar chr) =
162 chr
164compileJS (JSNum num)
165 | JSInt i <- num = show i
166 | JSFloat f <- num = show f
167 | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
168 | JSInteger JSBigOne <- num = "__IDRRT__ONE"
169 | JSInteger (JSBigInt i) <- num = show i
171compileJS (JSAssign lhs rhs) =
172 compileJS lhs ++ "=" ++ compileJS rhs
174compileJS (JSAlloc name val) =
175 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
177compileJS (JSIndex lhs rhs) =
178 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
180compileJS (JSCond branches) =
181 intercalate " else " $ map createIfBlock branches
182 where
183 createIfBlock (JSTrue, e) =
184 "{\n"
185 ++ compileJS e
186 ++ ";\n}"
187 createIfBlock (cond, e) =
188 "if (" ++ compileJS cond ++") {\n"
189 ++ 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 ++ ")"
198compileJS (JSParens js) =
199 "(" ++ compileJS js ++ ")"
201compileJS (JSWhile cond body) =
202 "while (" ++ compileJS cond ++ ") {\n"
203 ++ compileJS body
204 ++ "\n}"
206jsTailcall :: JS -> JS
207jsTailcall call =
208 jsCall (idrRTNamespace ++ "tailcall") [
209 JSFunction [] (JSReturn call)
210 ]
213jsCall :: String -> [JS] -> JS
214jsCall fun = JSApp (JSIdent fun)
217jsMeth :: JS -> String -> [JS] -> JS
218jsMeth obj meth =
219 JSApp (JSProj obj meth)
222jsInstanceOf :: JS -> JS -> JS
223jsInstanceOf = JSBinOp "instanceof"
226jsEq :: JS -> JS -> JS
227jsEq = JSBinOp "=="
230jsAnd :: JS -> JS -> JS
231jsAnd = JSBinOp "&&"
234jsType :: JS
235jsType = JSIdent $ idrRTNamespace ++ "Type"
238jsCon :: JS
239jsCon = JSIdent $ idrRTNamespace ++ "Con"
242jsTag :: JS -> JS
243jsTag obj = JSProj obj "tag"
246jsTypeTag :: JS -> JS
247jsTypeTag obj = JSProj obj "type"
250jsBigInt :: JS -> JS
251jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
252jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
253jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
256jsVar :: Int -> String
257jsVar = ("__var_" ++) . show
260jsLet :: String -> JS -> JS -> JS
261jsLet name value body =
262 JSApp (
263 JSFunction [name] (
264 JSReturn body
265 )
266 ) [value]
269jsError :: String -> JS
270jsError err = JSApp (JSFunction [] (JSError err)) []
273foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
274foldJS tr add acc js =
275 fold js
276 where
277 fold js
278 | JSFunction args body <- js =
279 add (tr js) (fold body)
280 | JSSeq seq <- js =
281 add (tr js) $ foldl' add acc (map fold seq)
282 | JSReturn ret <- js =
283 add (tr js) (fold ret)
284 | JSApp lhs rhs <- js =
285 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
286 | JSNew _ args <- js =
287 add (tr js) $ foldl' add acc $ map fold args
288 | JSBinOp _ lhs rhs <- js =
289 add (tr js) $ add (fold lhs) (fold rhs)
290 | JSPreOp _ val <- js =
291 add (tr js) $ fold val
292 | JSPostOp _ val <- js =
293 add (tr js) $ fold val
294 | JSProj obj _ <- js =
295 add (tr js) (fold obj)
296 | JSArray vals <- js =
297 add (tr js) $ foldl' add acc $ map fold vals
298 | JSAssign lhs rhs <- js =
299 add (tr js) $ add (fold lhs) (fold rhs)
300 | JSIndex lhs rhs <- js =
301 add (tr js) $ add (fold lhs) (fold rhs)
302 | JSAlloc _ val <- js =
303 add (tr js) $ fromMaybe acc $ fmap fold val
304 | JSTernary c t f <- js =
305 add (tr js) $ add (fold c) (add (fold t) (fold f))
306 | JSParens val <- js =
307 add (tr js) $ fold val
308 | JSCond conds <- js =
309 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
310 | JSWhile cond body <- js =
311 add (tr js) $ add (fold cond) (fold body)
312 | otherwise =
313 tr js
316transformJS :: (JS -> JS) -> JS -> JS
317transformJS tr js =
318 transformHelper js
319 where
320 transformHelper :: JS -> JS
321 transformHelper js
322 | JSFunction args body <- js = JSFunction args $ tr body
323 | JSSeq seq <- js = JSSeq $ map tr seq
324 | JSReturn ret <- js = JSReturn $ tr ret
325 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
326 | JSNew con args <- js = JSNew con $ map tr args
327 | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
328 | JSPreOp op val <- js = JSPreOp op (tr val)
329 | JSPostOp op val <- js = JSPostOp op (tr val)
330 | JSProj obj field <- js = JSProj (tr obj) field
331 | JSArray vals <- js = JSArray $ map tr vals
332 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
333 | JSAlloc var val <- js = JSAlloc var $ fmap tr val
334 | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
335 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
336 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
337 | JSParens val <- js = JSParens $ tr val
338 | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
339 | otherwise = js
342moveJSDeclToTop :: String -> [JS] -> [JS]
343moveJSDeclToTop decl js = move ([], js)
344 where
345 move :: ([JS], [JS]) -> [JS]
346 move (front, js@(JSAlloc name _):back)
347 | name == decl = js : front ++ back
349 move (front, js:back) =
350 move (front ++ [js], back)
353jsSubst :: JS -> JS -> JS -> JS
354jsSubst var new old
355 | var == old = new
357jsSubst (JSIdent var) new (JSVar old)
358 | var == translateVariableName old = new
359 | otherwise = JSVar old
361jsSubst var new old@(JSIdent _)
362 | var == old = new
363 | otherwise = old
365jsSubst var new (JSArray fields) =
366 JSArray (map (jsSubst var new) fields)
368jsSubst var new (JSNew con vals) =
369 JSNew con $ map (jsSubst var new) vals
371jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
372 | var `notElem` args =
373 JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
374 map (jsSubst (JSIdent var) new) vals
375 )
376 | otherwise =
377 JSApp (JSProj (JSFunction args body) "apply") (
378 map (jsSubst (JSIdent var) new) vals
379 )
381jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
382 | var /= arg =
383 JSApp (JSFunction [arg] (
384 jsSubst (JSIdent var) new body
385 )) $ map (jsSubst (JSIdent var) new) vals
386 | otherwise =
387 JSApp (JSFunction [arg] (
388 body
389 )) $ map (jsSubst (JSIdent var) new) vals
391jsSubst var new js = transformJS (jsSubst var new) js
394removeAllocations :: JS -> JS
395removeAllocations (JSSeq body) =
396 let opt = removeHelper (map removeAllocations body) in
397 case opt of
398 [ret] -> ret
399 _ -> JSSeq opt
400 where
401 removeHelper :: [JS] -> [JS]
402 removeHelper [js] = [js]
403 removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
404 map (jsSubst (JSIdent name) val) (removeHelper js)
405 removeHelper (j:js) = j : removeHelper js
407removeAllocations js = transformJS removeAllocations js
410isJSConstant :: JS -> Bool
411isJSConstant js
412 | JSString _ <- js = True
413 | JSChar _ <- js = True
414 | JSNum _ <- js = True
415 | JSType _ <- js = True
416 | JSNull <- js = True
417 | JSArray vals <- js = all isJSConstant vals
419 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
421 | otherwise = False
423isJSConstantConstructor :: [String] -> JS -> Bool
424isJSConstantConstructor constants js
425 | isJSConstant js =
426 True
427 | JSArray vals <- js =
428 all (isJSConstantConstructor constants) vals
429 | JSNew "__IDRRT__Con" args <- js =
430 all (isJSConstantConstructor constants) args
431 | JSIndex (JSProj (JSIdent _) "vars") (JSNum _) <- js =
432 True
433 | JSIdent name <- js
434 , name `elem` constants =
435 True
436 | otherwise = False
439inlineJS :: JS -> JS
440inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
441inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
442 inlineJS $ jsSubst (JSIdent "cse") val body
445inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
446 inlineJS $ JSSeq [ JSAlloc arg (Just val)
447 , cond
448 ]
450inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
451 JSThis,JSProj var "vars"
452 ])
453 | var /= JSIdent "cse" =
454 inlineJS $ inlineApply args body 0
455 where
456 inlineApply [] body _ = inlineJS body
457 inlineApply (a:as) body n =
458 inlineApply as (
459 jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
460 ) (n + 1)
462inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
463 | isJSConstant val = val
465inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
466 JSFunction [] (JSReturn val)
467 ])
468 | isJSConstant val = val
470inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
471 | JSNew con [tag, vals] <- ret
472 , opt <- inlineJS val =
473 inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
475 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
476 , opt <- inlineJS val =
477 inlineJS $ JSNew con [JSFunction [] (
478 JSReturn (
479 JSApp (
480 inlineJS $ jsSubst (JSIdent arg) opt fun
481 ) (
482 map (inlineJS . jsSubst (JSIdent arg) opt) vars
483 )
484 )
485 )]
487 | JSApp (JSProj obj field) args <- ret
488 , opt <- inlineJS val =
489 inlineJS $ JSApp (
490 inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
491 ) (
492 map (inlineJS . jsSubst (JSIdent arg) opt) args
493 )
495 | JSIndex (JSProj obj field) idx <- ret
496 , opt <- inlineJS val =
497 inlineJS $ JSIndex (JSProj (
498 inlineJS $ jsSubst (JSIdent arg) opt obj
499 ) field
500 ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
502 | JSBinOp op lhs rhs <- ret
503 , opt <- inlineJS val =
504 inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
505 (inlineJS $ jsSubst (JSIdent arg) opt rhs)
507 | JSApp (JSIdent fun) args <- ret
508 , opt <- inlineJS val =
509 inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
511inlineJS js = transformJS inlineJS js
514reduceJS :: [JS] -> [JS]
515reduceJS js = reduceLoop [] ([], js)
518funName :: JS -> String
519funName (JSAlloc fun _) = fun
522elimDeadLoop :: [JS] -> [JS]
523elimDeadLoop js
524 | ret <- deadEvalApplyCases js
525 , ret /= js = elimDeadLoop ret
526 | otherwise = js
529deadEvalApplyCases :: [JS] -> [JS]
530deadEvalApplyCases js =
531 let tags = sort $ nub $ concatMap (getTags) js in
532 map (removeHelper tags) js
533 where
534 getTags :: JS -> [Int]
535 getTags = foldJS match (++) []
536 where
537 match js
538 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
539 | otherwise = []
542 removeHelper :: [Int] -> JS -> JS
543 removeHelper tags (JSAlloc fun (Just (
544 JSApp (JSFunction [] (JSSeq seq)) []))
545 ) =
546 (JSAlloc fun (Just (
547 JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
548 )
550 removeHelper _ js = js
553 remover :: [Int] -> [JS] -> [JS]
554 remover tags (
555 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
556 )
557 | tag `notElem` tags = remover tags js
559 remover tags (j:js) = j : remover tags js
560 remover _ [] = []
563initConstructors :: [JS] -> [JS]
564initConstructors js =
565 let tags = nub $ sort $ concat (map getTags js) in
566 rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
567 where
568 rearrangePrelude :: [JS] -> [JS]
569 rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
572 getTags :: JS -> [Int]
573 getTags = foldJS match (++) []
574 where
575 match js
576 | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
577 | otherwise = []
580 replaceConstructors :: [Int] -> [JS] -> [JS]
581 replaceConstructors tags js = map (replaceHelper tags) js
582 where
583 replaceHelper :: [Int] -> JS -> JS
584 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
585 | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
587 replaceHelper tags js = transformJS (replaceHelper tags) js
590 createConstant :: Int -> JS
591 createConstant tag =
592 JSAlloc (idrCTRNamespace ++ show tag) (Just (
593 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
594 ))
597removeIDs :: [JS] -> [JS]
598removeIDs js =
599 case partition isID js of
600 ([], rest) -> rest
601 (ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
602 where isID :: JS -> Bool
603 isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
604 | JSReturn (JSVar _) <- last body = True
606 isID _ = False
609 idFor :: JS -> (String, Int)
610 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
611 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
614 removeIDCall :: [(String, Int)] -> JS -> JS
615 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
616 JSReturn (JSApp (JSIdent fun) args)
617 )])
618 | Just pos <- lookup fun ids
619 , pos < length args = args !! pos
621 removeIDCall ids (JSNew _ [JSFunction [] (
622 JSReturn (JSApp (JSIdent fun) args)
623 )])
624 | Just pos <- lookup fun ids
625 , pos < length args = args !! pos
627 removeIDCall ids js@(JSApp id@(JSIdent fun) args)
628 | Just pos <- lookup fun ids
629 , pos < length args = args !! pos
631 removeIDCall ids js = transformJS (removeIDCall ids) js
634inlineFunctions :: [JS] -> [JS]
635inlineFunctions js =
636 inlineHelper ([], js)
637 where
638 inlineHelper :: ([JS], [JS]) -> [JS]
639 inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
640 | countAll fun front + countAll fun back == 0 =
641 inlineHelper (front, back)
642 | Just new <- inlineAble (
643 countAll fun front + countAll fun back
644 ) fun args body =
645 let f = map (inline fun args new) in
646 inlineHelper (f front, f back)
648 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
649 inlineHelper (front, []) = front
652 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
653 inlineAble 1 fun args (JSReturn body)
654 | nonRecur fun body =
655 if all (<= 1) (map ($ body) (map countIDOccurences args))
656 then Just body
657 else Nothing
659 inlineAble _ _ _ _ = Nothing
662 inline :: String -> [String] -> JS -> JS -> JS
663 inline fun args body js = inline' js
664 where
665 inline' :: JS -> JS
666 inline' (JSApp (JSIdent name) vals)
667 | name == fun =
668 let (js, phs) = insertPlaceHolders args body in
669 inline' $ foldr (uncurry jsSubst) js (zip phs vals)
671 inline' js = transformJS inline' js
673 insertPlaceHolders :: [String] -> JS -> (JS, [JS])
674 insertPlaceHolders args body = insertPlaceHolders' args body []
675 where
676 insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
677 insertPlaceHolders' (a:as) body ph
678 | (body', ph') <- insertPlaceHolders' as body ph =
679 let phvar = JSIdent $ "__PH_" ++ show (length ph') in
680 (jsSubst (JSIdent a) phvar body', phvar : ph')
682 insertPlaceHolders' [] body ph = (body, ph)
685 nonRecur :: String -> JS -> Bool
686 nonRecur name body = countInvokations name body == 0
689 countAll :: String -> [JS] -> Int
690 countAll name js = sum $ map (countInvokations name) js
693 countIDOccurences :: String -> JS -> Int
694 countIDOccurences name = foldJS match (+) 0
695 where
696 match :: JS -> Int
697 match js
698 | JSIdent ident <- js
699 , name == ident = 1
700 | otherwise = 0
703 countInvokations :: String -> JS -> Int
704 countInvokations name = foldJS match (+) 0
705 where
706 match :: JS -> Int
707 match js
708 | JSApp (JSIdent ident) _ <- js
709 , name == ident = 1
710 | JSNew con _ <- js
711 , name == con = 1
712 | otherwise = 0
715reduceContinuations :: JS -> JS
716reduceContinuations = transformJS reduceHelper
717 where
718 reduceHelper :: JS -> JS
719 reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
720 JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
721 )]) = js
723 reduceHelper js = transformJS reduceHelper js
726reduceConstant :: JS -> JS
727reduceConstant
728 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
729 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
730 )])
731 | JSNum num <- val = val
732 | JSBinOp op lhs rhs <- val =
733 JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
735 | JSApp (JSProj lhs op) [rhs] <- val
736 , op `elem` [ "subtract"
737 , "add"
738 , "multiply"
739 , "divide"
740 , "mod"
741 , "equals"
742 , "lesser"
743 , "lesserOrEquals"
744 , "greater"
745 , "greaterOrEquals"
746 ] = val
748reduceConstant (JSApp ident [(JSParens js)]) =
749 JSApp ident [reduceConstant js]
751reduceConstant js = transformJS reduceConstant js
754reduceConstants :: JS -> JS
755reduceConstants js
756 | ret <- reduceConstant js
757 , ret /= js = reduceConstants ret
758 | otherwise = js
761elimDuplicateEvals :: JS -> JS
762elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
763 JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
764 where
765 elimHelper :: [JS] -> [JS]
766 elimHelper (j@(JSAlloc var (Just val)):js) =
767 j : map (jsSubst val (JSIdent var)) (elimHelper js)
768 elimHelper (j:js) =
769 j : elimHelper js
770 elimHelper [] = []
772elimDuplicateEvals js = js
775optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
776optimizeRuntimeCalls fun tc js =
777 optTC tc : map optHelper js
778 where
779 optHelper :: JS -> JS
780 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
781 JSFunction [] (JSReturn (JSApp (JSIdent n) args))
782 ])
783 | n == fun = JSApp (JSIdent tc) $ map optHelper args
785 optHelper js = transformJS optHelper js
788 optTC :: String -> JS
789 optTC tc@"__IDRRT__EVALTC" =
790 JSAlloc tc (Just $ JSFunction ["arg0"] (
791 JSSeq [ JSAlloc "ret" $ Just (
792 JSTernary (
793 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
794 (hasProp "__IDRLT__EVAL" "arg0")
795 ) (JSApp
796 (JSIndex
797 (JSIdent "__IDRLT__EVAL")
798 (JSProj (JSIdent "arg0") "tag")
799 )
800 [JSIdent "arg0"]
801 ) (JSIdent "arg0")
802 )
803 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
804 JSAssign (JSIdent "ret") (
805 JSApp (JSProj (JSIdent "ret") "k") []
806 )
807 )
808 , JSReturn $ JSIdent "ret"
809 ]
810 ))
812 optTC tc@"__IDRRT__APPLYTC" =
813 JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
814 JSSeq [ JSAlloc "ev" $ Just (JSApp
815 (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
816 )
817 , JSAlloc "ret" $ Just (
818 JSTernary (
819 (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
820 (hasProp "__IDRLT__APPLY" "ev")
821 ) (JSApp
822 (JSIndex
823 (JSIdent "__IDRLT__APPLY")
824 (JSProj (JSIdent "ev") "tag")
825 )
826 [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
827 ) JSNull
828 )
829 , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
830 JSAssign (JSIdent "ret") (
831 JSApp (JSProj (JSIdent "ret") "k") []
832 )
833 )
834 , JSReturn $ JSIdent "ret"
835 ]
836 ))
839 hasProp :: String -> String -> JS
840 hasProp table var =
841 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
844unfoldLookupTable :: [JS] -> [JS]
845unfoldLookupTable input =
846 let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
847 (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
848 js = applyunfold in
849 adaptRuntime $ expandCons evals applys js
850 where
851 adaptRuntime :: [JS] -> [JS]
852 adaptRuntime =
853 adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
856 adaptApply var = map (jsSubst (
857 JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
858 ) (JSProj (JSIdent var) "app"))
861 adaptEval = map (jsSubst (
862 JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
863 ) (JSProj (JSIdent "arg0") "eval"))
866 adaptCon js =
867 adaptCon' [] js
868 where
869 adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
870 front ++ (new:back)
872 adaptCon' front (next:back) =
873 adaptCon' (front ++ [next]) back
875 adaptCon' front [] = front
878 new =
879 JSAlloc "__IDRRT__Con" (Just $
880 JSFunction newArgs (
881 JSSeq (map newVar newArgs)
882 )
883 )
884 where
885 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
886 newArgs = ["tag", "eval", "app", "vars"]
889 unfoldLT :: String -> [JS] -> ([Int], [JS])
890 unfoldLT lt js =
891 let (table, code) = extractLT lt js
892 expanded = expandLT lt table in
893 (map fst expanded, map snd expanded ++ code)
896 expandCons :: [Int] -> [Int] -> [JS] -> [JS]
897 expandCons evals applys js =
898 map expandCons' js
899 where
900 expandCons' :: JS -> JS
901 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
902 | evalid <- getId "__IDRLT__EVAL" tag evals
903 , applyid <- getId "__IDRLT__APPLY" tag applys =
904 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
905 , maybe JSNull JSIdent evalid
906 , maybe JSNull JSIdent applyid
907 , JSArray (map expandCons' args)
908 ]
910 expandCons' js = transformJS expandCons' js
913 getId :: String -> Int -> [Int] -> Maybe String
914 getId lt tag entries
915 | tag `elem` entries = Just $ ltIdentifier lt tag
916 | otherwise = Nothing
919 ltIdentifier :: String -> Int -> String
920 ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
921 ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
924 extractLT :: String -> [JS] -> (JS, [JS])
925 extractLT lt js =
926 extractLT' ([], js)
927 where
928 extractLT' :: ([JS], [JS]) -> (JS, [JS])
929 extractLT' (front, js@(JSAlloc fun _):back)
930 | fun == lt = (js, front ++ back)
932 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
935 expandLT :: String -> JS -> [(Int, JS)]
936 expandLT lt (
937 JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
938 ) = catMaybes (map expandEntry seq)
939 where
940 expandEntry :: JS -> Maybe (Int, JS)
941 expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
942 Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
944 expandEntry js = Nothing
947removeInstanceChecks :: JS -> JS
948removeInstanceChecks (JSCond conds) =
949 JSCond $ eliminateDeadBranches $ map (
950 removeHelper *** removeInstanceChecks
951 ) conds
952 where
953 removeHelper (
954 JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
955 ) = removeHelper check
956 removeHelper js = js
959 eliminateDeadBranches (e@(JSTrue, _):_) = [e]
960 eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
961 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
962 eliminateDeadBranches [] = []
964removeInstanceChecks js = transformJS removeInstanceChecks js
967reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
968reduceLoop reduced (cons, program) =
969 case partition findConstructors program of
970 ([], js) -> cons ++ js
971 (candidates, rest) ->
972 let names = reduced ++ map funName candidates in
973 reduceLoop names (
974 cons ++ map reduce candidates, map (reduceCall names) rest
975 )
976 where findConstructors :: JS -> Bool
977 findConstructors js
978 | (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
979 reducable $ last body
980 | otherwise = False
981 where reducable :: JS -> Bool
982 reducable js
983 | JSReturn ret <- js = reducable ret
984 | JSNew _ args <- js = and $ map reducable args
985 | JSArray fields <- js = and $ map reducable fields
986 | JSNum _ <- js = True
987 | JSNull <- js = True
988 | JSIdent _ <- js = True
989 | otherwise = False
992 reduce :: JS -> JS
993 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
994 | JSReturn js <- last body = (JSAlloc fun (Just js))
996 reduce js = js
999 reduceCall :: [String] -> JS -> JS
1000 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1001 JSReturn (JSApp id@(JSIdent ret) _)
1002 )])
1003 | ret `elem` funs = id
1005 reduceCall funs js@(JSApp id@(JSIdent fun) _)
1006 | fun `elem` funs = id
1008 reduceCall funs js = transformJS (reduceCall funs) js
1011optimizeJS :: JS -> JS
1012optimizeJS = inlineLoop
1013 where inlineLoop :: JS -> JS
1014 inlineLoop js
1015 | opt <- inlineJS js
1016 , opt /= js = inlineLoop opt
1017 | otherwise = js
1020extractLocalConstructors :: [JS] -> [JS]
1021extractLocalConstructors js =
1022 concatMap extractLocalConstructors' js
1023 where
1024 globalCons :: [String]
1025 globalCons = concatMap (getGlobalCons) js
1028 extractLocalConstructors' :: JS -> [JS]
1029 extractLocalConstructors' js@(JSAlloc fun (Just (JSFunction args body))) =
1030 map allocCon cons ++ [foldr (uncurry jsSubst) js (reverse cons)]
1031 where
1032 cons :: [(JS, JS)]
1033 cons = zipWith genName (foldJS match (++) [] body) [1..]
1034 where
1035 genName :: JS -> Int -> (JS, JS)
1036 genName js id =
1037 (js, JSIdent $ idrCTRNamespace ++ fun ++ "_" ++ show id)
1039 match :: JS -> [JS]
1040 match js
1041 | JSNew "__IDRRT__Con" args <- js
1042 , all isConstant args = [js]
1043 | otherwise = []
1046 allocCon :: (JS, JS) -> JS
1047 allocCon (js, JSIdent name) =
1048 JSAlloc name (Just js)
1051 isConstant :: JS -> Bool
1052 isConstant js
1053 | JSNew "__IDRRT__Con" args <- js
1054 , all isConstant args =
1055 True
1056 | otherwise =
1057 isJSConstantConstructor globalCons js
1059 extractLocalConstructors' js = [js]
1062 getGlobalCons :: JS -> [String]
1063 getGlobalCons js = foldJS match (++) [] js
1064 where
1065 match :: JS -> [String]
1066 match js
1067 | (JSAlloc name (Just (JSNew "__IDRRT__Con" _))) <- js =
1068 [name]
1069 | otherwise =
1070 []
1073evalCons :: [JS] -> [JS]
1074evalCons js =
1075 map (collapseCont . collapseTC . expandProj . evalCons') js
1076 where
1077 cons :: [(String, JS)]
1078 cons = concatMap getGlobalCons js
1080 evalCons' :: JS -> JS
1081 evalCons' js = transformJS match js
1082 where
1083 match :: JS -> JS
1084 match (JSApp (JSIdent "__IDRRT__EVALTC") [arg])
1085 | JSIdent name <- arg
1086 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1087 arg
1089 match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1090 | JSIdent name <- arg
1091 , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1092 arg
1094 match js = transformJS match js
1097 lookupConstructor :: String -> [(String, JS)] -> Maybe JS
1098 lookupConstructor ctr cons
1099 | Just (JSIdent name) <- lookup ctr cons = lookupConstructor name cons
1100 | Just con@(JSNew _ _) <- lookup ctr cons = Just con
1101 | otherwise = Nothing
1104 expandProj :: JS -> JS
1105 expandProj js = transformJS match js
1106 where
1107 match :: JS -> JS
1108 match (
1109 JSIndex (
1110 JSProj (JSIdent name) "vars"
1111 ) (
1112 JSNum (JSInt idx)
1115 | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1116 args !! idx
1118 match js = transformJS match js
1121 collapseTC :: JS -> JS
1122 collapseTC js = transformJS match js
1123 where
1124 match :: JS -> JS
1125 match (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
1126 JSReturn (JSIdent name)
1127 )])
1128 | Just _ <- lookup name cons = (JSIdent name)
1130 match js = transformJS match js
1133 collapseCont :: JS -> JS
1134 collapseCont js = transformJS match js
1135 where
1136 match :: JS -> JS
1137 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1138 JSReturn ret@(JSNew "__IDRRT__Cont" [JSFunction [] _])
1139 )]) = collapseCont ret
1142 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1143 JSReturn (JSIdent name)
1144 )]) = JSIdent name
1146 match (JSNew "__IDRRT__Cont" [JSFunction [] (
1147 JSReturn ret@(JSNew "__IDRRT__Con" [_, _, _, JSArray args])
1148 )])
1149 | all collapsable args = ret
1150 where
1151 collapsable :: JS -> Bool
1152 collapsable (JSIdent _) = True
1153 collapsable js = isJSConstantConstructor (map fst cons) js
1156 match js = transformJS match js
1159getGlobalCons :: JS -> [(String, JS)]
1160getGlobalCons js = foldJS match (++) [] js
1161 where
1162 match :: JS -> [(String, JS)]
1163 match js
1164 | (JSAlloc name (Just con@(JSNew "__IDRRT__Con" _))) <- js =
1165 [(name, con)]
1166 | (JSAlloc name (Just con@(JSIdent _))) <- js =
1167 [(name, con)]
1168 | otherwise =
1169 []
1172codegenJavaScript
1173 :: JSTarget
1174 -> [(Name, SDecl)]
1175 -> FilePath
1176 -> OutputType
1177 -> IO ()
1178codegenJavaScript target definitions filename outputType = do
1179 let (header, runtime) = case target of
1180 Node ->
1181 ("#!/usr/bin/env node\n", "-node")
1182 JavaScript ->
1183 ("", "-browser")
1184 path <- (++) <$> getDataDir <*> (pure "/jsrts/")
1185 idrRuntime <- readFile $ path ++ "Runtime-common.js"
1186 tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
1187 jsbn <- readFile $ path ++ "jsbn/jsbn.js"
1188 writeFile filename $ header ++ (
1189 intercalate "\n" $ [ jsbn
1190 , idrRuntime
1191 , tgtRuntime
1192 ] ++ functions
1195 setPermissions filename (emptyPermissions { readable = True
1196 , executable = target == Node
1197 , writable = True
1198 })
1199 where
1200 def :: [(String, SDecl)]
1201 def = map (first translateNamespace) definitions
1204 functions :: [String]
1205 functions = translate >>> optimize >>> compile $ def
1206 where
1207 translate p =
1208 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1209 optimize p =
1210 foldl' (flip ($)) p opt
1211 compile =
1212 map compileJS
1214 opt =
1215 [ map optimizeJS
1216 , removeIDs
1217 , reduceJS
1218 , map reduceConstants
1219 , initConstructors
1220 , map removeAllocations
1221 , elimDeadLoop
1222 , map elimDuplicateEvals
1223 , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1224 , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1225 , map removeInstanceChecks
1226 , inlineFunctions
1227 , map reduceContinuations
1228 , extractLocalConstructors
1229 , unfoldLookupTable
1230 , evalCons
1233 prelude :: [JS]
1234 prelude =
1235 [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1236 JSAssign (JSProj JSThis "k") (JSIdent "k")
1237 ))
1238 , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1239 JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1240 , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1242 ))
1245 mainLoop :: JS
1246 mainLoop =
1247 JSAlloc "main" $ Just $ JSFunction [] (
1248 case target of
1249 Node -> mainFun
1250 JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
1251 JSString "DOMContentLoaded", JSFunction [] (
1252 mainFun
1253 ), JSFalse
1256 where
1257 mainFun :: JS
1258 mainFun = jsTailcall $ jsCall runMain []
1261 runMain :: String
1262 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
1265 invokeLoop :: JS
1266 invokeLoop = jsCall "main" []
1269translateIdentifier :: String -> String
1270translateIdentifier =
1271 replaceReserved . concatMap replaceBadChars
1272 where replaceBadChars :: Char -> String
1273 replaceBadChars c
1274 | ' ' <- c = "_"
1275 | '_' <- c = "__"
1276 | isDigit c = '_' : show (ord c)
1277 | not (isLetter c && isAscii c) = '_' : show (ord c)
1278 | otherwise = [c]
1279 replaceReserved s
1280 | s `elem` reserved = '_' : s
1281 | otherwise = s
1284 reserved = [ "break"
1285 , "case"
1286 , "catch"
1287 , "continue"
1288 , "debugger"
1289 , "default"
1290 , "delete"
1291 , "do"
1292 , "else"
1293 , "finally"
1294 , "for"
1295 , "function"
1296 , "if"
1297 , "in"
1298 , "instanceof"
1299 , "new"
1300 , "return"
1301 , "switch"
1302 , "this"
1303 , "throw"
1304 , "try"
1305 , "typeof"
1306 , "var"
1307 , "void"
1308 , "while"
1309 , "with"
1311 , "class"
1312 , "enum"
1313 , "export"
1314 , "extends"
1315 , "import"
1316 , "super"
1318 , "implements"
1319 , "interface"
1320 , "let"
1321 , "package"
1322 , "private"
1323 , "protected"
1324 , "public"
1325 , "static"
1326 , "yield"
1330translateNamespace :: Name -> String
1331translateNamespace (UN _) = idrNamespace
1332translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
1333translateNamespace (MN _ _) = idrNamespace
1334translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
1335translateNamespace NErased = idrNamespace
1338translateName :: Name -> String
1339translateName (UN name) = 'u' : translateIdentifier (str name)
1340translateName (NS name _) = 'n' : translateName name
1341translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
1342translateName (SN name) = 's' : translateSpecialName name
1343translateName NErased = "e"
1346translateSpecialName :: SpecialName -> String
1347translateSpecialName name
1348 | WhereN i m n <- name =
1349 'w' : translateName m ++ translateName n ++ show i
1350 | InstanceN n s <- name =
1351 'i' : translateName n ++ concatMap (translateIdentifier . str) s
1352 | ParentN n s <- name =
1353 'p' : translateName n ++ translateIdentifier (str s)
1354 | MethodN n <- name =
1355 'm' : translateName n
1356 | CaseN n <- name =
1357 'c' : translateName n
1360translateConstant :: Const -> JS
1361translateConstant (I i) = JSNum (JSInt i)
1362translateConstant (Fl f) = JSNum (JSFloat f)
1363translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
1364translateConstant (Ch '\a') = JSChar "'\\u0007'"
1365translateConstant (Ch '\SO') = JSChar "'\\u000E'"
1366translateConstant (Ch c) = JSString [c]
1367translateConstant (Str s) = JSString s
1368translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
1369translateConstant StrType = JSType JSStringTy
1370translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
1371translateConstant (AType ATFloat) = JSType JSFloatTy
1372translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
1373translateConstant PtrType = JSType JSPtrTy
1374translateConstant Forgot = JSType JSForgotTy
1375translateConstant (BI i) = jsBigInt $ JSString (show i)
1376translateConstant c =
1377 jsError $ "Unimplemented Constant: " ++ show c
1380translateDeclaration :: (String, SDecl) -> [JS]
1381translateDeclaration (path, SFun name params stackSize body)
1382 | (MN _ ap) <- name
1383 , (SLet var val next) <- body
1384 , (SChkCase cvar cases) <- next
1385 , ap == txt "APPLY" =
1386 let lvar = translateVariableName var
1387 lookup t = (JSApp
1388 (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1389 [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1390 [ lookupTable "APPLY" [(var, "chk")] var cases
1391 , jsDecl $ JSFunction ["fn0", "arg0"] (
1392 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1393 , JSAlloc (translateVariableName var) (
1394 Just $ translateExpression val
1396 , JSReturn $ (JSTernary (
1397 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1398 (hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))
1399 ) (lookup (idrLTNamespace ++ "APPLY")) JSNull)
1404 | (MN _ ev) <- name
1405 , (SChkCase var cases) <- body
1406 , ev == txt "EVAL" =
1407 [ lookupTable "EVAL" [] var cases
1408 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1409 JSTernary (
1410 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1411 (hasProp (idrLTNamespace ++ "EVAL") "arg0")
1412 ) (JSApp
1413 (JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))
1414 [JSIdent "arg0"]
1415 ) (JSIdent "arg0")
1418 | otherwise =
1419 let fun = translateExpression body in
1420 [jsDecl $ jsFun fun]
1422 where
1423 hasProp :: String -> String -> JS
1424 hasProp table var =
1425 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
1428 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1429 caseFun aux var cse =
1430 let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1431 jsFunAux aux c
1434 getTag :: SAlt -> Maybe Int
1435 getTag (SConCase _ tag _ _ _) = Just tag
1436 getTag _ = Nothing
1439 lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1440 lookupTable table aux var cases =
1441 JSAlloc (idrLTNamespace ++ table) $ Just (
1442 JSApp (JSFunction [] (
1443 JSSeq $ [
1444 JSAlloc "t" $ Just (JSArray [])
1445 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
1446 JSReturn (JSIdent "t")
1448 )) []
1450 where
1451 assignEntries :: [(Int, JS)] -> [JS]
1452 assignEntries entries =
1453 map (\(tag, fun) ->
1454 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
1455 ) entries
1458 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
1459 lookupEntry aux var alt = do
1460 tag <- getTag alt
1461 return (tag, caseFun aux var alt)
1464 jsDecl :: JS -> JS
1465 jsDecl = JSAlloc (path ++ translateName name) . Just
1468 jsFun body = jsFunAux [] body
1471 jsFunAux :: [(LVar, String)] -> JS -> JS
1472 jsFunAux aux body =
1473 JSFunction (p ++ map snd aux) (
1474 JSSeq $
1475 zipWith assignVar [0..] p ++
1476 map assignAux aux ++
1477 [JSReturn body]
1479 where
1480 assignVar :: Int -> String -> JS
1481 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
1484 assignAux :: (LVar, String) -> JS
1485 assignAux (Loc var, val) =
1486 JSAlloc (jsVar var) (Just $ JSIdent val)
1489 p :: [String]
1490 p = map translateName params
1493translateVariableName :: LVar -> String
1494translateVariableName (Loc i) =
1495 jsVar i
1498translateExpression :: SExp -> JS
1499translateExpression (SLet name value body) =
1500 jsLet (translateVariableName name) (
1501 translateExpression value
1502 ) (translateExpression body)
1504translateExpression (SConst cst) =
1505 translateConstant cst
1507translateExpression (SV var) =
1508 JSVar var
1510translateExpression (SApp tc name vars)
1511 | False <- tc =
1512 jsTailcall $ translateFunctionCall name vars
1513 | True <- tc =
1514 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
1515 JSReturn $ translateFunctionCall name vars
1516 )]
1517 where
1518 translateFunctionCall name vars =
1519 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
1521translateExpression (SOp op vars)
1522 | LNoOp <- op = JSVar (last vars)
1524 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
1525 | (LPlus (ATInt ITBig)) <- op
1526 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
1527 | (LMinus (ATInt ITBig)) <- op
1528 , (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
1529 | (LTimes (ATInt ITBig)) <- op
1530 , (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
1531 | (LSDiv (ATInt ITBig)) <- op
1532 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
1533 | (LSRem (ATInt ITBig)) <- op
1534 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
1535 | (LEq (ATInt ITBig)) <- op
1536 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
1537 | (LSLt (ATInt ITBig)) <- op
1538 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
1539 | (LSLe (ATInt ITBig)) <- op
1540 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
1541 | (LSGt (ATInt ITBig)) <- op
1542 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
1543 | (LSGe (ATInt ITBig)) <- op
1544 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
1546 | (LPlus ATFloat) <- op
1547 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1548 | (LMinus ATFloat) <- op
1549 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1550 | (LTimes ATFloat) <- op
1551 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1552 | (LSDiv ATFloat) <- op
1553 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1554 | (LEq ATFloat) <- op
1555 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1556 | (LSLt ATFloat) <- op
1557 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1558 | (LSLe ATFloat) <- op
1559 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1560 | (LSGt ATFloat) <- op
1561 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1562 | (LSGe ATFloat) <- op
1563 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1565 | (LPlus _) <- op
1566 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1567 | (LMinus _) <- op
1568 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
1569 | (LTimes _) <- op
1570 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
1571 | (LSDiv _) <- op
1572 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
1573 | (LSRem _) <- op
1574 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
1575 | (LEq _) <- op
1576 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1577 | (LSLt _) <- op
1578 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1579 | (LSLe _) <- op
1580 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
1581 | (LSGt _) <- op
1582 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
1583 | (LSGe _) <- op
1584 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
1585 | (LAnd _) <- op
1586 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
1587 | (LOr _) <- op
1588 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
1589 | (LXOr _) <- op
1590 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
1591 | (LSHL _) <- op
1592 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
1593 | (LASHR _) <- op
1594 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
1595 | (LCompl _) <- op
1596 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
1598 | LStrConcat <- op
1599 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1600 | LStrEq <- op
1601 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
1602 | LStrLt <- op
1603 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
1604 | LStrLen <- op
1605 , (arg:_) <- vars = JSProj (JSVar arg) "length"
1607 | (LStrInt ITNative) <- op
1608 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
1609 | (LIntStr ITNative) <- op
1610 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1611 | (LSExt ITNative ITBig) <- op
1612 , (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
1613 | (LTrunc ITBig ITNative) <- op
1614 , (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
1615 | (LIntStr ITBig) <- op
1616 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
1617 | (LStrInt ITBig) <- op
1618 , (arg:_) <- vars = jsBigInt $ JSVar arg
1619 | LFloatStr <- op
1620 , (arg:_) <- vars = jsCall "String" [JSVar arg]
1621 | LStrFloat <- op
1622 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
1623 | (LIntFloat ITNative) <- op
1624 , (arg:_) <- vars = JSVar arg
1625 | (LFloatInt ITNative) <- op
1626 , (arg:_) <- vars = JSVar arg
1627 | (LChInt ITNative) <- op
1628 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
1629 | (LIntCh ITNative) <- op
1630 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
1632 | LFExp <- op
1633 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
1634 | LFLog <- op
1635 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
1636 | LFSin <- op
1637 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
1638 | LFCos <- op
1639 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
1640 | LFTan <- op
1641 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
1642 | LFASin <- op
1643 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
1644 | LFACos <- op
1645 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
1646 | LFATan <- op
1647 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
1648 | LFSqrt <- op
1649 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
1650 | LFFloor <- op
1651 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
1652 | LFCeil <- op
1653 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
1655 | LStrCons <- op
1656 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
1657 | LStrHead <- op
1658 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
1659 | LStrRev <- op
1660 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
1661 | LStrIndex <- op
1662 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
1663 | LStrTail <- op
1664 , (arg:_) <- vars = let v = translateVariableName arg in
1665 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
1666 | LNullPtr <- op
1667 , (_) <- vars = JSNull
1669 where
1670 translateBinaryOp :: String -> LVar -> LVar -> JS
1671 translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
1674 invokeMeth :: LVar -> String -> [LVar] -> JS
1675 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
1677translateExpression (SError msg) =
1678 jsError msg
1680translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
1681 jsCall (idrRTNamespace ++ "print") [JSVar var]
1683translateExpression (SForeign _ _ fun args) =
1684 ffi fun (map generateWrapper args)
1685 where
1686 generateWrapper (ffunc, name)
1687 | FFunction <- ffunc =
1688 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1689 | FFunctionIO <- ffunc =
1690 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
1692 generateWrapper (_, name) =
1693 translateVariableName name
1695translateExpression patterncase
1696 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
1697 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
1698 where
1699 caseHelper var cases param =
1700 JSApp (JSFunction [param] (
1701 JSCond $ map (expandCase param . translateCaseCond param) cases
1702 )) [JSVar var]
1705 expandCase :: String -> (Cond, JS) -> (JS, JS)
1706 expandCase _ (RawCond cond, branch) = (cond, branch)
1707 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
1708 expandCase var (CaseCond caseTy, branch)
1709 | ConCase tag <- caseTy =
1710 let checkCon = JSIdent var `jsInstanceOf` jsCon
1711 checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
1712 (checkCon `jsAnd` checkTag, branch)
1714 | TypeCase ty <- caseTy =
1715 let checkTy = JSIdent var `jsInstanceOf` jsType
1716 checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
1717 (checkTy `jsAnd` checkTag, branch)
1719translateExpression (SCon i name vars) =
1720 JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
1721 , JSArray $ map JSVar vars
1724translateExpression (SUpdate var@(Loc i) e) =
1725 JSAssign (JSVar var) (translateExpression e)
1727translateExpression (SProj var i) =
1728 JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
1730translateExpression SNothing = JSNull
1732translateExpression e =
1733 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
1736data FFI = FFICode Char | FFIArg Int | FFIError String
1739ffi :: String -> [String] -> JS
1740ffi code args = let parsed = ffiParse code in
1741 case ffiError parsed of
1742 Just err -> jsError err
1743 Nothing -> JSRaw $ renderFFI parsed args
1744 where
1745 ffiParse :: String -> [FFI]
1746 ffiParse "" = []
1747 ffiParse ['%'] = [FFIError "Invalid positional argument"]
1748 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
1749 ffiParse ('%':s:ss)
1750 | isDigit s =
1751 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
1752 | otherwise =
1753 [FFIError "Invalid positional argument"]
1754 ffiParse (s:ss) = FFICode s : ffiParse ss
1757 ffiError :: [FFI] -> Maybe String
1758 ffiError [] = Nothing
1759 ffiError ((FFIError s):xs) = Just s
1760 ffiError (x:xs) = ffiError xs
1763 renderFFI :: [FFI] -> [String] -> String
1764 renderFFI [] _ = ""
1765 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
1766 renderFFI ((FFIArg i) : fs) args
1767 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
1768 | otherwise = "Argument index out of bounds"
1771data CaseType = ConCase Int
1772 | TypeCase JSType
1773 | DefaultCase
1774 deriving Eq
1777data Cond = CaseCond CaseType
1778 | RawCond JS
1781translateCaseCond :: String -> SAlt -> (Cond, JS)
1782translateCaseCond _ cse@(SDefaultCase _) =
1783 (CaseCond DefaultCase, translateCase Nothing cse)
1785translateCaseCond var cse@(SConstCase ty _)
1786 | StrType <- ty = matchHelper JSStringTy
1787 | PtrType <- ty = matchHelper JSPtrTy
1788 | Forgot <- ty = matchHelper JSForgotTy
1789 | (AType ATFloat) <- ty = matchHelper JSFloatTy
1790 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
1791 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
1792 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
1793 where
1794 matchHelper :: JSType -> (Cond, JS)
1795 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
1797translateCaseCond var cse@(SConstCase cst@(BI _) _) =
1798 let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
1799 (RawCond cond, translateCase Nothing cse)
1801translateCaseCond var cse@(SConstCase cst _) =
1802 let cond = JSIdent var `jsEq` translateConstant cst in
1803 (RawCond cond, translateCase Nothing cse)
1805translateCaseCond var cse@(SConCase _ tag _ _ _) =
1806 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1809translateCase :: Maybe String -> SAlt -> JS
1810translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
1811translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
1812translateCase (Just var) (SConCase a _ _ vars e) =
1813 let params = map jsVar [a .. (a + length vars)] in
1814 JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1815 JSThis, JSProj (JSIdent var) "vars"