git.iko.soy/Idris-dev
on master help sign in
Merge pull request #889 from raichoo/typed-laziness
433ddf3Edwin Brady
src/IRTS/CodegenJavaScript.hs+61−55
compare with master
unifiedsplit
@@ -80,10 +80,13 @@ data JS = JSRaw String
80 | JSTernary JS JS JS
80 | JSTernary JS JS JS
81 | JSParens JS
81 | JSParens JS
82 | JSWhile JS JS
82 | JSWhile JS JS
83+ | JSNoop
83 deriving Eq
84 deriving Eq
84
85
85
86
86compileJS :: JS -> String
87compileJS :: JS -> String
88+compileJS JSNoop = ""
89+
87compileJS (JSRaw code) =
90compileJS (JSRaw code) =
88 code
91 code
89
92
@@ -184,7 +187,7 @@ compileJS (JSCond branches) =
184 intercalate " else " $ map createIfBlock branches
187 intercalate " else " $ map createIfBlock branches
185 where
188 where
186 createIfBlock (JSTrue, e) =
189 createIfBlock (JSTrue, e) =
187− "{\n"
190+ "if (true) {\n"
188 ++ compileJS e
191 ++ compileJS e
189 ++ ";\n}"
192 ++ ";\n}"
190 createIfBlock (cond, e) =
193 createIfBlock (cond, e) =
@@ -938,6 +941,7 @@ unfoldLookupTable input =
938 | fun == lt = (js, front ++ back)
941 | fun == lt = (js, front ++ back)
939
942
940 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
943 extractLT' (front, js:back) = extractLT' (front ++ [js], back)
944+ extractLT' (front, back) = (JSNoop, front ++ back)
941
945
942
946
943 expandLT :: String -> JS -> [(Int, JS)]
947 expandLT :: String -> JS -> [(Int, JS)]
@@ -951,6 +955,8 @@ unfoldLookupTable input =
951
955
952 expandEntry js = Nothing
956 expandEntry js = Nothing
953
957
958+ expandLT lt JSNoop = []
959+
954
960
955removeInstanceChecks :: JS -> JS
961removeInstanceChecks :: JS -> JS
956removeInstanceChecks (JSCond conds) =
962removeInstanceChecks (JSCond conds) =
@@ -1237,24 +1243,24 @@ codegenJavaScript target definitions filename outputType = do
1237 compile =
1243 compile =
1238 map compileJS
1244 map compileJS
1239
1245
1240− opt =
1246+ opt = []
1241− [ map optimizeJS
1247+ {-[ map optimizeJS-}
1242− , removeIDs
1248+ {-, removeIDs-}
1243− , reduceJS
1249+ {-, reduceJS-}
1244− , map reduceConstants
1250+ {-, map reduceConstants-}
1245− , initConstructors
1251+ {-, initConstructors-}
1246− , map removeAllocations
1252+ {-, map removeAllocations-}
1247− , elimDeadLoop
1253+ {-, elimDeadLoop-}
1248− , map elimDuplicateEvals
1254+ {-, map elimDuplicateEvals-}
1249− , optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
1255+ {-, optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"-}
1250− , optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
1256+ {-, optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"-}
1251− , map removeInstanceChecks
1257+ {-, map removeInstanceChecks-}
1252− , inlineFunctions
1258+ {-, inlineFunctions-}
1253− , map reduceContinuations
1259+ {-, map reduceContinuations-}
1254− , extractLocalConstructors
1260+ {-, extractLocalConstructors-}
1255− , unfoldLookupTable
1261+ {-, unfoldLookupTable-}
1256− , evalCons
1262+ {-, evalCons-}
1257− ]
1263+ {-]-}
1258
1264
1259 prelude :: [JS]
1265 prelude :: [JS]
1260 prelude =
1266 prelude =
@@ -1413,42 +1419,42 @@ translateConstant c =
1413
1419
1414translateDeclaration :: (String, SDecl) -> [JS]
1420translateDeclaration :: (String, SDecl) -> [JS]
1415translateDeclaration (path, SFun name params stackSize body)
1421translateDeclaration (path, SFun name params stackSize body)
1416− | (MN _ ap) <- name
1422+ {-| (MN _ ap) <- name-}
1417− , (SLet var val next) <- body
1423+ {-, (SLet var val next) <- body-}
1418− , (SChkCase cvar cases) <- next
1424+ {-, (SChkCase cvar cases) <- next-}
1419− , ap == txt "APPLY" =
1425+ {-, ap == txt "APPLY" =-}
1420− let lvar = translateVariableName var
1426+ {-let lvar = translateVariableName var-}
1421− lookup t = (JSApp
1427+ {-lookup t = (JSApp-}
1422− (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1428+ {-(JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))-}
1423− [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1429+ {-[JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in-}
1424− [ lookupTable "APPLY" [(var, "chk")] var cases
1430+ {-[ lookupTable "APPLY" [(var, "chk")] var cases-}
1425− , jsDecl $ JSFunction ["fn0", "arg0"] (
1431+ {-, jsDecl $ JSFunction ["fn0", "arg0"] (-}
1426− JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1432+ {-JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")-}
1427− , JSAlloc (translateVariableName var) (
1433+ {-, JSAlloc (translateVariableName var) (-}
1428− Just $ translateExpression val
1434+ {-Just $ translateExpression val-}
1429− )
1435+ {-)-}
1430− , JSReturn $ (JSTernary (
1436+ {-, JSReturn $ (JSTernary (-}
1431− (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1437+ {-(JSVar var `jsInstanceOf` jsCon) `jsAnd`-}
1432− (hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))
1438+ {-(hasProp (idrLTNamespace ++ "APPLY") (translateVariableName var))-}
1433− ) (lookup (idrLTNamespace ++ "APPLY")) JSNull)
1439+ {-) (lookup (idrLTNamespace ++ "APPLY")) JSNull)-}
1434− ]
1440+ {-]-}
1435− )
1441+ {-)-}
1436− ]
1442+ {-]-}
1437−
1443+
1438− | (MN _ ev) <- name
1444+ {-| (MN _ ev) <- name-}
1439− , (SChkCase var cases) <- body
1445+ {-, (SChkCase var cases) <- body-}
1440− , ev == txt "EVAL" =
1446+ {-, ev == txt "EVAL" =-}
1441− [ lookupTable "EVAL" [] var cases
1447+ {-[ lookupTable "EVAL" [] var cases-}
1442− , jsDecl $ JSFunction ["arg0"] (JSReturn $
1448+ {-, jsDecl $ JSFunction ["arg0"] (JSReturn $-}
1443− JSTernary (
1449+ {-JSTernary (-}
1444− (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
1450+ {-(JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`-}
1445− (hasProp (idrLTNamespace ++ "EVAL") "arg0")
1451+ {-(hasProp (idrLTNamespace ++ "EVAL") "arg0")-}
1446− ) (JSApp
1452+ {-) (JSApp-}
1447− (JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))
1453+ {-(JSIndex (JSIdent (idrLTNamespace ++ "EVAL")) (JSProj (JSIdent "arg0") "tag"))-}
1448− [JSIdent "arg0"]
1454+ {-[JSIdent "arg0"]-}
1449− ) (JSIdent "arg0")
1455+ {-) (JSIdent "arg0")-}
1450− )
1456+ {-)-}
1451− ]
1457+ {-]-}
1452 | otherwise =
1458 | otherwise =
1453 let fun = translateExpression body in
1459 let fun = translateExpression body in
1454 [jsDecl $ jsFun fun]
1460 [jsDecl $ jsFun fun]