@@ -258,20 +258,8 @@ jsSubst var new (JSIdent old)
258258jsSubst var new (JSArray fields) =
259259 JSArray (map (jsSubst var new) fields)
260260
261−jsSubst var new (JSNew con [tag, 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)
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− )]
261+jsSubst var new (JSNew con vals) =
262+ JSNew con $ map (jsSubst var new) vals
275263
276264jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
277265 | var `notElem` args =
@@ -283,9 +271,6 @@ jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
283271 map (jsSubst var new) vals
284272 )
285273
286−jsSubst var new (JSApp (JSProj obj field) args) =
287− JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
288−
289274jsSubst var new (JSApp (JSFunction [arg] body) vals)
290275 | var /= arg =
291276 JSApp (JSFunction [arg] (
@@ -296,6 +281,12 @@ jsSubst var new (JSApp (JSFunction [arg] body) vals)
296281 body
297282 )) $ map (jsSubst var new) vals
298283
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+
299290jsSubst var new (JSReturn ret) =
300291 JSReturn $ jsSubst var new ret
301292
@@ -317,9 +308,64 @@ jsSubst var new (JSCond conds) =
317308jsSubst var new (JSAssign lhs rhs) =
318309 JSAssign (jsSubst var new lhs) (jsSubst var new rhs)
319310
311+jsSubst var new (JSAlloc val (Just js)) =
312+ JSAlloc val (Just (jsSubst var new js))
313+
320314jsSubst _ _ js = js
321315
322316
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+
323369isJSConstant :: JS -> Bool
324370isJSConstant js
325371 | JSString _ <- js = True
@@ -386,13 +432,9 @@ inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
386432 JSOp op (jsSubst arg opt lhs) $
387433 (jsSubst arg opt rhs)
388434
389− | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
390− JSReturn (JSApp fun args)
391− )] <- ret
435+ | JSApp (JSIdent fun) args <- ret
392436 , opt <- inlineJS val =
393− JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
394− JSReturn $ JSApp (jsSubst arg opt fun) (map (jsSubst arg opt) args)
395− )]
437+ JSApp (JSIdent fun) $ map (jsSubst arg opt) args
396438
397439inlineJS (JSApp fun args) =
398440 JSApp (inlineJS fun) (map inlineJS args)
@@ -438,6 +480,62 @@ reduceJS js = reduceLoop [] ([], js)
438480funName :: JS -> String
439481funName (JSAlloc fun _) = fun
440482
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+
441539initConstructors :: [JS] -> [JS]
442540initConstructors js =
443541 let tags = nub $ sort $ concat (map getTags js) in
@@ -592,6 +690,92 @@ removeIDs js =
592690
593691 removeIDCall _ js = js
594692
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+
595779reduceConstant :: JS -> JS
596780reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
597781 JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])
@@ -736,7 +920,7 @@ codegenJavaScript target definitions filename outputType = do
736920 intercalate "\n" $ [ jsbn
737921 , idrRuntime
738922 , tgtRuntime
739− ] ++ functions ++ [mainLoop, invokeLoop]
923+ ] ++ functions
740924 )
741925
742926 setPermissions filename (emptyPermissions { readable = True
@@ -749,10 +933,21 @@ codegenJavaScript target definitions filename outputType = do
749933
750934 functions :: [String]
751935 functions =
752− map compileJS $ initConstructors (map reduceConstants ((reduceJS . removeIDs) $ map (optimizeJS . translateDeclaration) def))
753−
754− mainLoop :: String
755− mainLoop = compileJS $
936+ let translated =
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+
949+ mainLoop :: JS
950+ mainLoop =
756951 JSAlloc "main" $ Just $ JSFunction [] (
757952 case target of
758953 Node -> mainFun
@@ -769,8 +964,8 @@ codegenJavaScript target definitions filename outputType = do
769964 runMain :: String
770965 runMain = idrNamespace ++ translateName (sMN 0 "runMain")
771966
772− invokeLoop :: String
773− invokeLoop = compileJS $ jsCall "main" []
967+ invokeLoop :: JS
968+ invokeLoop = jsCall "main" []
774969
775970translateIdentifier :: String -> String
776971translateIdentifier =
@@ -876,7 +1071,7 @@ translateConstant (BI i) = jsBigInt $ JSString (show i)
8761071translateConstant c =
8771072 JSError $ "Unimplemented Constant: " ++ show c
8781073
879−translateDeclaration :: (String, SDecl) -> JS
1074+translateDeclaration :: (String, SDecl) -> [JS]
8801075translateDeclaration (path, SFun name params stackSize body)
8811076 | (MN _ ap) <- name
8821077 , (SLet var val next) <- body
@@ -884,37 +1079,40 @@ translateDeclaration (path, SFun name params stackSize body)
8841079 , ap == txt "APPLY" =
8851080 let lvar = translateVariableName var
8861081 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
887− JSSeq [ lookupTable [(var, "chk")] var cases
888− , jsDecl $ JSFunction ["fn0", "arg0"] (
889− JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
890− , JSAlloc (translateVariableName var) (
891− Just $ translateExpression val
892− )
893− , JSReturn $ (JSTernary (
894− (JSVar var `jsInstanceOf` jsCon) `jsAnd`
895− (hasProp lookupTableName (translateVariableName var))
896− ) (JSIdent $
897− lookupTableName ++ lookup
898− ) JSNull
899− )
900− ]
901− )
902− ]
1082+ [ lookupTable [(var, "chk")] var cases
1083+ , jsDecl $ JSFunction ["fn0", "arg0"] (
1084+ JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1085+ , JSAlloc (translateVariableName var) (
1086+ Just $ translateExpression val
1087+ )
1088+ , JSReturn $ (JSTernary (
1089+ (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1090+ (hasProp lookupTableName (translateVariableName var))
1091+ ) (JSIdent $
1092+ lookupTableName ++ lookup
1093+ ) JSNull
1094+ )
1095+ ]
1096+ )
1097+ ]
9031098
9041099 | (MN _ ev) <- name
9051100 , (SChkCase var cases) <- body
9061101 , ev == txt "EVAL" =
907− JSSeq [ lookupTable [] var cases
908− , jsDecl $ JSFunction ["arg0"] (JSReturn $
909− JSTernary (
910− (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
911− (hasProp lookupTableName "arg0")
912− ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
913− )
914− ]
1102+ [ lookupTable [] var cases
1103+ , jsDecl $ JSFunction ["arg0"] (JSReturn $
1104+ JSTernary (
1105+ (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1106+ (hasProp lookupTableName "arg0")
1107+ ) (JSApp
1108+ (JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
1109+ [JSIdent "arg0"]
1110+ ) (JSIdent "arg0")
1111+ )
1112+ ]
9151113 | otherwise =
9161114 let fun = translateExpression body in
917− jsDecl $ jsFun fun
1115+ [jsDecl $ jsFun fun]
9181116
9191117 where
9201118 hasProp :: String -> String -> JS