summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler/GF/Compile/GenerateBC.hs80
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs8
-rw-r--r--src/runtime/c/pgf/data.h2
-rw-r--r--src/runtime/c/pgf/jit.c49
-rw-r--r--src/runtime/haskell/PGF/Binary.hs8
-rw-r--r--src/runtime/haskell/PGF/ByteCode.hs6
6 files changed, 110 insertions, 43 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
diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index 552856995..bbf3351cb 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -117,6 +117,8 @@ typedef enum {
PGF_INSTR_PUT_FLT,
PGF_INSTR_SET_VALUE,
PGF_INSTR_SET_VARIABLE,
+ PGF_INSTR_PUSH_VALUE,
+ PGF_INSTR_PUSH_VARIABLE,
PGF_INSTR_TAIL_CALL,
PGF_INSTR_FAIL,
PGF_INSTR_RET
diff --git a/src/runtime/c/pgf/jit.c b/src/runtime/c/pgf/jit.c
index 646115c4e..0efaa7fd2 100644
--- a/src/runtime/c/pgf/jit.c
+++ b/src/runtime/c/pgf/jit.c
@@ -527,11 +527,60 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
curr_offset++;
break;
}
+ case PGF_INSTR_PUSH_VALUE: {
+ size_t offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+ gu_printf(out, err, "PUSH_VALUE %d\n", offset);
+#endif
+
+ jit_getarg_p(JIT_V0, es_arg);
+ jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
+ jit_prepare(1);
+ jit_pusharg_p(JIT_V0);
+ jit_finish(gu_buf_extend);
+ if (offset == 0) {
+ jit_str_p(JIT_RET, JIT_V1);
+ } else {
+ jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
+ jit_str_p(JIT_RET, JIT_V0);
+ }
+ break;
+ }
+ case PGF_INSTR_PUSH_VARIABLE: {
+ size_t index = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+ gu_printf(out, err, "PUSH_VARIABLE %d\n", index);
+#endif
+
+ jit_getarg_p(JIT_V0, es_arg);
+ jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
+ jit_prepare(1);
+ jit_pusharg_p(JIT_V0);
+ jit_finish(gu_buf_extend);
+ jit_ldxi_p(JIT_V0, JIT_RET, -(index+1)*sizeof(PgfClosure*));
+ jit_str_p(JIT_RET, JIT_V0);
+ break;
+ }
case PGF_INSTR_TAIL_CALL: {
PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "TAIL_CALL %s\n", id);
#endif
+
+ jit_getarg_p(JIT_V0, es_arg);
+ jit_getarg_p(JIT_V1, closure_arg);
+ jit_prepare(2);
+ jit_pusharg_p(JIT_V1);
+ jit_pusharg_p(JIT_V0);
+
+ PgfCallPatch patch;
+ patch.cid = id;
+ patch.ref = jit_movi_p(JIT_V0, jit_forward());
+ gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch);
+ jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfAbsFun,function));
+
+ jit_finishr(JIT_V0);
+ jit_retval_p(JIT_V1);
break;
}
case PGF_INSTR_FAIL:
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index b2bfda069..b5c301e3b 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -149,9 +149,11 @@ instance Binary Instr where
put (PUT_FLT d) = putWord8 10 >> put d
put (SET_VALUE n) = putWord8 11 >> put n
put (SET_VARIABLE n) = putWord8 12 >> put n
- put (TAIL_CALL id) = putWord8 13 >> put id
- put (FAIL ) = putWord8 14
- put (RET n) = putWord8 15 >> put n
+ put (PUSH_VALUE n)= putWord8 13 >> put n
+ put (PUSH_VARIABLE n)= putWord8 14 >> put n
+ put (TAIL_CALL id) = putWord8 15 >> put id
+ put (FAIL ) = putWord8 16
+ put (RET n) = putWord8 17 >> put n
instance Binary Type where
diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
index b8e7d889d..bcf21ed9b 100644
--- a/src/runtime/haskell/PGF/ByteCode.hs
+++ b/src/runtime/haskell/PGF/ByteCode.hs
@@ -19,6 +19,8 @@ data Instr
| PUT_FLT {-# UNPACK #-} !Double
| SET_VALUE {-# UNPACK #-} !Int
| SET_VARIABLE {-# UNPACK #-} !Int
+ | PUSH_VALUE {-# UNPACK #-} !Int
+ | PUSH_VARIABLE {-# UNPACK #-} !Int
| TAIL_CALL CId
| FAIL
| RET {-# UNPACK #-} !Int
@@ -33,13 +35,15 @@ ppInstr l (CASE_INT n o ) = text "CASE_INT " <+> int n <+> ppLabel (l+o+1)
ppInstr l (CASE_STR s o ) = text "CASE_STR " <+> text (show s) <+> ppLabel (l+o+1)
ppInstr l (CASE_FLT d o ) = text "CASE_FLT " <+> double d <+> ppLabel (l+o+1)
ppInstr l (ALLOC n) = text "ALLOC " <+> int n
-ppInstr l (SET_VALUE n) = text "SET_VALUE " <+> int n
ppInstr l (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
ppInstr l (PUT_CLOSURE c) = text "PUT_CLOSURE " <+> ppLabel c
ppInstr l (PUT_INT n ) = text "PUT_INT " <+> int n
ppInstr l (PUT_STR s ) = text "PUT_STR " <+> text (show s)
ppInstr l (PUT_FLT d ) = text "PUT_FLT " <+> double d
+ppInstr l (SET_VALUE n) = text "SET_VALUE " <+> int n
ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n
+ppInstr l (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n
+ppInstr l (PUSH_VARIABLE n)= text "PUSH_VARIABLE"<+> int n
ppInstr l (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id
ppInstr l (FAIL ) = text "FAIL"
ppInstr l (RET n) = text "RET " <+> int n
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 08:31:24 +0000