@@ -262,6 +262,43 @@ jsError :: String -> JS
262262jsError err = JSApp (JSFunction [] (JSError err)) []
263263
264264
265+foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
266+foldJS tr add acc js =
267+ fold js
268+ where
269+ fold js
270+ | JSFunction args body <- js =
271+ add (tr js) (fold body)
272+ | JSSeq seq <- js =
273+ add (tr js) $ foldl' add acc (map fold seq)
274+ | JSReturn ret <- js =
275+ add (tr js) (fold ret)
276+ | JSApp lhs rhs <- js =
277+ add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
278+ | JSNew _ args <- js =
279+ add (tr js) $ foldl' add acc $ map fold args
280+ | JSOp _ lhs rhs <- js =
281+ add (tr js) $ add (fold lhs) (fold rhs)
282+ | JSProj obj _ <- js =
283+ add (tr js) (fold obj)
284+ | JSArray vals <- js =
285+ add (tr js) $ foldl' add acc $ map fold vals
286+ | JSAssign lhs rhs <- js =
287+ add (tr js) $ add (fold lhs) (fold rhs)
288+ | JSIndex lhs rhs <- js =
289+ add (tr js) $ add (fold lhs) (fold rhs)
290+ | JSAlloc _ val <- js =
291+ add (tr js) $ fromMaybe acc $ fmap fold val
292+ | JSTernary c t f <- js =
293+ add (tr js) $ add (fold c) (add (fold t) (fold f))
294+ | JSParens val <- js =
295+ add (tr js) $ fold val
296+ | JSCond conds <- js =
297+ add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
298+ | otherwise =
299+ tr js
300+
301+
265302transformJS :: (JS -> JS) -> JS -> JS
266303transformJS tr js =
267304 transformHelper js
@@ -348,6 +385,7 @@ isJSConstant js
348385 | JSChar _ <- js = True
349386 | JSNum _ <- js = True
350387 | JSType _ <- js = True
388+ | JSNull <- js = True
351389
352390 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
353391 | otherwise = False
@@ -449,37 +487,11 @@ deadEvalApplyCases js =
449487 map (removeHelper tags) js
450488 where
451489 getTags :: JS -> [Int]
452− getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), args]) =
453− tag : getTags args
454−
455− getTags (JSNew _ args) = concatMap getTags args
456−
457− getTags (JSFunction _ body) = getTags body
458−
459− getTags (JSReturn ret) = getTags ret
460−
461− getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
462−
463− getTags (JSSeq seq) = concatMap getTags seq
464−
465− getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
466−
467− getTags (JSProj obj _) = getTags obj
468−
469− getTags (JSArray vals) = concatMap getTags vals
470−
471− getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
472−
473− getTags (JSAlloc _ (Just val)) = getTags val
474−
475− getTags (JSCond conds) =
476− concatMap (uncurry (++)) $ map (getTags *** getTags) conds
477−
478− getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
479−
480− getTags (JSParens js) = getTags js
481−
482− getTags js = []
490+ getTags = foldJS match (++) []
491+ where
492+ match js
493+ | JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
494+ | otherwise = []
483495
484496
485497 removeHelper :: [Int] -> JS -> JS
@@ -509,36 +521,11 @@ initConstructors js =
509521 map createConstant tags ++ replaceConstructors tags js
510522 where
511523 getTags :: JS -> [Int]
512− getTags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []]) = [tag]
513−
514− getTags (JSNew _ args) = concatMap getTags args
515−
516− getTags (JSFunction _ body) = getTags body
517−
518− getTags (JSReturn ret) = getTags ret
519−
520− getTags (JSApp lhs rhs) = getTags lhs ++ concatMap getTags rhs
521−
522− getTags (JSSeq seq) = concatMap getTags seq
523−
524− getTags (JSOp _ lhs rhs) = getTags lhs ++ getTags rhs
525−
526− getTags (JSProj obj _) = getTags obj
527−
528− getTags (JSArray vals) = concatMap getTags vals
529−
530− getTags (JSAssign lhs rhs) = getTags lhs ++ getTags rhs
531−
532− getTags (JSAlloc _ (Just val)) = getTags val
533−
534− getTags (JSCond conds) =
535− concatMap (uncurry (++)) $ map (getTags *** getTags) conds
536−
537− getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f
538−
539− getTags (JSParens js) = getTags js
540−
541− getTags js = []
524+ getTags = foldJS match (++) []
525+ where
526+ match js
527+ | JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
528+ | otherwise = []
542529
543530
544531 replaceConstructors :: [Int] -> [JS] -> [JS]
@@ -597,91 +584,104 @@ removeIDs js =
597584
598585inlineFunctions :: [JS] -> [JS]
599586inlineFunctions js =
600− let funs = collectFunctions js
601− occurences = map ((id . fst) &&& countAll js) funs in
602− removeDeadFunctions occurences js
587+ inlineHelper ([], js)
588+ where
589+ inlineHelper :: ([JS], [JS]) -> [JS]
590+ inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
591+ | countAll fun front + countAll fun back == 0 =
592+ inlineHelper (front, back)
593+ | Just new <- inlineAble (
594+ countAll fun front + countAll fun back
595+ ) fun args body =
596+ let f = map (inline fun args new) in
597+ inlineHelper (f front, f back)
598+
599+ inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
600+ inlineHelper (front, []) = front
601+
602+
603+ inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
604+ inlineAble 1 fun args body
605+ | nonRecur fun body =
606+ inlineAble' body
607+ where
608+ inlineAble' :: JS -> Maybe JS
609+ inlineAble' (
610+ JSReturn js@(JSNew "__IDRRT__Con" [JSNum _, JSArray vals])
611+ )
612+ | and $ map (\x -> isJSIdent x || isJSConstant x) vals = Just js
613+
614+ inlineAble' (
615+ JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] (
616+ JSReturn (JSApp (JSIdent _) args)
617+ )])
618+ )
619+ | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
620+
621+ inlineAble' (
622+ JSReturn js@(JSIndex (JSProj (JSApp (JSIdent _) args) "vars") _)
623+ )
624+ | and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
625+
626+ inlineAble' _ = Nothing
627+
628+ isJSIdent js
629+ | JSIdent _ <- js = True
630+ | otherwise = False
631+
632+ inlineAble _ _ _ _ = Nothing
633+
634+
635+ inline :: String -> [String] -> JS -> JS -> JS
636+ inline fun args body js = inline' js
603637 where
604− removeDeadFunctions :: [(String, (Int, JS))] -> [JS] -> [JS]
605− removeDeadFunctions _ [] = []
606− removeDeadFunctions funOccur ((JSAlloc fun (Just (JSFunction _ _))):js)
607− | Just (o, _) <- lookup fun funOccur
608− , o == 0 = removeDeadFunctions funOccur js
609−
610− removeDeadFunctions funOccur (j:js) = j : removeDeadFunctions funOccur js
611−
612−
613− collectFunctions :: [JS] -> [(String, JS)]
614− collectFunctions js =
615− catMaybes $ map collectHelper js
616−
617−
618− collectHelper :: JS -> Maybe (String, JS)
619− collectHelper (JSAlloc fun (Just js@(JSFunction _ body)))
620− | fun /= "main" && nonRecur fun body = Just (fun, js)
621− collectHelper _ = Nothing
622−
623−
624− nonRecur :: String -> JS -> Bool
625− nonRecur name body = countInvokations name body == 0
638+ inline' :: JS -> JS
639+ inline' (JSApp (JSIdent name) vals)
640+ | name == fun =
641+ let (js, phs) = insertPlaceHolders args body in
642+ inline' $ foldr (uncurry jsSubst) js (zip phs vals)
626643
644+ inline' js = transformJS inline' js
627645
628− countAll :: [JS] -> (String, JS) -> (Int, JS)
629− countAll js (name, fun) = (sum $ map (countInvokations name) js, fun)
630−
631−
632− countInvokations :: String -> JS -> Int
633− countInvokations name (JSApp (JSIdent ident) args)
634− | name == ident = 1 + (sum $ map (countInvokations name) args)
635− | otherwise = sum $ map (countInvokations name) args
636−
637− countInvokations name (JSApp lhs rhs) =
638− countInvokations name lhs + (sum $ map (countInvokations name) rhs)
639−
640− countInvokations name (JSFunction _ body) =
641− countInvokations name body
642−
643− countInvokations name (JSSeq seq) =
644− sum $ map (countInvokations name) seq
645−
646− countInvokations name (JSReturn ret) =
647− countInvokations name ret
648−
649− countInvokations name (JSNew _ args) =
650− sum $ map (countInvokations name) args
646+ insertPlaceHolders :: [String] -> JS -> (JS, [JS])
647+ insertPlaceHolders args body = insertPlaceHolders' args body []
648+ where
649+ insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
650+ insertPlaceHolders' (a:as) body ph
651+ | (body', ph') <- insertPlaceHolders' as body ph =
652+ let phvar = JSIdent $ "__PH_" ++ show (length ph') in
653+ (jsSubst (JSIdent a) phvar body', phvar : ph')
651654
652− countInvokations name (JSOp _ lhs rhs) =
653− countInvokations name lhs + countInvokations name rhs
655+ insertPlaceHolders' [] body ph = (body, ph)
654656
655− countInvokations name (JSProj obj _) =
656− countInvokations name obj
657657
658− countInvokations name (JSArray vals) =
659− sum $ map (countInvokations name) vals
658+ nonRecur :: String -> JS -> Bool
659+ nonRecur name body = countInvokations name body == 0
660660
661− countInvokations name (JSAssign _ rhs) =
662− countInvokations name rhs
663661
664− countInvokations name (JSAlloc _ (Just js)) =
665− countInvokations name js
662+ countAll :: String -> [JS] -> Int
663+ countAll name js = sum $ map (countInvokations name) js
666664
667− countInvokations name (JSIndex lhs rhs) =
668− countInvokations name lhs + countInvokations name rhs
669665
670− countInvokations name (JSCond conds) =
671− sum $ map (uncurry (+)) (
672− map (countInvokations name *** countInvokations name) conds
673− )
666+ countInvokations :: String -> JS -> Int
667+ countInvokations name = foldJS match (+) 0
668+ where
669+ match :: JS -> Int
670+ match js
671+ | JSApp (JSIdent ident) _ <- js
672+ , name == ident = 1
673+ | otherwise = 0
674674
675− countInvokations name (JSTernary c t f) =
676− sum $ [ countInvokations name c
677− , countInvokations name t
678− , countInvokations name f
679− ]
680675
681− countInvokations name (JSParens js) =
682− countInvokations name js
676+reduceContinuations :: JS -> JS
677+reduceContinuations = transformJS reduceHelper
678+ where
679+ reduceHelper :: JS -> JS
680+ reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
681+ JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
682+ )]) = js
683683
684− countInvokations _ _ = 0
684+ reduceHelper js = transformJS reduceHelper js
685685
686686
687687reduceConstant :: JS -> JS
@@ -866,11 +866,12 @@ codegenJavaScript target definitions filename outputType = do
866866 , initConstructors
867867 , map removeAllocations
868868 , elimDeadLoop
869− , inlineFunctions
870869 , map elimDuplicateEvals
871870 , map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC"))
872871 , map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC"))
873872 , map removeInstanceChecks
873+ , inlineFunctions
874+ , map reduceContinuations
874875 ]
875876
876877