git.iko.soy/Idris-dev
on master help sign in
javascript: allow more inlining
1419f45raichoo
src/IRTS/CodegenJavaScript.hs+13−11
compare with master
unifiedsplit
@@ -182,11 +182,11 @@ compileJS (JSCond branches) =
182
182
183 createIfBlock (JSTrue, e) =
183 createIfBlock (JSTrue, e) =
184 "{\n"
184 "{\n"
185− ++ "return " ++ compileJS e
185+ ++ compileJS e
186 ++ ";\n}"
186 ++ ";\n}"
187 createIfBlock (cond, e) =
187 createIfBlock (cond, e) =
188 "if (" ++ compileJS cond ++") {\n"
188 "if (" ++ compileJS cond ++") {\n"
189− ++ "return " ++ compileJS e
189+ ++ compileJS e
190 ++ ";\n}"
190 ++ ";\n}"
191
191
192compileJS (JSTernary cond true false) =
192compileJS (JSTernary cond true false) =
@@ -383,16 +383,17 @@ inlineJS :: JS -> JS
383inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
383inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
384 inlineJS $ jsSubst (JSIdent "cse") val body
384 inlineJS $ jsSubst (JSIdent "cse") val body
385
385
386+
386inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
387inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
387− JSSeq [ JSAlloc arg (Just (inlineJS val))
388+ inlineJS $ JSSeq [ JSAlloc arg (Just val)
388− , inlineJS cond
389+ , cond
389− ]
390+ ]
390
391
391inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
392inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
392 JSThis,JSProj var "vars"
393 JSThis,JSProj var "vars"
393 ])
394 ])
394 | var /= JSIdent "cse" =
395 | var /= JSIdent "cse" =
395− inlineApply args body 0
396+ inlineJS $ inlineApply args body 0
396 where
397 where
397 inlineApply [] body _ = inlineJS body
398 inlineApply [] body _ = inlineJS body
398 inlineApply (a:as) body n =
399 inlineApply (a:as) body n =
@@ -477,7 +478,7 @@ inlineJS (JSAlloc name (Just js)) =
477 JSAlloc name (Just $ inlineJS js)
478 JSAlloc name (Just $ inlineJS js)
478
479
479inlineJS (JSCond cases) =
480inlineJS (JSCond cases) =
480− JSCond (map (second inlineJS) cases)
481+ JSCond $ map (inlineJS *** inlineJS) cases
481
482
482inlineJS (JSObject fields) =
483inlineJS (JSObject fields) =
483 JSObject (map (second inlineJS) fields)
484 JSObject (map (second inlineJS) fields)
@@ -1269,7 +1270,8 @@ translateDeclaration (path, SFun name params stackSize body)
1269
1270
1270 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1271 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
1271 caseFun aux var cse =
1272 caseFun aux var cse =
1272− jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
1273+ let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
1274+ jsFunAux aux c
1273
1275
1274 getTag :: SAlt -> Maybe Int
1276 getTag :: SAlt -> Maybe Int
1275 getTag (SConCase _ tag _ _ _) = Just tag
1277 getTag (SConCase _ tag _ _ _) = Just tag
@@ -1631,10 +1633,10 @@ translateCaseCond var cse@(SConCase _ tag _ _ _) =
1631 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1633 (CaseCond $ ConCase tag, translateCase (Just var) cse)
1632
1634
1633translateCase :: Maybe String -> SAlt -> JS
1635translateCase :: Maybe String -> SAlt -> JS
1634−translateCase _ (SDefaultCase e) = translateExpression e
1636+translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
1635−translateCase _ (SConstCase _ e) = translateExpression e
1637+translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
1636translateCase (Just var) (SConCase a _ _ vars e) =
1638translateCase (Just var) (SConCase a _ _ vars e) =
1637 let params = map jsVar [a .. (a + length vars)] in
1639 let params = map jsVar [a .. (a + length vars)] in
1638− jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1640+ JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
1639 JSThis, JSProj (JSIdent var) "vars"
1641 JSThis, JSProj (JSIdent var) "vars"
1640 ]
1642 ]