diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 488368887..bab6cd4f4 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -6,21 +6,19 @@ import GF.Data.Operations import PGF(CId,utf8CId) import PGF.Internal(Instr(..)) import qualified Data.Map as Map -import Data.List(mapAccumL) +import Data.List(nub) -generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [Instr] +generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]] generateByteCode gr arity eqs = - compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) + let (bs,instrs) = compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) [ENTER:instrs] + in reverse bs where is = push_is (arity-1) arity [] -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 gr st (i:is) eqs = whilePP eqs Map.empty +compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [[Instr]] -> ([[Instr]],[Instr]) +compileEquations gr st _ [] bs = (bs,[FAIL]) +compileEquations gr st [] ((vs,[],t):_) bs = compileBody gr st vs [] t bs [] +compileEquations gr st (i:is) eqs bs = 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) @@ -32,54 +30,118 @@ compileEquations gr 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 gr st (i:is) eqs + whilePV eqs cns vrs = let (bs1,instrs1) = mkCase cns (reverse vrs) + (bs2,instrs2) = compileEquations gr st (i:is) eqs (instrs2:bs1) + in (bs2,instrs1) - mkCase cns 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 gr st is vrs + mkCase cns vrs = + case Map.toList cns of + [] -> compileEquations gr st is vrs bs + (cn:cns) -> let (bs1,instrs1) = compileBranch0 cn bs + bs2 = foldr compileBranch bs1 cns + (bs3,instrs3) = compileEquations gr st is vrs (instrs3:bs2) + in (bs3,instrs1) - compileBranch t n eqs = + compileBranch0 ((t,n),eqs) bs = let case_instr = case t of (Q (_,id)) -> CASE (i2i id) (EInt n) -> CASE_INT n (K s) -> CASE_STR s (EFloat d) -> CASE_FLT d - instrs = compileEquations gr (st+n) (push_is st n is) eqs - in case_instr (length instrs) : instrs + (bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs bs + in (bs1, EVAL_ARG_VAR (st-i-1) : case_instr (length bs1) : instrs) -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]) + compileBranch ((t,n),eqs) bs = + let case_instr = + case t of + (Q (_,id)) -> CASE (i2i id) + (EInt n) -> CASE_INT n + (K s) -> CASE_STR s + (EFloat d) -> CASE_FLT d + (bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs ((case_instr (length bs1) : instrs) : bs) + in bs1 -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)) +compileBody gr st avs fvs e bs es = + let (heap,bs1,instrs) = compileFun gr st avs fvs e 0 bs es + in (bs1,(if heap > 0 then (ALLOC heap :) else id) (instrs ++ [RET st])) + +compileFun gr st avs fvs (App e1 e2) h0 bs es = + compileFun gr st avs fvs e1 h0 bs (e2:es) +compileFun gr st avs fvs (Q (m,id)) h0 bs es = + case lookupAbsDef gr m id of + Ok (_,Just _) + -> let (h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es) + in (h1,bs1,is3 ++ is2 ++ [TAIL_CALL (i2i id)]) + _ -> let h1 = h0 + 2 + length es + (h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es + in (h2,bs2,PUT_CONSTR (i2i id) : is1 ++ is3) +compileFun gr st avs fvs (QC qid) h0 bs es = + compileFun gr st avs fvs (Q qid) h0 bs es +compileFun gr st avs fvs (Vr x) h0 bs es = + let (h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es) + i = case lookup x avs of + Just i -> EVAL_ARG_VAR (st-i-1) + Nothing -> case lookup x fvs of + Just i -> EVAL_FREE_VAR i + Nothing -> error "compileFun: unknown variable" + in (h1,bs1,is3 ++ is2 ++ [i]) +compileFun gr st avs fvs (EInt n) h0 bs _ = + let h1 = h0 + 2 + in (h1,bs,[PUT_INT n]) +compileFun gr st avs fvs (K s) h0 bs _ = + let h1 = h0 + 1 + (length s + 4) `div` 4 + in (h1,bs,[PUT_STR s]) +compileFun gr st avs fvs (EFloat d) h0 bs _ = + let h1 = h0 + 3 + in (h1,bs,[PUT_FLT d]) + +compileArgs gr st st0 avs fvs h0 bs [] = + (h0,bs,[],[],[]) +compileArgs gr st st0 avs fvs h0 bs (e:es) = + (h2,bs2,i1:is1,i2:is2,is++is3) + where + (h1,bs1,i1,i2,is) = compileArg gr st st0 avs fvs e h0 bs [] + (h2,bs2,is1,is2,is3) = compileArgs gr st (st0+1) avs fvs h1 bs1 es + +compileArg gr st st0 avs fvs (App e1 e2) h0 bs es = compileArg gr st st0 avs fvs e1 h0 bs (e2:es) +compileArg gr st st0 avs fvs e@(Q(m,id)) h0 bs es = + case lookupAbsDef gr m id of + Ok (_,Just _) + -> if null es + then let h1 = h0 + 2 + in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FUN (i2i id)]) + else let es_fvs = nub (foldr freeVars [] es) + h1 = h0 + 1 + length es_fvs + (bs1,b) = compileBody gr 0 [] (zip es_fvs [0..]) e bs es + in (h1,(ENTER:b):bs1,SET_VALUE h0,PUSH_VALUE h0,PUT_CLOSURE (length bs) : map (fst . compileVar st st0 avs fvs) es_fvs) + _ -> let h1 = h0 + 2 + length es + (h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es + in (h2,bs2,SET_VALUE h0,PUSH_VALUE h0,PUT_CONSTR (i2i id) : is1 ++ is3) +compileArg gr st st0 avs fvs (QC qid) h0 bs es = compileArg gr st st0 avs fvs (Q qid) h0 bs es +compileArg gr st st0 avs fvs (Vr x) h0 bs es = + let (i1,i2) = compileVar st st0 avs fvs x + in (h0,bs,i1,i2,[]) +compileArg gr st st0 avs fvs (EInt n) h0 bs _ = + let h1 = h0 + 2 + in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_INT n]) +compileArg gr st st0 avs fvs (K s) h0 bs _ = + let h1 = h0 + 1 + (length s + 4) `div` 4 + in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_STR s]) +compileArg gr st st0 avs fvs (EFloat d) h0 bs _ = + let h1 = h0 + 3 + in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FLT d]) + +compileVar st st0 avs fvs x = + case lookup x avs of + Just i -> (SET_ARG_VAR (st-i-1),PUSH_ARG_VAR (st0-i-1)) + Nothing -> case lookup x fvs of + Just i -> (SET_FREE_VAR i,PUSH_FREE_VAR i) + Nothing -> error "compileVar: unknown variable" + +freeVars (App e1 e2) vs = (freeVars e1 . freeVars e2) vs +freeVars (Vr x) vs = x:vs +freeVars _ vs = vs i2i :: Ident -> CId i2i = utf8CId . ident2utf8 diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index c5a04230b..b8a79af52 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -146,8 +146,8 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty else (x:scope,(bt,i2i x,ty'))) scope hyps 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 - ) + ,generateByteCode gr arity eqs + ) mkDef gr arity Nothing = Nothing mkArrity (Just a) ty = a diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index 2195ce431..1a3d81a89 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -32,7 +32,7 @@ pgf2js pgf = abstract2js :: String -> Abstr -> JS.Expr abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] -absdef2js :: (CId,(Type,Int,Maybe ([Equation],[M.Instr]),Double)) -> JS.Property +absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property absdef2js (f,(typ,_,_,_)) = let (args,cat) = M.catSkeleton typ in JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs index 1fee9c8c5..72b4f1ff8 100644 --- a/src/compiler/GF/Compile/PGFtoPython.hs +++ b/src/compiler/GF/Compile/PGFtoPython.hs @@ -39,7 +39,7 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++ abs = abstract pgf cncs = concretes pgf -pyAbsdef :: (Type, Int, Maybe ([Equation], [M.Instr]), Double) -> String +pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args] where (args, cat) = M.catSkeleton typ diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index bbf3351cb..f2e646a50 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -104,21 +104,26 @@ typedef struct { } PgfAbstr; typedef enum { - PGF_INSTR_EVAL, + PGF_INSTR_ENTER, + PGF_INSTR_EVAL_ARG_VAR, + PGF_INSTR_EVAL_FREE_VAR, PGF_INSTR_CASE, PGF_INSTR_CASE_INT, PGF_INSTR_CASE_STR, PGF_INSTR_CASE_FLT, PGF_INSTR_ALLOC, PGF_INSTR_PUT_CONSTR, + PGF_INSTR_PUT_FUN, PGF_INSTR_PUT_CLOSURE, PGF_INSTR_PUT_INT, PGF_INSTR_PUT_STR, PGF_INSTR_PUT_FLT, PGF_INSTR_SET_VALUE, - PGF_INSTR_SET_VARIABLE, + PGF_INSTR_SET_ARG_VAR, + PGF_INSTR_SET_FREE_VAR, PGF_INSTR_PUSH_VALUE, - PGF_INSTR_PUSH_VARIABLE, + PGF_INSTR_PUSH_ARG_VAR, + PGF_INSTR_PUSH_FREE_VAR, 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 0efaa7fd2..24e9ee0d8 100644 --- a/src/runtime/c/pgf/jit.c +++ b/src/runtime/c/pgf/jit.c @@ -14,7 +14,7 @@ struct PgfJitState { jit_insn *buf; char *save_ip_ptr; GuBuf* call_patches; - GuBuf* label_patches; + GuBuf* segment_patches; }; #define _jit (rdr->jit_state->jit) @@ -25,9 +25,10 @@ typedef struct { } PgfCallPatch; typedef struct { - size_t label; + size_t segment; jit_insn *ref; -} PgfLabelPatch; + bool is_abs; +} PgfSegmentPatch; // Between two calls to pgf_jit_make_space we are not allowed // to emit more that JIT_CODE_WINDOW bytes. This is not quite @@ -78,7 +79,7 @@ pgf_new_jit(PgfReader* rdr) { PgfJitState* state = gu_new(PgfJitState, rdr->tmp_pool); state->call_patches = gu_new_buf(PgfCallPatch, rdr->tmp_pool); - state->label_patches = gu_new_buf(PgfLabelPatch, rdr->tmp_pool); + state->segment_patches = gu_new_buf(PgfSegmentPatch, rdr->tmp_pool); state->buf = NULL; state->save_ip_ptr = NULL; return state; @@ -333,282 +334,345 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr, absfun->function = jit_get_ip().ptr; - jit_prolog(2); - - int es_arg = jit_arg_p(); - int closure_arg = jit_arg_p(); - - size_t n_instrs = pgf_read_len(rdr); + size_t n_segments = pgf_read_len(rdr); gu_return_on_exn(rdr->err, ); - - size_t curr_offset = 0; - size_t curr_label = 0; - gu_buf_flush(rdr->jit_state->label_patches); + gu_buf_flush(rdr->jit_state->segment_patches); - for (size_t i = 0; i < n_instrs; i++) { - size_t labels_count = gu_buf_length(rdr->jit_state->label_patches); - if (labels_count > 0) { - PgfLabelPatch* patch = - gu_buf_index(rdr->jit_state->label_patches, PgfLabelPatch, labels_count-1); - if (patch->label == curr_label) { - jit_patch(patch->ref); - gu_buf_trim_n(rdr->jit_state->label_patches, 1); + int es_arg = 0; + int closure_arg = 0; + + for (size_t segment = 0; segment < n_segments; segment++) { + size_t n_instrs = pgf_read_len(rdr); + gu_return_on_exn(rdr->err, ); + + size_t curr_offset = 0; + + size_t n_patches = gu_buf_length(rdr->jit_state->segment_patches); + if (n_patches > 0) { + PgfSegmentPatch* patch = + gu_buf_index(rdr->jit_state->segment_patches, PgfSegmentPatch, n_patches-1); + if (patch->segment == segment) { + if (patch->is_abs) + jit_patch_movi(patch->ref,jit_get_ip().ptr); + else + jit_patch(patch->ref); + gu_buf_trim_n(rdr->jit_state->segment_patches, 1); } } #ifdef PGF_JIT_DEBUG - gu_printf(out, err, "%04d ", curr_label); -#endif - curr_label++; - - uint8_t opcode = pgf_read_tag(rdr); - switch (opcode) { - case PGF_INSTR_EVAL: { - size_t index = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "EVAL %d\n", index); + gu_printf(out, err, "%03d ", segment); #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_last); - jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*)); - jit_prepare(2); - jit_pusharg_p(JIT_V0); - jit_getarg_p(JIT_V2, es_arg); - jit_pusharg_p(JIT_V2); - jit_ldr_p(JIT_V0, JIT_V0); - jit_finishr(JIT_V0); - jit_retval_p(JIT_V1); - jit_ldxi_p(JIT_V0, JIT_V1, offsetof(PgfValue, absfun)); - break; - } - case PGF_INSTR_CASE: { - PgfCId id = pgf_read_cid(rdr, rdr->opool); - int offset = pgf_read_int(rdr); + for (size_t label = 0; label < n_instrs; label++) { #ifdef PGF_JIT_DEBUG - gu_printf(out, err, "CASE %s %04d\n", id, curr_label+offset); -#endif - jit_insn *jump= - jit_bnei_i(jit_forward(), JIT_V0, (int) jit_forward()); - - PgfLabelPatch label_patch; - label_patch.label = curr_label+offset; - label_patch.ref = jump; - gu_buf_push(rdr->jit_state->label_patches, PgfLabelPatch, label_patch); - - PgfCallPatch call_patch; - call_patch.cid = id; - call_patch.ref = jump-6; - gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, call_patch); - - jit_prepare(2); - jit_pusharg_p(JIT_V1); - jit_getarg_p(JIT_V2, es_arg); - jit_pusharg_p(JIT_V2); - jit_finish(pgf_evaluate_save_variables); - break; - } - case PGF_INSTR_CASE_INT: { - int n = pgf_read_int(rdr); - int offset = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "CASE_INT %d %04d\n", n, curr_label+offset); -#endif - break; - } - case PGF_INSTR_CASE_STR: { - GuString s = pgf_read_string(rdr); - int offset = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "CASE_STR %s %04d\n", s, curr_label+offset); -#endif - break; - } - case PGF_INSTR_CASE_FLT: { - double d = pgf_read_double(rdr); - int offset = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "CASE_FLT %f %04d\n", d, curr_label+offset); -#endif - break; - } - case PGF_INSTR_ALLOC: { - size_t size = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "ALLOC %d\n", size); -#endif - jit_prepare(2); - jit_movi_ui(JIT_V0, size*sizeof(void*)); - jit_pusharg_ui(JIT_V0); - jit_getarg_p(JIT_V0, es_arg); - jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,pool)); - jit_pusharg_p(JIT_V0); - jit_finish(gu_malloc); - jit_retval_p(JIT_V1); - - curr_offset = 0; - break; - } - case PGF_INSTR_PUT_CONSTR: { - PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUT_CONSTR %s\n", id); + if (label > 0) + gu_printf(out, err, " "); #endif - jit_movi_p(JIT_V0, pgf_evaluate_value); - jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); - curr_offset++; - - PgfCallPatch patch; - patch.cid = id; - patch.ref = jit_movi_p(JIT_V0, jit_forward()); - jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); - curr_offset++; - - gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch); - break; - } - case PGF_INSTR_PUT_CLOSURE: { - size_t addr = pgf_read_int(rdr); + uint8_t opcode = pgf_read_tag(rdr); + switch (opcode) { + case PGF_INSTR_ENTER: { #ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUT_CLOSURE %d\n", addr); -#endif - break; - } - case PGF_INSTR_PUT_INT: { - size_t n = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUT_INT %d\n", n); -#endif - break; - } - case PGF_INSTR_PUT_STR: { - size_t addr = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUT_STR %d\n", addr); -#endif - break; - } - case PGF_INSTR_PUT_FLT: { - size_t addr = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUT_FLT %d\n", addr); -#endif - - break; - } - case PGF_INSTR_SET_VALUE: { - size_t offset = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "SET_VALUE %d\n", offset); -#endif - jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*)); - jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); - curr_offset++; - break; - } - case PGF_INSTR_SET_VARIABLE: { - size_t index = pgf_read_int(rdr); -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "SET_VARIABLE %d\n", index); + gu_printf(out, err, "ENTER\n"); #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_last); - jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*)); - jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); - curr_offset++; - break; - } - case PGF_INSTR_PUSH_VALUE: { - size_t offset = pgf_read_int(rdr); + jit_prolog(2); + es_arg = jit_arg_p(); + closure_arg = jit_arg_p(); + break; + } + case PGF_INSTR_EVAL_ARG_VAR: { + size_t index = pgf_read_int(rdr); #ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUSH_VALUE %d\n", offset); + gu_printf(out, err, "EVAL_ARG_VAR %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); - if (offset == 0) { - jit_str_p(JIT_RET, JIT_V1); - } else { + 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_last); + jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*)); + jit_prepare(2); + jit_pusharg_p(JIT_V0); + jit_getarg_p(JIT_V2, es_arg); + jit_pusharg_p(JIT_V2); + jit_ldr_p(JIT_V0, JIT_V0); + jit_finishr(JIT_V0); + jit_retval_p(JIT_V1); + jit_ldxi_p(JIT_V0, JIT_V1, offsetof(PgfValue, absfun)); + break; + } + case PGF_INSTR_CASE: { + PgfCId id = pgf_read_cid(rdr, rdr->opool); + int target = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE %s %03d\n", id, target); +#endif + jit_insn *jump= + jit_bnei_i(jit_forward(), JIT_V0, (int) jit_forward()); + + PgfSegmentPatch label_patch; + label_patch.segment = target; + label_patch.ref = jump; + label_patch.is_abs = false; + gu_buf_push(rdr->jit_state->segment_patches, PgfSegmentPatch, label_patch); + + PgfCallPatch call_patch; + call_patch.cid = id; + call_patch.ref = jump-6; + gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, call_patch); + + jit_prepare(2); + jit_pusharg_p(JIT_V1); + jit_getarg_p(JIT_V2, es_arg); + jit_pusharg_p(JIT_V2); + jit_finish(pgf_evaluate_save_variables); + break; + } + case PGF_INSTR_CASE_INT: { + int n = pgf_read_int(rdr); + int target = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_INT %d %03d\n", n, target); +#endif + break; + } + case PGF_INSTR_CASE_STR: { + GuString s = pgf_read_string(rdr); + int target = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_STR %s %03d\n", s, target); +#endif + break; + } + case PGF_INSTR_CASE_FLT: { + double d = pgf_read_double(rdr); + int target = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_FLT %f %03d\n", d, target); +#endif + break; + } + case PGF_INSTR_ALLOC: { + size_t size = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "ALLOC %d\n", size); +#endif + jit_prepare(2); + jit_movi_ui(JIT_V0, size*sizeof(void*)); + jit_pusharg_ui(JIT_V0); + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,pool)); + jit_pusharg_p(JIT_V0); + jit_finish(gu_malloc); + jit_retval_p(JIT_V1); + + curr_offset = 0; + break; + } + case PGF_INSTR_PUT_CONSTR: { + PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_CONSTR %s\n", id); +#endif + + jit_movi_p(JIT_V0, pgf_evaluate_value); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + PgfCallPatch patch; + patch.cid = id; + patch.ref = jit_movi_p(JIT_V0, jit_forward()); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch); + break; + } + case PGF_INSTR_PUT_FUN: { + PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_FUN %s\n", id); +#endif + + PgfCallPatch patch; + patch.cid = id; + patch.ref = jit_movi_p(JIT_V0, jit_forward()); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfAbsFun,function)); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch); + break; + } + case PGF_INSTR_PUT_CLOSURE: { + size_t target = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_CLOSURE %03d\n", target); +#endif + + PgfSegmentPatch patch; + patch.segment = target; + patch.ref = jit_movi_p(JIT_V0, jit_forward()); + patch.is_abs = true; + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + gu_buf_push(rdr->jit_state->segment_patches, PgfSegmentPatch, patch); + break; + } + case PGF_INSTR_PUT_INT: { + size_t n = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_INT %d\n", n); +#endif + break; + } + case PGF_INSTR_PUT_STR: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_STR %d\n", addr); +#endif + break; + } + case PGF_INSTR_PUT_FLT: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_FLT %d\n", addr); +#endif + + break; + } + case PGF_INSTR_SET_VALUE: { + size_t offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "SET_VALUE %d\n", offset); +#endif jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*)); - jit_str_p(JIT_RET, JIT_V0); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + break; } - break; - } - case PGF_INSTR_PUSH_VARIABLE: { - size_t index = pgf_read_int(rdr); + case PGF_INSTR_SET_ARG_VAR: { + size_t index = pgf_read_int(rdr); #ifdef PGF_JIT_DEBUG - gu_printf(out, err, "PUSH_VARIABLE %d\n", index); + gu_printf(out, err, "SET_ARG_VAR %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); + 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_last); + jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*)); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + break; + } + case PGF_INSTR_PUSH_VALUE: { + size_t offset = pgf_read_int(rdr); #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: -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "FAIL\n"); -#endif - break; - case PGF_INSTR_RET: { - size_t count = pgf_read_int(rdr); - -#ifdef PGF_JIT_DEBUG - gu_printf(out, err, "RET %d\n", count); + gu_printf(out, err, "PUSH_VALUE %d\n", offset); #endif - jit_prepare(2); - jit_movi_ui(JIT_V0, count); - jit_pusharg_p(JIT_V0); - jit_getarg_p(JIT_V0, es_arg); - jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack)); - jit_pusharg_p(JIT_V0); - jit_finish(gu_buf_trim_n); + 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_ARG_VAR: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUSH_ARG_VAR %d\n", index); +#endif - jit_movr_p(JIT_RET, JIT_V1); - jit_ret(); - break; - } - default: - gu_impossible(); + 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_PUSH_FREE_VAR: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUSH_FREE_VAR %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_getarg_p(JIT_V0, closure_arg); + jit_ldxi_p(JIT_V0, JIT_V0, sizeof(PgfClosure)+index*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: +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "FAIL\n"); +#endif + break; + case PGF_INSTR_RET: { + size_t count = pgf_read_int(rdr); + +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "RET %d\n", count); +#endif + + if (count > 0) { + jit_prepare(2); + jit_movi_ui(JIT_V0, count); + jit_pusharg_p(JIT_V0); + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack)); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_trim_n); + } + + jit_movr_p(JIT_RET, JIT_V1); + jit_ret(); + break; + } + default: + gu_impossible(); + } } } } diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index b5c301e3b..2064e9a3b 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -136,24 +136,29 @@ instance Binary Equation where get = liftM2 Equ get get instance Binary Instr where - put (EVAL n) = putWord8 0 >> put n - put (CASE id l ) = putWord8 1 >> put (id,l) - put (CASE_INT n l ) = putWord8 2 >> put (n,l) - put (CASE_STR s l ) = putWord8 3 >> put (s,l) - put (CASE_FLT d l ) = putWord8 4 >> put (d,l) - put (ALLOC n) = putWord8 5 >> put n - put (PUT_CONSTR id) = putWord8 6 >> put id - put (PUT_CLOSURE l) = putWord8 7 >> put l - put (PUT_INT n) = putWord8 8 >> put n - put (PUT_STR s) = putWord8 9 >> put s - 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 (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 + put (ENTER ) = putWord8 0 + put (EVAL_ARG_VAR n) = putWord8 1 >> put n + put (EVAL_FREE_VAR n)= putWord8 2 >> put n + put (CASE id l ) = putWord8 3 >> put (id,l) + put (CASE_INT n l ) = putWord8 4 >> put (n,l) + put (CASE_STR s l ) = putWord8 5 >> put (s,l) + put (CASE_FLT d l ) = putWord8 6 >> put (d,l) + put (ALLOC n) = putWord8 7 >> put n + put (PUT_CONSTR id) = putWord8 8 >> put id + put (PUT_FUN id) = putWord8 9 >> put id + put (PUT_CLOSURE l) = putWord8 10 >> put l + put (PUT_INT n) = putWord8 11 >> put n + put (PUT_STR s) = putWord8 12 >> put s + put (PUT_FLT d) = putWord8 13 >> put d + put (SET_VALUE n) = putWord8 14 >> put n + put (SET_ARG_VAR n) = putWord8 15 >> put n + put (SET_FREE_VAR n) = putWord8 16 >> put n + put (PUSH_VALUE n) = putWord8 17 >> put n + put (PUSH_ARG_VAR n) = putWord8 18 >> put n + put (PUSH_FREE_VAR n)= putWord8 19 >> put n + put (TAIL_CALL id) = putWord8 20 >> put id + put (FAIL ) = putWord8 21 + put (RET n) = putWord8 22 >> put n instance Binary Type where diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs index bcf21ed9b..2e317d4c0 100644 --- a/src/runtime/haskell/PGF/ByteCode.hs +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -6,46 +6,57 @@ import Text.PrettyPrint type CodeLabel = Int data Instr - = EVAL {-# UNPACK #-} !Int + = ENTER + | EVAL_ARG_VAR {-# UNPACK #-} !Int + | EVAL_FREE_VAR {-# UNPACK #-} !Int | CASE CId {-# UNPACK #-} !CodeLabel | CASE_INT Int {-# UNPACK #-} !CodeLabel | CASE_STR String {-# UNPACK #-} !CodeLabel | CASE_FLT Double {-# UNPACK #-} !CodeLabel | ALLOC {-# UNPACK #-} !Int | PUT_CONSTR CId + | PUT_FUN CId | PUT_CLOSURE {-# UNPACK #-} !CodeLabel | PUT_INT {-# UNPACK #-} !Int | PUT_STR String | PUT_FLT {-# UNPACK #-} !Double - | SET_VALUE {-# UNPACK #-} !Int - | SET_VARIABLE {-# UNPACK #-} !Int - | PUSH_VALUE {-# UNPACK #-} !Int - | PUSH_VARIABLE {-# UNPACK #-} !Int + | SET_VALUE {-# UNPACK #-} !Int + | SET_ARG_VAR {-# UNPACK #-} !Int + | SET_FREE_VAR {-# UNPACK #-} !Int + | PUSH_VALUE {-# UNPACK #-} !Int + | PUSH_ARG_VAR {-# UNPACK #-} !Int + | PUSH_FREE_VAR {-# UNPACK #-} !Int | TAIL_CALL CId + | UPDATE | FAIL | RET {-# UNPACK #-} !Int -ppCode :: CodeLabel -> [Instr] -> Doc -ppCode l [] = empty -ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is +ppCode :: Int -> [[Instr]] -> Doc +ppCode l [] = empty +ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss -ppInstr l (EVAL n) = text "EVAL " <+> int n -ppInstr l (CASE id o ) = text "CASE " <+> ppCId id <+> ppLabel (l+o+1) -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 (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 +ppInstr (ENTER ) = text "ENTER" +ppInstr (EVAL_ARG_VAR n) = text "EVAL_ARG_VAR " <+> int n +ppInstr (EVAL_FREE_VAR n) = text "EVAL_FREE_VAR" <+> int n +ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l +ppInstr (CASE_INT n l ) = text "CASE_INT " <+> int n <+> ppLabel l +ppInstr (CASE_STR str l ) = text "CASE_STR " <+> text (show str) <+> ppLabel l +ppInstr (CASE_FLT d l ) = text "CASE_FLT " <+> double d <+> ppLabel l +ppInstr (ALLOC n) = text "ALLOC " <+> int n +ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id +ppInstr (PUT_FUN id) = text "PUT_FUN " <+> ppCId id +ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE " <+> ppLabel l +ppInstr (PUT_INT n ) = text "PUT_INT " <+> int n +ppInstr (PUT_STR str ) = text "PUT_STR " <+> text (show str) +ppInstr (PUT_FLT d ) = text "PUT_FLT " <+> double d +ppInstr (SET_VALUE n) = text "SET_VALUE " <+> int n +ppInstr (SET_ARG_VAR n) = text "SET_ARG_VAR " <+> int n +ppInstr (SET_FREE_VAR n) = text "SET_FREE_VAR " <+> int n +ppInstr (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n +ppInstr (PUSH_ARG_VAR n) = text "PUSH_ARG_VAR " <+> int n +ppInstr (PUSH_FREE_VAR n) = text "PUSH_FREE_VAR" <+> int n +ppInstr (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id +ppInstr (FAIL ) = text "FAIL" +ppInstr (RET n) = text "RET " <+> int n -ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s) +ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s) diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 76dbc616a..e9263cc1c 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -28,11 +28,11 @@ data PGF = PGF { data Abstr = Abstr { aflags :: Map.Map CId Literal, -- ^ value of a flag - funs :: Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double),-- ^ type, arrity and definition of function + probability - cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category - -- 2. functions of a category. The functions are stored - -- in decreasing probability order. - -- 3. probability + funs :: Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double),-- ^ type, arrity and definition of function + probability + cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category + -- 2. functions of a category. The functions are stored + -- in decreasing probability order. + -- 3. probability } data Concr = Concr { diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 0b4ccc554..80a615e67 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -325,8 +325,8 @@ data Value | VClosure Env Expr | VImplArg Value -type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- type and def of a fun - , Int -> Maybe Expr -- lookup for metavariables +type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[[Instr]]),Double) -- type and def of a fun + , Int -> Maybe Expr -- lookup for metavariables ) type Env = [Value] diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 1aabce09d..a9985cdeb 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -29,13 +29,13 @@ ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' -ppFun :: CId -> (Type,Int,Maybe ([Equation],[Instr]),Double) -> Doc +ppFun :: CId -> (Type,Int,Maybe ([Equation],[[Instr]]),Double) -> Doc ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] $$ + (if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]) $$ ppCode 0 code ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'