@@ -409,13 +409,30 @@ removeAllocations js = transformJS removeAllocations js
409409
410410isJSConstant :: JS -> Bool
411411isJSConstant js
412− | JSString _ <- js = True
413− | JSChar _ <- js = True
414− | JSNum _ <- js = True
415− | JSType _ <- js = True
416− | JSNull <- js = True
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
417418
418419 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
420+
421+ | otherwise = False
422+
423+isJSConstantConstructor :: [String] -> JS -> Bool
424+isJSConstantConstructor 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
419436 | otherwise = False
420437
421438
@@ -1000,6 +1017,158 @@ optimizeJS = inlineLoop
10001017 | otherwise = js
10011018
10021019
1020+extractLocalConstructors :: [JS] -> [JS]
1021+extractLocalConstructors js =
1022+ concatMap extractLocalConstructors' js
1023+ where
1024+ globalCons :: [String]
1025+ globalCons = concatMap (getGlobalCons) js
1026+
1027+
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)
1038+
1039+ match :: JS -> [JS]
1040+ match js
1041+ | JSNew "__IDRRT__Con" args <- js
1042+ , all isConstant args = [js]
1043+ | otherwise = []
1044+
1045+
1046+ allocCon :: (JS, JS) -> JS
1047+ allocCon (js, JSIdent name) =
1048+ JSAlloc name (Just js)
1049+
1050+
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
1058+
1059+ extractLocalConstructors' js = [js]
1060+
1061+
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+ []
1071+
1072+
1073+evalCons :: [JS] -> [JS]
1074+evalCons js =
1075+ map (collapseCont . collapseTC . expandProj . evalCons') js
1076+ where
1077+ cons :: [(String, JS)]
1078+ cons = concatMap getGlobalCons js
1079+
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
1088+
1089+ match (JSApp (JSIdent "__IDR__mEVAL0") [arg])
1090+ | JSIdent name <- arg
1091+ , Just (JSNew _ [_, JSNull, _, _]) <- lookupConstructor name cons =
1092+ arg
1093+
1094+ match js = transformJS match js
1095+
1096+
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
1102+
1103+
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)
1113+ )
1114+ )
1115+ | Just (JSNew _ [_, _, _, JSArray args]) <- lookup name cons =
1116+ args !! idx
1117+
1118+ match js = transformJS match js
1119+
1120+
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)
1129+
1130+ match js = transformJS match js
1131+
1132+
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
1140+
1141+
1142+ match (JSNew "__IDRRT__Cont" [JSFunction [] (
1143+ JSReturn (JSIdent name)
1144+ )]) = JSIdent name
1145+
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
1154+
1155+
1156+ match js = transformJS match js
1157+
1158+
1159+getGlobalCons :: JS -> [(String, JS)]
1160+getGlobalCons 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+ []
1170+
1171+
10031172codegenJavaScript
10041173 :: JSTarget
10051174 -> [(Name, SDecl)]
@@ -1056,7 +1225,9 @@ codegenJavaScript target definitions filename outputType = do
10561225 , map removeInstanceChecks
10571226 , inlineFunctions
10581227 , map reduceContinuations
1228+ , extractLocalConstructors
10591229 , unfoldLookupTable
1230+ , evalCons
10601231 ]
10611232
10621233 prelude :: [JS]