git.iko.soy/Idris-dev
on master help sign in
Merge pull request #1178 from raichoo/javascript
89c3853raichoo
src/IRTS/CodegenJavaScript.hs+74−24
compare with master
unifiedsplit
@@ -755,6 +755,29 @@ removeIDs js =
755 removeIDCall ids js = transformJS (removeIDCall ids) js
755 removeIDCall ids js = transformJS (removeIDCall ids) js
756
756
757
757
758+inlineFunction :: String -> [String] -> JS -> JS -> JS
759+inlineFunction fun args body js = inline' js
760+ where
761+ inline' :: JS -> JS
762+ inline' (JSApp (JSIdent name) vals)
763+ | name == fun =
764+ let (js, phs) = insertPlaceHolders args body in
765+ inline' $ foldr (uncurry jsSubst) js (zip phs vals)
766+
767+ inline' js = transformJS inline' js
768+
769+ insertPlaceHolders :: [String] -> JS -> (JS, [JS])
770+ insertPlaceHolders args body = insertPlaceHolders' args body []
771+ where
772+ insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
773+ insertPlaceHolders' (a:as) body ph
774+ | (body', ph') <- insertPlaceHolders' as body ph =
775+ let phvar = JSIdent $ "__PH_" ++ show (length ph') in
776+ (jsSubst (JSIdent a) phvar body', phvar : ph')
777+
778+ insertPlaceHolders' [] body ph = (body, ph)
779+
780+
758inlineFunctions :: [JS] -> [JS]
781inlineFunctions :: [JS] -> [JS]
759inlineFunctions js =
782inlineFunctions js =
760 inlineHelper ([], js)
783 inlineHelper ([], js)
@@ -766,7 +789,7 @@ inlineFunctions js =
766 | Just new <- inlineAble (
789 | Just new <- inlineAble (
767 countAll fun front + countAll fun back
790 countAll fun front + countAll fun back
768 ) fun args body =
791 ) fun args body =
769− let f = map (inline fun args new) in
792+ let f = map (inlineFunction fun args new) in
770 inlineHelper (f front, f back)
793 inlineHelper (f front, f back)
771
794
772 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
795 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
@@ -783,29 +806,6 @@ inlineFunctions js =
783 inlineAble _ _ _ _ = Nothing
806 inlineAble _ _ _ _ = Nothing
784
807
785
808
786− inline :: String -> [String] -> JS -> JS -> JS
787− inline fun args body js = inline' js
788− where
789− inline' :: JS -> JS
790− inline' (JSApp (JSIdent name) vals)
791− | name == fun =
792− let (js, phs) = insertPlaceHolders args body in
793− inline' $ foldr (uncurry jsSubst) js (zip phs vals)
794−
795− inline' js = transformJS inline' js
796−
797− insertPlaceHolders :: [String] -> JS -> (JS, [JS])
798− insertPlaceHolders args body = insertPlaceHolders' args body []
799− where
800− insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
801− insertPlaceHolders' (a:as) body ph
802− | (body', ph') <- insertPlaceHolders' as body ph =
803− let phvar = JSIdent $ "__PH_" ++ show (length ph') in
804− (jsSubst (JSIdent a) phvar body', phvar : ph')
805−
806− insertPlaceHolders' [] body ph = (body, ph)
807−
808−
809 nonRecur :: String -> JS -> Bool
809 nonRecur :: String -> JS -> Bool
810 nonRecur name body = countInvokations name body == 0
810 nonRecur name body = countInvokations name body == 0
811
811
@@ -1416,6 +1416,54 @@ evalCons js =
1416 match js = transformJS match js
1416 match js = transformJS match js
1417
1417
1418
1418
1419+elimConds :: [JS] -> [JS]
1420+elimConds js =
1421+ let (conds, rest) = partition isCond js in
1422+ foldl' eraseCond rest conds
1423+ where
1424+ isCond :: JS -> Bool
1425+ isCond (JSAlloc
1426+ fun (Just (JSFunction args (JSCond
1427+ [ (JSBinOp "==" (JSNum (JSInt tag)) _, JSReturn (JSIdent _))
1428+ , (JSNoop, JSReturn (JSIdent _))
1429+ ]))
1430+ )) = True
1431+
1432+ isCond (JSAlloc
1433+ fun (Just (JSFunction args (JSCond
1434+ [ (JSBinOp "==" _ (JSNum (JSInt tag)), JSReturn (JSIdent _))
1435+ , (JSNoop, JSReturn (JSIdent _))
1436+ ]))
1437+ )) = True
1438+
1439+ isCond _ = False
1440+
1441+
1442+ eraseCond :: [JS] -> JS -> [JS]
1443+ eraseCond js (JSAlloc
1444+ fun (Just (JSFunction args (JSCond
1445+ [ (c, JSReturn t)
1446+ , (_, JSReturn f)
1447+ ])
1448+ )
1449+ )) = map (inlineFunction fun args (JSTernary c t f)) js
1450+
1451+
1452+removeUselessCons :: [JS] -> [JS]
1453+removeUselessCons js =
1454+ let (cons, rest) = partition isUseless js in
1455+ foldl' eraseCon rest cons
1456+ where
1457+ isUseless :: JS -> Bool
1458+ isUseless (JSAlloc fun (Just JSNull)) = True
1459+ isUseless (JSAlloc fun (Just (JSIdent _))) = True
1460+ isUseless _ = False
1461+
1462+
1463+ eraseCon :: [JS] -> JS -> [JS]
1464+ eraseCon js (JSAlloc fun (Just val)) = map (jsSubst (JSIdent fun) val) js
1465+
1466+
1419getGlobalCons :: JS -> [(String, JS)]
1467getGlobalCons :: JS -> [(String, JS)]
1420getGlobalCons js = foldJS match (++) [] js
1468getGlobalCons js = foldJS match (++) [] js
1421 where
1469 where
@@ -1517,6 +1565,8 @@ codegenJS_all target definitions includes filename outputType = do
1517 , extractLocalConstructors
1565 , extractLocalConstructors
1518 , unfoldLookupTable
1566 , unfoldLookupTable
1519 , evalCons
1567 , evalCons
1568+ , elimConds
1569+ , removeUselessCons
1520 ]
1570 ]
1521
1571
1522 functions :: [String]
1572 functions :: [String]