msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

full support for recursive def rules in the C runtime

Browse Source
This commit is contained in:
kr.angelov
2014-09-05 10:09:43 +00:00
parent fe8daf7f94
commit 5e5ad8f2db
11 changed files with 513 additions and 366 deletions
Download Patch File Download Diff File Expand all files Collapse all files

158
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -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

4
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -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

2
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -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)])

2
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -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

11
src/runtime/c/pgf/data.h
View File

@@ -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

570
src/runtime/c/pgf/jit.c
View File

@@ -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();
}
}
}
}

41
src/runtime/haskell/PGF/Binary.hs
View File

@@ -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

65
src/runtime/haskell/PGF/ByteCode.hs
View File

@@ -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)

10
src/runtime/haskell/PGF/Data.hs
View File

@@ -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 {

4
src/runtime/haskell/PGF/Expr.hs
View File

@@ -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]

12
src/runtime/haskell/PGF/Printer.hs
View File

@@ -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 ';'