diff options
Diffstat (limited to 'src/compiler/GF/Compile')
| -rw-r--r-- | src/compiler/GF/Compile/GenerateBC.hs | 80 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/GrammarToPGF.hs | 8 |
2 files changed, 49 insertions, 39 deletions
diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 393c6722e..488368887 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -1,23 +1,26 @@ module GF.Compile.GenerateBC(generateByteCode) where import GF.Grammar +import GF.Grammar.Lookup(lookupAbsDef) +import GF.Data.Operations import PGF(CId,utf8CId) import PGF.Internal(Instr(..)) import qualified Data.Map as Map +import Data.List(mapAccumL) -generateByteCode :: Int -> [L Equation] -> [Instr] -generateByteCode arity eqs = - compileEquations arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) +generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [Instr] +generateByteCode gr arity eqs = + compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) where is = push_is (arity-1) arity [] -compileEquations :: Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr] -compileEquations st _ [] = [FAIL] -compileEquations st [] ((vs,[],t):_) = - let (heap,instrs) = compileBody st vs t 0 [] +compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr] +compileEquations gr st _ [] = [FAIL] +compileEquations gr st [] ((vs,[],t):_) = + let (heap,instrs) = compileBody gr st vs t 0 [] in (if heap > 0 then (ALLOC heap :) else id) (instrs ++ [RET st]) -compileEquations st (i:is) eqs = whilePP eqs Map.empty +compileEquations gr st (i:is) eqs = whilePP eqs Map.empty where whilePP [] cns = mkCase cns [] whilePP ((vs, PP c ps' : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (Q c,length ps') [(vs,ps'++ps,t)] cns) @@ -29,13 +32,13 @@ compileEquations st (i:is) eqs = whilePP eqs Map.empty whilePV [] cns vrs = mkCase cns (reverse vrs) whilePV ((vs, PV x : ps, t):eqs) cns vrs = whilePV eqs cns (((x,i):vs,ps,t) : vrs) whilePV ((vs, PW : ps, t):eqs) cns vrs = whilePV eqs cns (( vs,ps,t) : vrs) - whilePV eqs cns vrs = mkCase cns (reverse vrs) ++ compileEquations st (i:is) eqs + whilePV eqs cns vrs = mkCase cns (reverse vrs) ++ compileEquations gr st (i:is) eqs mkCase cns vrs - | Map.null cns = compileEquations st is vrs + | Map.null cns = compileEquations gr st is vrs | otherwise = EVAL (st-i-1) : concat [compileBranch t n eqs | ((t,n),eqs) <- Map.toList cns] ++ - compileEquations st is vrs + compileEquations gr st is vrs compileBranch t n eqs = let case_instr = @@ -44,32 +47,39 @@ compileEquations st (i:is) eqs = whilePP eqs Map.empty (EInt n) -> CASE_INT n (K s) -> CASE_STR s (EFloat d) -> CASE_FLT d - instrs = compileEquations (st+n) (push_is st n is) eqs + instrs = compileEquations gr (st+n) (push_is st n is) eqs in case_instr (length instrs) : instrs - -compileBody st vs (App e1 e2) h0 os = - case e2 of - Vr x -> case lookup x vs of - Just i -> compileBody st vs e1 h0 (SET_VARIABLE (st-i-1):os) - Nothing -> error "compileBody: unknown variable" - e2 -> let (h1,is1) = compileBody st vs e1 h0 (SET_VALUE h1:os) - (h2,is2) = compileBody st vs e2 h1 [] - in (h2,is1 ++ is2) -compileBody st vs (QC (_,id)) h0 os = let h1 = h0 + 2 + length os - in (h1,PUT_CONSTR (i2i id) : os) -compileBody st vs (Q (_,id)) h0 os = let h1 = h0 + 2 + length os - in (h1,PUT_CONSTR (i2i id) : os) -compileBody st vs (Vr x) h0 os = case lookup x vs of - Just i -> (h0,EVAL (st-i-1) : os) - Nothing -> error "compileBody: unknown variable" -compileBody st vs (EInt n) h0 os = let h1 = h0 + 2 - in (h1,PUT_INT n : os) -compileBody st vs (K s) h0 os = let h1 = h0 + 1 + (length s + 4) `div` 4 - in (h1,PUT_STR s : os) -compileBody st vs (EFloat d) h0 os = let h1 = h0 + 3 - in (h1,PUT_FLT d : os) -compileBody st vs t _ _ = error (show t) +compileBody gr st vs (App e1 e2) h0 es = compileBody gr st vs e1 h0 (e2:es) +compileBody gr st vs (Q (m,id)) h0 es = case lookupAbsDef gr m id of + Ok (Just _,Just _) + -> let ((h1,st1),iis) = mapAccumL (compileArg gr st vs) (h0,st) (reverse es) + (is1,is2,is3) = unzip3 iis + in (h1,concat is3 ++ is2 ++ [TAIL_CALL (i2i id)]) + _ -> let h1 = h0 + 2 + length es + ((h2,st1),iis) = mapAccumL (compileArg gr st vs) (h1,st) es + (is1,is2,is3) = unzip3 iis + in (h2,PUT_CONSTR (i2i id) : concat (is1:is3)) +compileBody gr st vs (QC qid) h0 es = compileBody gr st vs (Q qid) h0 es +compileBody gr st vs (Vr x) h0 es = case lookup x vs of + Just i -> let ((h1,st1),iis) = mapAccumL (compileArg gr st vs) (h0,st) (reverse es) + (is1,is2,is3) = unzip3 iis + in (h1,concat is3 ++ is2 ++ [EVAL (st-i-1)]) + Nothing -> error "compileBody: unknown variable" +compileBody gr st vs (EInt n) h0 _ = let h1 = h0 + 2 + in (h1,[PUT_INT n]) +compileBody gr st vs (K s) h0 _ = let h1 = h0 + 1 + (length s + 4) `div` 4 + in (h1,[PUT_STR s]) +compileBody gr st vs (EFloat d) h0 _ = let h1 = h0 + 3 + in (h1,[PUT_FLT d]) + +compileArg gr st vs (h0,st0) (Vr x) = + case lookup x vs of + Just i -> ((h0,st0+1),(SET_VARIABLE (st-i-1),PUSH_VARIABLE (st0-i-1),[])) + Nothing -> error "compileFunArg: unknown variable" +compileArg gr st vs (h0,st0) e = + let (h1,is2) = compileBody gr st vs e h0 [] + in ((h1,st0+1),(SET_VALUE h0,PUSH_VALUE h0,is2)) i2i :: Ident -> CId i2i = utf8CId . ident2utf8 diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 6373133d7..c5a04230b 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -48,7 +48,7 @@ mkCanon2pgf opts gr am = do flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags] - funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef arity mdef, 0)) | + 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] @@ -145,10 +145,10 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty then ( scope,(bt,i2i x,ty')) else (x:scope,(bt,i2i x,ty'))) scope hyps -mkDef arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - ,generateByteCode arity eqs +mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] + ,generateByteCode gr arity eqs ) -mkDef arity Nothing = Nothing +mkDef gr arity Nothing = Nothing mkArrity (Just a) ty = a mkArrity Nothing ty = let (ctxt, _, _) = GM.typeForm ty |