mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 11:19:32 -06:00
partial implementation for recursive def rules
This commit is contained in:
kr.angelov
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user