diff options
| author | kr.angelov <kr.angelov@gmail.com> | 2014-10-16 10:00:32 +0000 |
|---|---|---|
| committer | kr.angelov <kr.angelov@gmail.com> | 2014-10-16 10:00:32 +0000 |
| commit | 26ad164cecc65afd9420e0ac34a15d49b02e6cbf (patch) | |
| tree | 327fb80f9d2281199737f6db0ca6bdcc336729c2 /src/compiler/GF/Compile | |
| parent | b70dba87bab5dfc8039f0b9f69e0851f92324f8b (diff) | |
finally proper stack unwind in the evaluator
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/GenerateBC.hs | 12 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GrammarToPGF.hs | 11 |
2 files changed, 14 insertions, 9 deletions
diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 1f1e81ab9..d90e78ee7 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -24,7 +24,7 @@ generateByteCode gr arity eqs = is = push_is (arity-1) arity [] compileEquations :: SourceGrammar -> Int -> Int -> [IVal] -> [([(Ident,IVal)],[Patt],Term)] -> Maybe (Int,CodeLabel) -> [[Instr]] -> ([[Instr]],[Instr]) -compileEquations gr arity st _ [] fl bs = (bs,[mkFail st fl]) +compileEquations gr arity st _ [] fl bs = (bs,mkFail arity st fl) compileEquations gr arity st [] ((vs,[],t):_) fl bs = compileBody gr arity st vs t bs compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty where @@ -32,7 +32,7 @@ compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty [] -> (bs,[FAIL]) (cn:cns) -> let (bs1,instrs1) = compileBranch0 fl bs cn bs2 = foldl (compileBranch fl) bs1 cns - bs3 = [mkFail st fl]:bs2 + bs3 = mkFail arity st fl : bs2 in (bs3,EVAL (shiftIVal st i) RecCall : instrs1) whilePP ((vs, PP c ps' : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (Q c,length ps') [(vs,ps'++ps,t)] cns) whilePP ((vs, PInt n : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EInt n,0) [(vs,ps,t)] cns) @@ -75,8 +75,12 @@ compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty let (bs1,instrs) = compileEquations gr arity (st+n) (push_is (st+n-1) n is) eqs fl ((case_instr t n (length bs1) : instrs) : bs) in bs1 -mkFail st1 Nothing = FAIL -mkFail st1 (Just (st0,l)) = DROP (st1-st0) l +mkFail arity st1 Nothing + | arity+1 /= st1 = [DROP (st1-arity), FAIL] + | otherwise = [FAIL] +mkFail arity st1 (Just (st0,l)) + | st1 /= st0 = [DROP (st1-st0), JUMP l] + | otherwise = [JUMP l] compileBody gr arity st vs e bs = let (heap,bs1,is) = compileFun gr arity st vs e 0 bs [] diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index b8a79af52..d0b588d81 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -50,8 +50,8 @@ mkCanon2pgf opts gr am = do funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, - let arity = mkArrity ma ty] - + let arity = mkArity ma mdef ty] + cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) | ((m,c),AbsCat (Just (L _ cont))) <- adefs] @@ -150,9 +150,10 @@ mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eq ) mkDef gr arity Nothing = Nothing -mkArrity (Just a) ty = a -mkArrity Nothing ty = let (ctxt, _, _) = GM.typeForm ty - in length ctxt +mkArity (Just a) _ ty = a -- known arity, i.e. defined function +mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom +mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor + in length ctxt genCncCats gr am cm cdefs = let (index,cats) = mkCncCats 0 cdefs |