git.iko.soy/Idris-dev
on master help sign in
javascript: make unfoldLookupTable work
0793991raichoo
src/IRTS/CodegenJavaScript.hs+45−7
compare with master
unifiedsplit
@@ -839,8 +839,47 @@ unfoldLookupTable :: [JS] -> [JS]
839unfoldLookupTable input =
839unfoldLookupTable input =
840 let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
840 let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
841 (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
841 (applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
842+ js = applyunfold in
842− js = applyunfold in expandCons evals applys js
843+ adaptRuntime $ expandCons evals applys js
843 where
844 where
845+ adaptRuntime :: [JS] -> [JS]
846+ adaptRuntime =
847+ adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
848+
849+
850+ adaptApply var = map (jsSubst (
851+ JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag")
852+ ) (JSProj (JSIdent var) "app"))
853+
854+
855+ adaptEval = map (jsSubst (
856+ JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag")
857+ ) (JSProj (JSIdent "arg0") "eval"))
858+
859+
860+ adaptCon js =
861+ adaptCon' [] js
862+ where
863+ adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
864+ front ++ (new:back)
865+
866+ adaptCon' front (next:back) =
867+ adaptCon' (front ++ [next]) back
868+
869+ adaptCon' front [] = front
870+
871+
872+ new =
873+ JSAlloc "__IDRRT__Con" (Just $
874+ JSFunction newArgs (
875+ JSSeq (map newVar newArgs)
876+ )
877+ )
878+ where
879+ newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
880+ newArgs = ["tag", "eval", "app", "vars"]
881+
882+
844 unfoldLT :: String -> [JS] -> ([Int], [JS])
883 unfoldLT :: String -> [JS] -> ([Int], [JS])
845 unfoldLT lt js =
884 unfoldLT lt js =
846 let (table, code) = extractLT lt js
885 let (table, code) = extractLT lt js
@@ -1184,8 +1223,10 @@ translateDeclaration (path, SFun name params stackSize body)
1184 , (SLet var val next) <- body
1223 , (SLet var val next) <- body
1185 , (SChkCase cvar cases) <- next
1224 , (SChkCase cvar cases) <- next
1186 , ap == txt "APPLY" =
1225 , ap == txt "APPLY" =
1187− let lvar = translateVariableName var
1226+ let lvar = translateVariableName var
1227+ lookup t = (JSApp
1228+ (JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
1188− lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
1229+ [JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
1189 [ lookupTable [(var, "chk")] var cases
1230 [ lookupTable [(var, "chk")] var cases
1190 , jsDecl $ JSFunction ["fn0", "arg0"] (
1231 , jsDecl $ JSFunction ["fn0", "arg0"] (
1191 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
1232 JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
@@ -1195,10 +1236,7 @@ translateDeclaration (path, SFun name params stackSize body)
1195 , JSReturn $ (JSTernary (
1236 , JSReturn $ (JSTernary (
1196 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1237 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
1197 (hasProp lookupTableName (translateVariableName var))
1238 (hasProp lookupTableName (translateVariableName var))
1198− ) (JSIdent $
1199− lookupTableName ++ lookup
1239+ ) (lookup lookupTableName) JSNull)
1200− ) JSNull
1201− )
1202 ]
1240 ]
1203 )
1241 )
1204 ]
1242 ]