git.iko.soy/Idris-dev
on master help sign in
javascript: split eval function
a9080ffraichoo
jsrts/Runtime-common.js+2−1
compare with master
unifiedsplit
@@ -9,10 +9,11 @@ var i$VM = function() {
9}
9}
10
10
11/** @constructor */
11/** @constructor */
12−var i$CON = function(tag,args,app) {
12+var i$CON = function(tag,args,app,ev) {
13 this.tag = tag;
13 this.tag = tag;
14 this.args = args;
14 this.args = args;
15 this.app = app;
15 this.app = app;
16+ this.ev = ev;
16}
17}
17
18
18var i$SLIDE = function(vm,args) {
19var i$SLIDE = function(vm,args) {
src/IRTS/CodegenJavaScript.hs+36−13
@@ -33,15 +33,16 @@ data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
33
33
34
34
35initCompileInfo :: [(Name, [BC])] -> CompileInfo
35initCompileInfo :: [(Name, [BC])] -> CompileInfo
36−initCompileInfo bc = CompileInfo (collectApplyCases bc) []
36+initCompileInfo bc =
37+ CompileInfo (collectCases "APPLY" bc) (collectCases "EVAL" bc)
37 where
38 where
38− collectApplyCases :: [(Name, [BC])] -> [Int]
39+ collectCases :: String -> [(Name, [BC])] -> [Int]
39− collectApplyCases bc = getCases $ findApply bc
40+ collectCases fun bc = getCases $ findFunction fun bc
40
41
41− findApply :: [(Name, [BC])] -> [BC]
42+ findFunction :: String -> [(Name, [BC])] -> [BC]
42− findApply ((MN 0 fun, bc):_)
43+ findFunction f ((MN 0 fun, bc):_)
43− | fun == txt "APPLY" = bc
44+ | fun == txt f = bc
44− findApply (_:bc) = findApply bc
45+ findFunction f (_:bc) = findFunction f bc
45
46
46 getCases :: [BC] -> [Int]
47 getCases :: [BC] -> [Int]
47 getCases = concatMap analyze
48 getCases = concatMap analyze
@@ -343,7 +344,7 @@ translateDecl info (name@(MN 0 fun), bc)
343 translateName name
344 translateName name
344 ) (Just $ JSFunction ["vm", "oldbase"] (
345 ) (Just $ JSFunction ["vm", "oldbase"] (
345 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
346 JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
346− JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON"
347+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "app")
347 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [ JSIdent "vm"
348 , JSApp (JSProj (translateReg $ caseReg (snd body)) "app") [ JSIdent "vm"
348 , JSIdent "oldbase"
349 , JSIdent "oldbase"
349 , JSIdent "myoldbase"
350 , JSIdent "myoldbase"
@@ -357,6 +358,27 @@ translateDecl info (name@(MN 0 fun), bc)
357 )
358 )
358 )
359 )
359 ]
360 ]
361+
362+ | txt "EVAL" == fun =
363+ allocCaseFunctions (snd body)
364+ ++ [ JSAlloc (
365+ translateName name
366+ ) (Just $ JSFunction ["vm", "oldbase"] (
367+ JSSeq $ JSAlloc "myoldbase" Nothing : map (translateBC info) (fst body) ++ [
368+ JSCond [ ( (translateReg $ caseReg (snd body)) `jsInstanceOf` "i$CON" `jsAnd` (JSProj (translateReg $ caseReg (snd body)) "ev")
369+ , JSApp (JSProj (translateReg $ caseReg (snd body)) "ev") [ JSIdent "vm"
370+ , JSIdent "oldbase"
371+ , JSIdent "myoldbase"
372+ ]
373+ )
374+ , ( JSNoop
375+ , JSSeq $ map (translateBC info) (defaultCase (snd body))
376+ )
377+ ]
378+ ]
379+ )
380+ )
381+ ]
360 where
382 where
361 body :: ([BC], [BC])
383 body :: ([BC], [BC])
362 body = break isCase bc
384 body = break isCase bc
@@ -568,6 +590,9 @@ jsMKCON info r t rs =
568 , if t `elem` compileInfoApplyCases info
590 , if t `elem` compileInfoApplyCases info
569 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
591 then JSIdent $ translateName (sMN 0 "APPLY") ++ "$" ++ show t
570 else JSNull
592 else JSNull
593+ , if t `elem` compileInfoEvalCases info
594+ then JSIdent $ translateName (sMN 0 "EVAL") ++ "$" ++ show t
595+ else JSNull
571 ]
596 ]
572 )
597 )
573
598
@@ -638,11 +663,9 @@ jsCASE info safe reg cases def =
638
663
639 jsTAG :: JS -> JS
664 jsTAG :: JS -> JS
640 jsTAG js =
665 jsTAG js =
641− JSTernary (jsIsNumber js `jsOr` jsIsNull js) (
642− JSNum (JSInt $ negate 1)
643− ) (JSTernary (js `jsInstanceOf` "i$CON") (
666+ (JSTernary (js `jsInstanceOf` "i$CON") (
644− JSProj js "tag"
667+ JSProj js "tag"
645− ) (JSNum (JSInt $ negate 1)))
668+ ) (JSNum (JSInt $ negate 1)))
646
669
647 jsCTAG :: JS -> JS
670 jsCTAG :: JS -> JS
648 jsCTAG js = JSProj js "tag"
671 jsCTAG js = JSProj js "tag"