@@ -59,7 +59,9 @@ data JS = JSRaw String
5959 | JSApp JS [JS]
6060 | JSNew String [JS]
6161 | JSError String
62− | JSOp String JS JS
62+ | JSBinOp String JS JS
63+ | JSPreOp String JS
64+ | JSPostOp String JS
6365 | JSProj JS String
6466 | JSVar LVar
6567 | JSNull
@@ -76,6 +78,7 @@ data JS = JSRaw String
7678 | JSCond [(JS, JS)]
7779 | JSTernary JS JS JS
7880 | JSParens JS
81+ | JSWhile JS JS
7982 deriving Eq
8083
8184
@@ -122,7 +125,7 @@ compileJS (JSNew name args) =
122125compileJS (JSError exc) =
123126 "throw new Error(\"" ++ exc ++ "\")"
124127
125−compileJS (JSOp op lhs rhs) =
128+compileJS (JSBinOp op lhs rhs) =
126129 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
127130
128131compileJS (JSProj obj field)
@@ -194,6 +197,10 @@ compileJS (JSTernary cond true false) =
194197compileJS (JSParens js) =
195198 "(" ++ compileJS js ++ ")"
196199
200+compileJS (JSWhile cond body) =
201+ "while (" ++ compileJS cond ++ ") {\n"
202+ ++ compileJS body
203+ ++ "\n}"
197204
198205jsTailcall :: JS -> JS
199206jsTailcall call =
@@ -212,15 +219,15 @@ jsMeth obj meth =
212219
213220
214221jsInstanceOf :: JS -> JS -> JS
215−jsInstanceOf = JSOp "instanceof"
222+jsInstanceOf = JSBinOp "instanceof"
216223
217224
218225jsEq :: JS -> JS -> JS
219−jsEq = JSOp "=="
226+jsEq = JSBinOp "=="
220227
221228
222229jsAnd :: JS -> JS -> JS
223−jsAnd = JSOp "&&"
230+jsAnd = JSBinOp "&&"
224231
225232
226233jsType :: JS
@@ -277,8 +284,12 @@ foldJS tr add acc js =
277284 add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
278285 | JSNew _ args <- js =
279286 add (tr js) $ foldl' add acc $ map fold args
280− | JSOp _ lhs rhs <- js =
287+ | JSBinOp _ lhs rhs <- js =
281288 add (tr js) $ add (fold lhs) (fold rhs)
289+ | JSPreOp _ val <- js =
290+ add (tr js) $ fold val
291+ | JSPostOp _ val <- js =
292+ add (tr js) $ fold val
282293 | JSProj obj _ <- js =
283294 add (tr js) (fold obj)
284295 | JSArray vals <- js =
@@ -295,6 +306,8 @@ foldJS tr add acc js =
295306 add (tr js) $ fold val
296307 | JSCond conds <- js =
297308 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
309+ | JSWhile cond body <- js =
310+ add (tr js) $ add (fold cond) (fold body)
298311 | otherwise =
299312 tr js
300313
@@ -310,7 +323,9 @@ transformJS tr js =
310323 | JSReturn ret <- js = JSReturn $ tr ret
311324 | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
312325 | JSNew con args <- js = JSNew con $ map tr args
313− | JSOp op lhs rhs <- js = JSOp op (tr lhs) (tr rhs)
326+ | JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
327+ | JSPreOp op val <- js = JSPreOp op (tr val)
328+ | JSPostOp op val <- js = JSPostOp op (tr val)
314329 | JSProj obj field <- js = JSProj (tr obj) field
315330 | JSArray vals <- js = JSArray $ map tr vals
316331 | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
@@ -319,9 +334,21 @@ transformJS tr js =
319334 | JSCond conds <- js = JSCond $ map (tr *** tr) conds
320335 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
321336 | JSParens val <- js = JSParens $ tr val
337+ | JSWhile cond body <- js = JSWhile(tr cond) (tr body)
322338 | otherwise = js
323339
324340
341+moveJSDeclToTop :: String -> [JS] -> [JS]
342+moveJSDeclToTop decl js = move ([], js)
343+ where
344+ move :: ([JS], [JS]) -> [JS]
345+ move (front, js@(JSAlloc name _):back)
346+ | name == decl = js : front ++ back
347+
348+ move (front, js:back) =
349+ move (front ++ [js], back)
350+
351+
325352jsSubst :: JS -> JS -> JS -> JS
326353jsSubst var new old
327354 | var == old = new
@@ -454,9 +481,9 @@ inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
454481 ) field
455482 ) (inlineJS $ jsSubst (JSIdent arg) opt idx)
456483
457− | JSOp op lhs rhs <- ret
484+ | JSBinOp op lhs rhs <- ret
458485 , opt <- inlineJS val =
459− inlineJS $ JSOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
486+ inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
460487 (inlineJS $ jsSubst (JSIdent arg) opt rhs)
461488
462489 | JSApp (JSIdent fun) args <- ret
@@ -518,8 +545,12 @@ deadEvalApplyCases js =
518545initConstructors :: [JS] -> [JS]
519546initConstructors js =
520547 let tags = nub $ sort $ concat (map getTags js) in
521− map createConstant tags ++ replaceConstructors tags js
548+ rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
522549 where
550+ rearrangePrelude :: [JS] -> [JS]
551+ rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
552+
553+
523554 getTags :: JS -> [Int]
524555 getTags = foldJS match (++) []
525556 where
@@ -670,6 +701,8 @@ inlineFunctions js =
670701 match js
671702 | JSApp (JSIdent ident) _ <- js
672703 , name == ident = 1
704+ | JSNew con _ <- js
705+ , name == con = 1
673706 | otherwise = 0
674707
675708
@@ -689,9 +722,9 @@ reduceConstant
689722 (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
690723 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
691724 )])
692− | JSNum num <- val = val
693− | JSOp op lhs rhs <- val =
694− JSParens $ JSOp op (reduceConstant lhs) (reduceConstant rhs)
725+ | JSNum num <- val = val
726+ | JSBinOp op lhs rhs <- val =
727+ JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
695728
696729 | JSApp (JSProj lhs op) [rhs] <- val
697730 , op `elem` [ "subtract"
@@ -733,9 +766,9 @@ elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
733766elimDuplicateEvals js = js
734767
735768
736−optimizeEvalTailcalls :: (String, String) -> JS -> JS
737−optimizeEvalTailcalls (fun, tc) js =
738− optHelper js
769+optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
770+optimizeRuntimeCalls fun tc js =
771+ optTC tc : map optHelper js
739772 where
740773 optHelper :: JS -> JS
741774 optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
@@ -746,6 +779,165 @@ optimizeEvalTailcalls (fun, tc) js =
746779 optHelper js = transformJS optHelper js
747780
748781
782+ optTC :: String -> JS
783+ optTC tc@"__IDRRT__EVALTC" =
784+ JSAlloc tc (Just $ JSFunction ["arg0"] (
785+ JSSeq [ JSAlloc "ret" $ Just (
786+ JSTernary (
787+ (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
788+ (hasProp "__IDRLT__mEVAL0" "arg0")
789+ ) (JSApp
790+ (JSIndex
791+ (JSIdent "__IDRLT__mEVAL0")
792+ (JSProj (JSIdent "arg0") "tag")
793+ )
794+ [JSIdent "arg0"]
795+ ) (JSIdent "arg0")
796+ )
797+ , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
798+ JSAssign (JSIdent "ret") (
799+ JSApp (JSProj (JSIdent "ret") "k") []
800+ )
801+ )
802+ , JSReturn $ JSIdent "ret"
803+ ]
804+ ))
805+
806+ optTC tc@"__IDRRT__APPLYTC" =
807+ JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
808+ JSSeq [ JSAlloc "ev" $ Just (JSApp
809+ (JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
810+ )
811+ , JSAlloc "ret" $ Just (
812+ JSTernary (
813+ (JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
814+ (hasProp "__IDRLT__mAPPLY0" "ev")
815+ ) (JSApp
816+ (JSIndex
817+ (JSIdent "__IDRLT__mAPPLY0")
818+ (JSProj (JSIdent "ev") "tag")
819+ )
820+ [JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
821+ ) JSNull
822+ )
823+ , JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
824+ JSAssign (JSIdent "ret") (
825+ JSApp (JSProj (JSIdent "ret") "k") []
826+ )
827+ )
828+ , JSReturn $ JSIdent "ret"
829+ ]
830+ ))
831+
832+
833+ hasProp :: String -> String -> JS
834+ hasProp table var =
835+ JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
836+
837+
838+unfoldLookupTable :: [JS] -> [JS]
839+unfoldLookupTable input =
840+ let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
841+ (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
842+ js = applyunfold in
843+ adaptRuntime $ expandCons evals applys js
844+ where
845+ adaptRuntime :: [JS] -> [JS]
846+ adaptRuntime =
847+ adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
848+
849+
850+ adaptApply var = map (jsSubst (
851+ JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag")
852+ ) (JSProj (JSIdent var) "app"))
853+
854+
855+ adaptEval = map (jsSubst (
856+ JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag")
857+ ) (JSProj (JSIdent "arg0") "eval"))
858+
859+
860+ adaptCon js =
861+ adaptCon' [] js
862+ where
863+ adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
864+ front ++ (new:back)
865+
866+ adaptCon' front (next:back) =
867+ adaptCon' (front ++ [next]) back
868+
869+ adaptCon' front [] = front
870+
871+
872+ new =
873+ JSAlloc "__IDRRT__Con" (Just $
874+ JSFunction newArgs (
875+ JSSeq (map newVar newArgs)
876+ )
877+ )
878+ where
879+ newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
880+ newArgs = ["tag", "eval", "app", "vars"]
881+
882+
883+ unfoldLT :: String -> [JS] -> ([Int], [JS])
884+ unfoldLT lt js =
885+ let (table, code) = extractLT lt js
886+ expanded = expandLT lt table in
887+ (map fst expanded, map snd expanded ++ code)
888+
889+
890+ expandCons :: [Int] -> [Int] -> [JS] -> [JS]
891+ expandCons evals applys js =
892+ map expandCons' js
893+ where
894+ expandCons' :: JS -> JS
895+ expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
896+ | evalid <- getId "__IDRLT__mEVAL0" tag evals
897+ , applyid <- getId "__IDRLT__mAPPLY0" tag applys =
898+ JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
899+ , maybe JSNull JSIdent evalid
900+ , maybe JSNull JSIdent applyid
901+ , JSArray (map expandCons' args)
902+ ]
903+
904+ expandCons' js = transformJS expandCons' js
905+
906+
907+ getId :: String -> Int -> [Int] -> Maybe String
908+ getId lt tag entries
909+ | tag `elem` entries = Just $ ltIdentifier lt tag
910+ | otherwise = Nothing
911+
912+
913+ ltIdentifier :: String -> Int -> String
914+ ltIdentifier "__IDRLT__mEVAL0" id = idrLTNamespace ++ "EVAL" ++ show id
915+ ltIdentifier "__IDRLT__mAPPLY0" id = idrLTNamespace ++ "APPLY" ++ show id
916+
917+
918+ extractLT :: String -> [JS] -> (JS, [JS])
919+ extractLT lt js =
920+ extractLT' ([], js)
921+ where
922+ extractLT' :: ([JS], [JS]) -> (JS, [JS])
923+ extractLT' (front, js@(JSAlloc fun _):back)
924+ | fun == lt = (js, front ++ back)
925+
926+ extractLT' (front, js:back) = extractLT' (front ++ [js], back)
927+
928+
929+ expandLT :: String -> JS -> [(Int, JS)]
930+ expandLT lt (
931+ JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
932+ ) = catMaybes (map expandEntry seq)
933+ where
934+ expandEntry :: JS -> Maybe (Int, JS)
935+ expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
936+ Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
937+
938+ expandEntry js = Nothing
939+
940+
749941removeInstanceChecks :: JS -> JS
750942removeInstanceChecks (JSCond conds) =
751943 JSCond $ eliminateDeadBranches $ map (
@@ -753,7 +945,7 @@ removeInstanceChecks (JSCond conds) =
753945 ) conds
754946 where
755947 removeHelper (
756− JSOp "&&" (JSOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
948+ JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
757949 ) = removeHelper check
758950 removeHelper js = js
759951
@@ -854,9 +1046,12 @@ codegenJavaScript target definitions filename outputType = do
8541046 functions :: [String]
8551047 functions = translate >>> optimize >>> compile $ def
8561048 where
857− translate p = concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
858− optimize p = foldl' (flip ($)) p opt
859− compile = map compileJS
1049+ translate p =
1050+ prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
1051+ optimize p =
1052+ foldl' (flip ($)) p opt
1053+ compile =
1054+ map compileJS
8601055
8611056 opt =
8621057 [ map optimizeJS
@@ -867,13 +1062,25 @@ codegenJavaScript target definitions filename outputType = do
8671062 , map removeAllocations
8681063 , elimDeadLoop
8691064 , map elimDuplicateEvals
870− , map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC"))
871− , map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC"))
1065+ , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1066+ , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
8721067 , map removeInstanceChecks
8731068 , inlineFunctions
8741069 , map reduceContinuations
1070+ , unfoldLookupTable
8751071 ]
8761072
1073+ prelude :: [JS]
1074+ prelude =
1075+ [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
1076+ JSAssign (JSProj JSThis "k") (JSIdent "k")
1077+ ))
1078+ , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
1079+ JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
1080+ , JSAssign (JSProj JSThis "vars") (JSIdent "vars")
1081+ ]
1082+ ))
1083+ ]
8771084
8781085 mainLoop :: JS
8791086 mainLoop =
@@ -1016,8 +1223,10 @@ translateDeclaration (path, SFun name params stackSize body)
10161223 , (SLet var val next) <- body
10171224 , (SChkCase cvar cases) <- next
10181225 , ap == txt "APPLY" =
1019− let lvar = translateVariableName var
1020− lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
1226+ let lvar = translateVariableName var
1227+ lookup t = (JSApp
1228+ (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1229+ [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
10211230 [ lookupTable [(var, "chk")] var cases
10221231 , jsDecl $ JSFunction ["fn0", "arg0"] (
10231232 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
@@ -1027,10 +1236,7 @@ translateDeclaration (path, SFun name params stackSize body)
10271236 , JSReturn $ (JSTernary (
10281237 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
10291238 (hasProp lookupTableName (translateVariableName var))
1030− ) (JSIdent $
1031− lookupTableName ++ lookup
1032− ) JSNull
1033− )
1239+ ) (lookup lookupTableName) JSNull)
10341240 ]
10351241 )
10361242 ]
@@ -1306,7 +1512,7 @@ translateExpression (SOp op vars)
13061512
13071513 where
13081514 translateBinaryOp :: String -> LVar -> LVar -> JS
1309− translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
1515+ translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
13101516
13111517
13121518 invokeMeth :: LVar -> String -> [LVar] -> JS