git.iko.soy/Idris-dev
on master help sign in
Merge pull request #854 from raichoo/javascript
138d35eEdwin Brady
src/IRTS/CodegenJavaScript.hs+41−56
compare with master
unifiedsplit
@@ -20,9 +20,10 @@ import System.IO
20import System.Directory
20import System.Directory
21
21
22idrNamespace :: String
22idrNamespace :: String
23−idrNamespace = "__IDR__"
23+idrNamespace = "__IDR__"
24−idrRTNamespace = "__IDRRT__"
24+idrRTNamespace = "__IDRRT__"
25−idrLTNamespace = "__IDRLT__"
25+idrLTNamespace = "__IDRLT__"
26+idrCTRNamespace = "__IDRCTR__"
26
27
27
28
28data JSTarget = Node | JavaScript deriving Eq
29data JSTarget = Node | JavaScript deriving Eq
@@ -564,14 +565,14 @@ initConstructors js =
564 where
565 where
565 replaceHelper :: [Int] -> JS -> JS
566 replaceHelper :: [Int] -> JS -> JS
566 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
567 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
567− | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
568+ | tag `elem` tags = JSIdent (idrCTRNamespace ++ show tag)
568
569
569 replaceHelper tags js = transformJS (replaceHelper tags) js
570 replaceHelper tags js = transformJS (replaceHelper tags) js
570
571
571
572
572 createConstant :: Int -> JS
573 createConstant :: Int -> JS
573 createConstant tag =
574 createConstant tag =
574− JSAlloc ("__IDRCTR__" ++ show tag) (Just (
575+ JSAlloc (idrCTRNamespace ++ show tag) (Just (
575 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
576 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
576 ))
577 ))
577
578
@@ -632,33 +633,11 @@ inlineFunctions js =
632
633
633
634
634 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
635 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
635− inlineAble 1 fun args body
636+ inlineAble 1 fun args (JSReturn body)
636 | nonRecur fun body =
637 | nonRecur fun body =
637− inlineAble' body
638+ if all (<= 1) (map ($ body) (map countIDOccurences args))
638− where
639+ then Just body
639− inlineAble' :: JS -> Maybe JS
640− inlineAble' (
641− JSReturn js@(JSNew "__IDRRT__Con" [JSNum _, JSArray vals])
642− )
643− | and $ map (\x -> isJSIdent x || isJSConstant x) vals = Just js
644−
645− inlineAble' (
646− JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] (
647− JSReturn (JSApp (JSIdent _) args)
648− )])
649− )
650− | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
651−
652− inlineAble' (
653− JSReturn js@(JSIndex (JSProj (JSApp (JSIdent _) args) "vars") _)
654− )
655− | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
656−
657− inlineAble' _ = Nothing
640+ else Nothing
658−
659− isJSIdent js
660− | JSIdent _ <- js = True
661− | otherwise = False
662
641
663 inlineAble _ _ _ _ = Nothing
642 inlineAble _ _ _ _ = Nothing
664
643
@@ -694,6 +673,16 @@ inlineFunctions js =
694 countAll name js = sum $ map (countInvokations name) js
673 countAll name js = sum $ map (countInvokations name) js
695
674
696
675
676+ countIDOccurences :: String -> JS -> Int
677+ countIDOccurences name = foldJS match (+) 0
678+ where
679+ match :: JS -> Int
680+ match js
681+ | JSIdent ident <- js
682+ , name == ident = 1
683+ | otherwise = 0
684+
685+
697 countInvokations :: String -> JS -> Int
686 countInvokations :: String -> JS -> Int
698 countInvokations name = foldJS match (+) 0
687 countInvokations name = foldJS match (+) 0
699 where
688 where
@@ -785,10 +774,10 @@ optimizeRuntimeCalls fun tc js =
785 JSSeq [ JSAlloc "ret" $ Just (
774 JSSeq [ JSAlloc "ret" $ Just (
786 JSTernary (
775 JSTernary (
787 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
776 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
788− (hasProp "__IDRLT__mEVAL0" "arg0")
777+ (hasProp "__IDRLT__EVAL" "arg0")
789 ) (JSApp
778 ) (JSApp
790 (JSIndex
779 (JSIndex
791− (JSIdent "__IDRLT__mEVAL0")
780+ (JSIdent "__IDRLT__EVAL")
792 (JSProj (JSIdent "arg0") "tag")
781 (JSProj (JSIdent "arg0") "tag")
793 )
782 )
794 [JSIdent "arg0"]
783 [JSIdent "arg0"]
@@ -811,10 +800,10 @@ optimizeRuntimeCalls fun tc js =
811 , JSAlloc "ret" $ Just (
800 , JSAlloc "ret" $ Just (
812 JSTernary (
801 JSTernary (
813 (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
802 (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
814− (hasProp "__IDRLT__mAPPLY0" "ev")
803+ (hasProp "__IDRLT__APPLY" "ev")
815 ) (JSApp
804 ) (JSApp
816 (JSIndex
805 (JSIndex
817− (JSIdent "__IDRLT__mAPPLY0")
806+ (JSIdent "__IDRLT__APPLY")
818 (JSProj (JSIdent "ev") "tag")
807 (JSProj (JSIdent "ev") "tag")
819 )
808 )
820 [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
809 [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
@@ -837,8 +826,8 @@ optimizeRuntimeCalls fun tc js =
837
826
838unfoldLookupTable :: [JS] -> [JS]
827unfoldLookupTable :: [JS] -> [JS]
839unfoldLookupTable input =
828unfoldLookupTable input =
840− let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
829+ let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
841− (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
830+ (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
842 js = applyunfold in
831 js = applyunfold in
843 adaptRuntime $ expandCons evals applys js
832 adaptRuntime $ expandCons evals applys js
844 where
833 where
@@ -848,12 +837,12 @@ unfoldLookupTable input =
848
837
849
838
850 adaptApply var = map (jsSubst (
839 adaptApply var = map (jsSubst (
851− JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag")
840+ JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
852 ) (JSProj (JSIdent var) "app"))
841 ) (JSProj (JSIdent var) "app"))
853
842
854
843
855 adaptEval = map (jsSubst (
844 adaptEval = map (jsSubst (
856− JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag")
845+ JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
857 ) (JSProj (JSIdent "arg0") "eval"))
846 ) (JSProj (JSIdent "arg0") "eval"))
858
847
859
848
@@ -893,8 +882,8 @@ unfoldLookupTable input =
893 where
882 where
894 expandCons' :: JS -> JS
883 expandCons' :: JS -> JS
895 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
884 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
896− | evalid <- getId "__IDRLT__mEVAL0" tag evals
885+ | evalid <- getId "__IDRLT__EVAL" tag evals
897− , applyid <- getId "__IDRLT__mAPPLY0" tag applys =
886+ , applyid <- getId "__IDRLT__APPLY" tag applys =
898 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
887 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
899 , maybe JSNull JSIdent evalid
888 , maybe JSNull JSIdent evalid
900 , maybe JSNull JSIdent applyid
889 , maybe JSNull JSIdent applyid
@@ -911,8 +900,8 @@ unfoldLookupTable input =
911
900
912
901
913 ltIdentifier :: String -> Int -> String
902 ltIdentifier :: String -> Int -> String
914− ltIdentifier "__IDRLT__mEVAL0" id = idrLTNamespace ++ "EVAL" ++ show id
903+ ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
915− ltIdentifier "__IDRLT__mAPPLY0" id = idrLTNamespace ++ "APPLY" ++ show id
904+ ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
916
905
917
906
918 extractLT :: String -> [JS] -> (JS, [JS])
907 extractLT :: String -> [JS] -> (JS, [JS])
@@ -1227,7 +1216,7 @@ translateDeclaration (path, SFun name params stackSize body)
1227 lookup t = (JSApp
1216 lookup t = (JSApp
1228 (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1217 (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1229 [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1218 [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1230− [ lookupTable [(var, "chk")] var cases
1219+ [ lookupTable "APPLY" [(var, "chk")] var cases
1231 , jsDecl $ JSFunction ["fn0", "arg0"] (
1220 , jsDecl $ JSFunction ["fn0", "arg0"] (
1232 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1221 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1233 , JSAlloc (translateVariableName var) (
1222 , JSAlloc (translateVariableName var) (
@@ -1235,8 +1224,8 @@ translateDeclaration (path, SFun name params stackSize body)
1235 )
1224 )
1236 , JSReturn $ (JSTernary (
1225 , JSReturn $ (JSTernary (
1237 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1226 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1238− (hasProp lookupTableName (translateVariableName var))
1227+ (hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))
1239− ) (lookup lookupTableName) JSNull)
1228+ ) (lookup (idrLTNamespace ++ "APPLY")) JSNull)
1240 ]
1229 ]
1241 )
1230 )
1242 ]
1231 ]
@@ -1244,13 +1233,13 @@ translateDeclaration (path, SFun name params stackSize body)
1244 | (MN _ ev) <- name
1233 | (MN _ ev) <- name
1245 , (SChkCase var cases) <- body
1234 , (SChkCase var cases) <- body
1246 , ev == txt "EVAL" =
1235 , ev == txt "EVAL" =
1247− [ lookupTable [] var cases
1236+ [ lookupTable "EVAL" [] var cases
1248 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1237 , jsDecl $ JSFunction ["arg0"] (JSReturn $
1249 JSTernary (
1238 JSTernary (
1250 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1239 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1251− (hasProp lookupTableName "arg0")
1240+ (hasProp (idrLTNamespace ++ "EVAL") "arg0")
1252 ) (JSApp
1241 ) (JSApp
1253− (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1242+ (JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))
1254 [JSIdent "arg0"]
1243 [JSIdent "arg0"]
1255 ) (JSIdent "arg0")
1244 ) (JSIdent "arg0")
1256 )
1245 )
@@ -1276,13 +1265,9 @@ translateDeclaration (path, SFun name params stackSize body)
1276 getTag _ = Nothing
1265 getTag _ = Nothing
1277
1266
1278
1267
1279− lookupTableName :: String
1280− lookupTableName = idrLTNamespace ++ translateName name
1281−
1282−
1283− lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
1268+ lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1284− lookupTable aux var cases =
1269+ lookupTable table aux var cases =
1285− JSAlloc lookupTableName $ Just (
1270+ JSAlloc (idrLTNamespace ++ table) $ Just (
1286 JSApp (JSFunction [] (
1271 JSApp (JSFunction [] (
1287 JSSeq $ [
1272 JSSeq $ [
1288 JSAlloc "t" $ Just (JSArray [])
1273 JSAlloc "t" $ Just (JSArray [])