@@ -20,9 +20,10 @@ import System.IO
2020import System.Directory
2121
2222idrNamespace :: String
23−idrNamespace = "__IDR__"
24−idrRTNamespace = "__IDRRT__"
25−idrLTNamespace = "__IDRLT__"
23+idrNamespace = "__IDR__"
24+idrRTNamespace = "__IDRRT__"
25+idrLTNamespace = "__IDRLT__"
26+idrCTRNamespace = "__IDRCTR__"
2627
2728
2829data JSTarget = Node | JavaScript deriving Eq
@@ -564,14 +565,14 @@ initConstructors js =
564565 where
565566 replaceHelper :: [Int] -> JS -> JS
566567 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)
568569
569570 replaceHelper tags js = transformJS (replaceHelper tags) js
570571
571572
572573 createConstant :: Int -> JS
573574 createConstant tag =
574− JSAlloc ("__IDRCTR__" ++ show tag) (Just (
575+ JSAlloc (idrCTRNamespace ++ show tag) (Just (
575576 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
576577 ))
577578
@@ -632,33 +633,11 @@ inlineFunctions js =
632633
633634
634635 inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
635− inlineAble 1 fun args body
636+ inlineAble 1 fun args (JSReturn body)
636637 | nonRecur fun body =
637− inlineAble' body
638− where
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
658−
659− isJSIdent js
660− | JSIdent _ <- js = True
661− | otherwise = False
638+ if all (<= 1) (map ($ body) (map countIDOccurences args))
639+ then Just body
640+ else Nothing
662641
663642 inlineAble _ _ _ _ = Nothing
664643
@@ -694,6 +673,16 @@ inlineFunctions js =
694673 countAll name js = sum $ map (countInvokations name) js
695674
696675
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+
697686 countInvokations :: String -> JS -> Int
698687 countInvokations name = foldJS match (+) 0
699688 where
@@ -785,10 +774,10 @@ optimizeRuntimeCalls fun tc js =
785774 JSSeq [ JSAlloc "ret" $ Just (
786775 JSTernary (
787776 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
788− (hasProp "__IDRLT__mEVAL0" "arg0")
777+ (hasProp "__IDRLT__EVAL" "arg0")
789778 ) (JSApp
790779 (JSIndex
791− (JSIdent "__IDRLT__mEVAL0")
780+ (JSIdent "__IDRLT__EVAL")
792781 (JSProj (JSIdent "arg0") "tag")
793782 )
794783 [JSIdent "arg0"]
@@ -811,10 +800,10 @@ optimizeRuntimeCalls fun tc js =
811800 , JSAlloc "ret" $ Just (
812801 JSTernary (
813802 (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
814− (hasProp "__IDRLT__mAPPLY0" "ev")
803+ (hasProp "__IDRLT__APPLY" "ev")
815804 ) (JSApp
816805 (JSIndex
817− (JSIdent "__IDRLT__mAPPLY0")
806+ (JSIdent "__IDRLT__APPLY")
818807 (JSProj (JSIdent "ev") "tag")
819808 )
820809 [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
@@ -837,8 +826,8 @@ optimizeRuntimeCalls fun tc js =
837826
838827unfoldLookupTable :: [JS] -> [JS]
839828unfoldLookupTable input =
840− let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
841− (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
829+ let (evals, evalunfold) = unfoldLT "__IDRLT__EVAL" input
830+ (applys, applyunfold) = unfoldLT "__IDRLT__APPLY" evalunfold
842831 js = applyunfold in
843832 adaptRuntime $ expandCons evals applys js
844833 where
@@ -848,12 +837,12 @@ unfoldLookupTable input =
848837
849838
850839 adaptApply var = map (jsSubst (
851− JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag")
840+ JSIndex (JSIdent "__IDRLT__APPLY") (JSProj (JSIdent var) "tag")
852841 ) (JSProj (JSIdent var) "app"))
853842
854843
855844 adaptEval = map (jsSubst (
856− JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag")
845+ JSIndex (JSIdent "__IDRLT__EVAL") (JSProj (JSIdent "arg0") "tag")
857846 ) (JSProj (JSIdent "arg0") "eval"))
858847
859848
@@ -893,8 +882,8 @@ unfoldLookupTable input =
893882 where
894883 expandCons' :: JS -> JS
895884 expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
896− | evalid <- getId "__IDRLT__mEVAL0" tag evals
897− , applyid <- getId "__IDRLT__mAPPLY0" tag applys =
885+ | evalid <- getId "__IDRLT__EVAL" tag evals
886+ , applyid <- getId "__IDRLT__APPLY" tag applys =
898887 JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
899888 , maybe JSNull JSIdent evalid
900889 , maybe JSNull JSIdent applyid
@@ -911,8 +900,8 @@ unfoldLookupTable input =
911900
912901
913902 ltIdentifier :: String -> Int -> String
914− ltIdentifier "__IDRLT__mEVAL0" id = idrLTNamespace ++ "EVAL" ++ show id
915− ltIdentifier "__IDRLT__mAPPLY0" id = idrLTNamespace ++ "APPLY" ++ show id
903+ ltIdentifier "__IDRLT__EVAL" id = idrLTNamespace ++ "EVAL" ++ show id
904+ ltIdentifier "__IDRLT__APPLY" id = idrLTNamespace ++ "APPLY" ++ show id
916905
917906
918907 extractLT :: String -> [JS] -> (JS, [JS])
@@ -1227,7 +1216,7 @@ translateDeclaration (path, SFun name params stackSize body)
12271216 lookup t = (JSApp
12281217 (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
12291218 [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1230− [ lookupTable [(var, "chk")] var cases
1219+ [ lookupTable "APPLY" [(var, "chk")] var cases
12311220 , jsDecl $ JSFunction ["fn0", "arg0"] (
12321221 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
12331222 , JSAlloc (translateVariableName var) (
@@ -1235,8 +1224,8 @@ translateDeclaration (path, SFun name params stackSize body)
12351224 )
12361225 , JSReturn $ (JSTernary (
12371226 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1238− (hasProp lookupTableName (translateVariableName var))
1239− ) (lookup lookupTableName) JSNull)
1227+ (hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))
1228+ ) (lookup (idrLTNamespace ++ "APPLY")) JSNull)
12401229 ]
12411230 )
12421231 ]
@@ -1244,13 +1233,13 @@ translateDeclaration (path, SFun name params stackSize body)
12441233 | (MN _ ev) <- name
12451234 , (SChkCase var cases) <- body
12461235 , ev == txt "EVAL" =
1247− [ lookupTable [] var cases
1236+ [ lookupTable "EVAL" [] var cases
12481237 , jsDecl $ JSFunction ["arg0"] (JSReturn $
12491238 JSTernary (
12501239 (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1251− (hasProp lookupTableName "arg0")
1240+ (hasProp (idrLTNamespace ++ "EVAL") "arg0")
12521241 ) (JSApp
1253− (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1242+ (JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))
12541243 [JSIdent "arg0"]
12551244 ) (JSIdent "arg0")
12561245 )
@@ -1276,13 +1265,9 @@ translateDeclaration (path, SFun name params stackSize body)
12761265 getTag _ = Nothing
12771266
12781267
1279− lookupTableName :: String
1280− lookupTableName = idrLTNamespace ++ translateName name
1281−
1282−
1283− lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
1284− lookupTable aux var cases =
1285− JSAlloc lookupTableName $ Just (
1268+ lookupTable :: String -> [(LVar, String)] -> LVar -> [SAlt] -> JS
1269+ lookupTable table aux var cases =
1270+ JSAlloc (idrLTNamespace ++ table) $ Just (
12861271 JSApp (JSFunction [] (
12871272 JSSeq $ [
12881273 JSAlloc "t" $ Just (JSArray [])