git.iko.soy/Idris-dev
on master help sign in
Merge pull request #809 from raichoo/javascript
50c2c53Edwin Brady
src/IRTS/CodegenJavaScript.hs+254−56
compare with master
unifiedsplit
@@ -258,20 +258,8 @@ jsSubst var new (JSIdent old)
258jsSubst var new (JSArray fields) =
258jsSubst var new (JSArray fields) =
259 JSArray (map (jsSubst var new) fields)
259 JSArray (map (jsSubst var new) fields)
260
260
261−jsSubst var new (JSNew con [tag, vals]) =
261+jsSubst var new (JSNew con vals) =
262− JSNew con [tag, jsSubst var new vals]
263−
264−jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
265− JSNew con [JSFunction [] (
266− JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) vars)
262+ JSNew con $ map (jsSubst var new) vals
267− )]
268−
269−jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
270− JSReturn (JSApp fun args)
271− )]) =
272− JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
273− JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
274− )]
275
263
276jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
264jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
277 | var `notElem` args =
265 | var `notElem` args =
@@ -283,9 +271,6 @@ jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
283 map (jsSubst var new) vals
271 map (jsSubst var new) vals
284 )
272 )
285
273
286−jsSubst var new (JSApp (JSProj obj field) args) =
287− JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
288−
289jsSubst var new (JSApp (JSFunction [arg] body) vals)
274jsSubst var new (JSApp (JSFunction [arg] body) vals)
290 | var /= arg =
275 | var /= arg =
291 JSApp (JSFunction [arg] (
276 JSApp (JSFunction [arg] (
@@ -296,6 +281,12 @@ jsSubst var new (JSApp (JSFunction [arg] body) vals)
296 body
281 body
297 )) $ map (jsSubst var new) vals
282 )) $ map (jsSubst var new) vals
298
283
284+jsSubst var new (JSApp lhs rhs) =
285+ JSApp (jsSubst var new lhs) (map (jsSubst var new) rhs)
286+
287+jsSubst var new (JSFunction [] body) =
288+ JSFunction [] (jsSubst var new body)
289+
299jsSubst var new (JSReturn ret) =
290jsSubst var new (JSReturn ret) =
300 JSReturn $ jsSubst var new ret
291 JSReturn $ jsSubst var new ret
301
292
@@ -317,9 +308,64 @@ jsSubst var new (JSCond conds) =
317jsSubst var new (JSAssign lhs rhs) =
308jsSubst var new (JSAssign lhs rhs) =
318 JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
309 JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
319
310
311+jsSubst var new (JSAlloc val (Just js)) =
312+ JSAlloc val (Just (jsSubst var new js))
313+
320jsSubst _ _ js = js
314jsSubst _ _ js = js
321
315
322
316
317+removeAllocations :: JS -> JS
318+removeAllocations (JSSeq body) =
319+ let opt = removeHelper (map removeAllocations body) in
320+ case opt of
321+ [ret] -> ret
322+ _ -> JSSeq opt
323+ where
324+ removeHelper :: [JS] -> [JS]
325+ removeHelper [js] = [js]
326+ removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
327+ map (jsSubst name val) (removeHelper js)
328+ removeHelper (j:js) = j : removeHelper js
329+
330+removeAllocations (JSFunction args body) =
331+ JSFunction args $ removeAllocations body
332+
333+removeAllocations (JSReturn ret) =
334+ JSReturn $ removeAllocations ret
335+
336+removeAllocations (JSApp fun args) =
337+ JSApp (removeAllocations fun) (map removeAllocations args)
338+
339+removeAllocations (JSNew con args) =
340+ JSNew con $ map removeAllocations args
341+
342+removeAllocations (JSOp op lhs rhs) =
343+ JSOp op (removeAllocations lhs) (removeAllocations rhs)
344+
345+removeAllocations (JSProj obj field) =
346+ JSProj (removeAllocations obj) field
347+
348+removeAllocations (JSArray vals) =
349+ JSArray $ map removeAllocations vals
350+
351+removeAllocations (JSAssign lhs rhs) =
352+ JSAssign (removeAllocations lhs) (removeAllocations rhs)
353+
354+removeAllocations (JSAlloc name (Just val)) =
355+ JSAlloc name $ Just (removeAllocations val)
356+
357+removeAllocations (JSIndex val idx) =
358+ JSIndex (removeAllocations val) (removeAllocations idx)
359+
360+removeAllocations (JSCond conds) =
361+ JSCond $ map (removeAllocations *** removeAllocations) conds
362+
363+removeAllocations (JSTernary c t f) =
364+ JSTernary (removeAllocations c) (removeAllocations t) (removeAllocations f)
365+
366+removeAllocations js = js
367+
368+
323isJSConstant :: JS -> Bool
369isJSConstant :: JS -> Bool
324isJSConstant js
370isJSConstant js
325 | JSString _ <- js = True
371 | JSString _ <- js = True
@@ -386,13 +432,9 @@ inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
386 JSOp op (jsSubst arg opt lhs) $
432 JSOp op (jsSubst arg opt lhs) $
387 (jsSubst arg opt rhs)
433 (jsSubst arg opt rhs)
388
434
389− | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
435+ | JSApp (JSIdent fun) args <- ret
390− JSReturn (JSApp fun args)
391− )] <- ret
392 , opt <- inlineJS val =
436 , opt <- inlineJS val =
393− JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
394− JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args)
437+ JSApp (JSIdent fun) $ map (jsSubst arg opt) args
395− )]
396
438
397inlineJS (JSApp fun args) =
439inlineJS (JSApp fun args) =
398 JSApp (inlineJS fun) (map inlineJS args)
440 JSApp (inlineJS fun) (map inlineJS args)
@@ -438,6 +480,62 @@ reduceJS js = reduceLoop [] ([], js)
438funName :: JS -> String
480funName :: JS -> String
439funName (JSAlloc fun _) = fun
481funName (JSAlloc fun _) = fun
440
482
483+
484+deadEvalApplyCases :: [JS] -> [JS]
485+deadEvalApplyCases js =
486+ let tags = sort $ nub $ concatMap (getTags) js in
487+ map (removeHelper tags) js
488+ where
489+ getTags :: JS -> [Int]
490+ getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =
491+ tag : getTags args
492+
493+ getTags (JSNew _ args) = concatMap getTags args
494+
495+ getTags (JSFunction _ body) = getTags body
496+
497+ getTags (JSReturn ret) = getTags ret
498+
499+ getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
500+
501+ getTags (JSSeq seq) = concatMap getTags seq
502+
503+ getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
504+
505+ getTags (JSProj obj _) = getTags obj
506+
507+ getTags (JSArray vals) = concatMap getTags vals
508+
509+ getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
510+
511+ getTags (JSAlloc _ (Just val)) = getTags val
512+
513+ getTags (JSCond conds) =
514+ concatMap (uncurry (++)) $ map (getTags *** getTags) conds
515+
516+ getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
517+
518+ getTags js = []
519+ removeHelper :: [Int] -> JS -> JS
520+ removeHelper tags (JSAlloc fun (Just (
521+ JSApp (JSFunction [] (JSSeq seq)) []))
522+ ) =
523+ (JSAlloc fun (Just (
524+ JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
525+ )
526+
527+ removeHelper _ js = js
528+
529+ remover :: [Int] -> [JS] -> [JS]
530+ remover tags (
531+ j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
532+ )
533+ | tag `notElem` tags = remover tags js
534+
535+ remover tags (j:js) = j : remover tags js
536+ remover _ [] = []
537+
538+
441initConstructors :: [JS] -> [JS]
539initConstructors :: [JS] -> [JS]
442initConstructors js =
540initConstructors js =
443 let tags = nub $ sort $ concat (map getTags js) in
541 let tags = nub $ sort $ concat (map getTags js) in
@@ -592,6 +690,92 @@ removeIDs js =
592
690
593 removeIDCall _ js = js
691 removeIDCall _ js = js
594
692
693+inlineFunctions :: [JS] -> [JS]
694+inlineFunctions js =
695+ let funs = collectFunctions js
696+ occurences = map ((id . fst) &&& countAll js) funs in
697+ removeDeadFunctions occurences js
698+ where
699+ removeDeadFunctions :: [(String, (Int, JS))] -> [JS] -> [JS]
700+ removeDeadFunctions _ [] = []
701+ removeDeadFunctions funOccur ((JSAlloc fun (Just (JSFunction _ _))):js)
702+ | Just (o, _) <- lookup fun funOccur
703+ , o == 0 = removeDeadFunctions funOccur js
704+
705+ removeDeadFunctions funOccur (j:js) = j : removeDeadFunctions funOccur js
706+
707+
708+ collectFunctions :: [JS] -> [(String, JS)]
709+ collectFunctions js =
710+ catMaybes $ map collectHelper js
711+
712+
713+ collectHelper :: JS -> Maybe (String, JS)
714+ collectHelper (JSAlloc fun (Just js@(JSFunction _ body)))
715+ | fun /= "main" && nonRecur fun body = Just (fun, js)
716+ collectHelper _ = Nothing
717+
718+
719+ nonRecur :: String -> JS -> Bool
720+ nonRecur name body = countInvokations name body == 0
721+
722+
723+ countAll :: [JS] -> (String, JS) -> (Int, JS)
724+ countAll js (name, fun) = (sum $ map (countInvokations name) js, fun)
725+
726+
727+ countInvokations :: String -> JS -> Int
728+ countInvokations name (JSApp (JSIdent ident) args)
729+ | name == ident = 1 + (sum $ map (countInvokations name) args)
730+ | otherwise = sum $ map (countInvokations name) args
731+
732+ countInvokations name (JSApp lhs rhs) =
733+ countInvokations name lhs + (sum $ map (countInvokations name) rhs)
734+
735+ countInvokations name (JSFunction _ body) =
736+ countInvokations name body
737+
738+ countInvokations name (JSSeq seq) =
739+ sum $ map (countInvokations name) seq
740+
741+ countInvokations name (JSReturn ret) =
742+ countInvokations name ret
743+
744+ countInvokations name (JSNew _ args) =
745+ sum $ map (countInvokations name) args
746+
747+ countInvokations name (JSOp _ lhs rhs) =
748+ countInvokations name lhs + countInvokations name rhs
749+
750+ countInvokations name (JSProj obj _) =
751+ countInvokations name obj
752+
753+ countInvokations name (JSArray vals) =
754+ sum $ map (countInvokations name) vals
755+
756+ countInvokations name (JSAssign _ rhs) =
757+ countInvokations name rhs
758+
759+ countInvokations name (JSAlloc _ (Just js)) =
760+ countInvokations name js
761+
762+ countInvokations name (JSIndex lhs rhs) =
763+ countInvokations name lhs + countInvokations name rhs
764+
765+ countInvokations name (JSCond conds) =
766+ sum $ map (uncurry (+)) (
767+ map (countInvokations name *** countInvokations name) conds
768+ )
769+
770+ countInvokations name (JSTernary c t f) =
771+ sum $ [ countInvokations name c
772+ , countInvokations name t
773+ , countInvokations name f
774+ ]
775+
776+ countInvokations _ _ = 0
777+
778+
595reduceConstant :: JS -> JS
779reduceConstant :: JS -> JS
596reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
780reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
597 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
781 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
@@ -736,7 +920,7 @@ codegenJavaScript target definitions filename outputType = do
736 intercalate "\n" $ [ jsbn
920 intercalate "\n" $ [ jsbn
737 , idrRuntime
921 , idrRuntime
738 , tgtRuntime
922 , tgtRuntime
739− ] ++ functions ++ [mainLoop, invokeLoop]
923+ ] ++ functions
740 )
924 )
741
925
742 setPermissions filename (emptyPermissions { readable = True
926 setPermissions filename (emptyPermissions { readable = True
@@ -749,10 +933,21 @@ codegenJavaScript target definitions filename outputType = do
749
933
750 functions :: [String]
934 functions :: [String]
751 functions =
935 functions =
752− map compileJS $ initConstructors (map reduceConstants ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def))
936+ let translated =
753−
937+ concatMap translateDeclaration def ++ [mainLoop, invokeLoop]
938+
939+ optimized = map optimizeJS translated
940+ idsRemoved = removeIDs optimized
941+ reduced = reduceJS idsRemoved
942+ constRemoved = map reduceConstants reduced
943+ constrInit = initConstructors constRemoved
944+ removeAlloc = map removeAllocations constrInit
945+ deadElim = deadEvalApplyCases removeAlloc
946+ js = inlineFunctions deadElim in
947+ map compileJS js
948+
754− mainLoop :: String
949+ mainLoop :: JS
755− mainLoop = compileJS $
950+ mainLoop =
756 JSAlloc "main" $ Just $ JSFunction [] (
951 JSAlloc "main" $ Just $ JSFunction [] (
757 case target of
952 case target of
758 Node -> mainFun
953 Node -> mainFun
@@ -769,8 +964,8 @@ codegenJavaScript target definitions filename outputType = do
769 runMain :: String
964 runMain :: String
770 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
965 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
771
966
772− invokeLoop :: String
967+ invokeLoop :: JS
773− invokeLoop = compileJS $ jsCall "main" []
968+ invokeLoop = jsCall "main" []
774
969
775translateIdentifier :: String -> String
970translateIdentifier :: String -> String
776translateIdentifier =
971translateIdentifier =
@@ -876,7 +1071,7 @@ translateConstant (BI i) = jsBigInt $ JSString (show i)
876translateConstant c =
1071translateConstant c =
877 JSError $ "Unimplemented Constant: " ++ show c
1072 JSError $ "Unimplemented Constant: " ++ show c
878
1073
879−translateDeclaration :: (String, SDecl) -> JS
1074+translateDeclaration :: (String, SDecl) -> [JS]
880translateDeclaration (path, SFun name params stackSize body)
1075translateDeclaration (path, SFun name params stackSize body)
881 | (MN _ ap) <- name
1076 | (MN _ ap) <- name
882 , (SLet var val next) <- body
1077 , (SLet var val next) <- body
@@ -884,37 +1079,40 @@ translateDeclaration (path, SFun name params stackSize body)
884 , ap == txt "APPLY" =
1079 , ap == txt "APPLY" =
885 let lvar = translateVariableName var
1080 let lvar = translateVariableName var
886 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
1081 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
887− JSSeq [ lookupTable [(var, "chk")] var cases
1082+ [ lookupTable [(var, "chk")] var cases
888− , jsDecl $ JSFunction ["fn0", "arg0"] (
1083+ , jsDecl $ JSFunction ["fn0", "arg0"] (
889− JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1084+ JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
890− , JSAlloc (translateVariableName var) (
1085+ , JSAlloc (translateVariableName var) (
891− Just $ translateExpression val
1086+ Just $ translateExpression val
892− )
1087+ )
893− , JSReturn $ (JSTernary (
1088+ , JSReturn $ (JSTernary (
894− (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1089+ (JSVar var `jsInstanceOf` jsCon) `jsAnd`
895− (hasProp lookupTableName (translateVariableName var))
1090+ (hasProp lookupTableName (translateVariableName var))
896− ) (JSIdent $
1091+ ) (JSIdent $
897− lookupTableName ++ lookup
1092+ lookupTableName ++ lookup
898− ) JSNull
1093+ ) JSNull
899− )
1094+ )
900− ]
1095+ ]
901− )
1096+ )
902− ]
1097+ ]
903
1098
904 | (MN _ ev) <- name
1099 | (MN _ ev) <- name
905 , (SChkCase var cases) <- body
1100 , (SChkCase var cases) <- body
906 , ev == txt "EVAL" =
1101 , ev == txt "EVAL" =
907− JSSeq [ lookupTable [] var cases
1102+ [ lookupTable [] var cases
908− , jsDecl $ JSFunction ["arg0"] (JSReturn $
1103+ , jsDecl $ JSFunction ["arg0"] (JSReturn $
909− JSTernary (
1104+ JSTernary (
910− (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1105+ (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
911− (hasProp lookupTableName "arg0")
1106+ (hasProp lookupTableName "arg0")
1107+ ) (JSApp
912− ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
1108+ (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1109+ [JSIdent "arg0"]
1110+ ) (JSIdent "arg0")
913− )
1111+ )
914− ]
1112+ ]
915 | otherwise =
1113 | otherwise =
916 let fun = translateExpression body in
1114 let fun = translateExpression body in
917− jsDecl $ jsFun fun
1115+ [jsDecl $ jsFun fun]
918
1116
919 where
1117 where
920 hasProp :: String -> String -> JS
1118 hasProp :: String -> String -> JS
test/Makefile+7−1
@@ -26,7 +26,7 @@ test_js:
26 @perl ./runtest.pl reg013 --codegen node
26 @perl ./runtest.pl reg013 --codegen node
27 @perl ./runtest.pl reg014 --codegen node
27 @perl ./runtest.pl reg014 --codegen node
28 @perl ./runtest.pl reg015 --codegen node
28 @perl ./runtest.pl reg015 --codegen node
29− @#perl ./runtest.pl reg016 --codegen node
29+ @perl ./runtest.pl reg016 --codegen node
30 @perl ./runtest.pl reg017 --codegen node
30 @perl ./runtest.pl reg017 --codegen node
31 @perl ./runtest.pl reg018 --codegen node
31 @perl ./runtest.pl reg018 --codegen node
32 @perl ./runtest.pl reg019 --codegen node
32 @perl ./runtest.pl reg019 --codegen node
@@ -62,6 +62,12 @@ test_js:
62 @perl ./runtest.pl test029 --codegen node
62 @perl ./runtest.pl test029 --codegen node
63 @perl ./runtest.pl test030 --codegen node
63 @perl ./runtest.pl test030 --codegen node
64 @perl ./runtest.pl test031 --codegen node
64 @perl ./runtest.pl test031 --codegen node
65+ @perl ./runtest.pl test032 --codegen node
66+ @#perl ./runtest.pl test033 --codegen node
67+ @perl ./runtest.pl test034 --codegen node
68+ @perl ./runtest.pl test035 --codegen node
69+ @perl ./runtest.pl test036 --codegen node
70+ @perl ./runtest.pl test037 --codegen node
65
71
66test_llvm:
72test_llvm:
67 @perl ./runtest.pl test001 --codegen llvm
73 @perl ./runtest.pl test001 --codegen llvm