now (+) in the abstract syntax works, i.e. it knows how to deal with partial sums

src/compiler/GF/Compile/GenerateBC.hs

@@ -86,7 +86,7 @@ mkFail arity st1 (Just (st0,l))
   | otherwise      = [JUMP l]
 
 compileBody gr arity st vs e bs =
-  let eval fun args 
+  let eval st fun args 
         | arity == 0 = let (st1,is) = pushArgs (st+2) (reverse args)
                            fun'     = shiftIVal st1 fun
                        in [PUSH_FRAME]++is++[EVAL fun' UpdateCall]
@@ -97,7 +97,7 @@ compileBody gr arity st vs e bs =
 
 compileFun gr eval st vs (Abs _ x e) h0 bs args =
   let (h1,bs1,arg,is1) = compileLambda gr st vs [x] e h0 bs
-  in (h1,bs1,is1++eval arg args)
+  in (h1,bs1,is1++eval st arg args)
 compileFun gr eval st vs (App e1 e2) h0 bs args =
   let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs
       (h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args)
@@ -105,7 +105,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
 compileFun gr eval st vs (Q (m,id))  h0 bs args =
   case lookupAbsDef gr m id of
     Ok (_,Just _)
-       -> (h0,bs,eval (GLOBAL (i2i id)) args)
+       -> (h0,bs,eval st (GLOBAL (i2i id)) args)
     _  -> let Ok ty = lookupFunType gr m id
               (ctxt,_,_) = typeForm ty
               c_arity    = length ctxt
@@ -114,9 +114,9 @@ compileFun gr eval st vs (Q (m,id))  h0 bs args =
               diff   = c_arity-n_args
           in if diff <= 0
                then if n_args == 0
-                      then (h0,bs,eval (GLOBAL (i2i id)) [])
+                      then (h0,bs,eval st (GLOBAL (i2i id)) [])
                       else let h1  = h0 + 2 + n_args
-                           in (h1,bs,PUT_CONSTR (i2i id):is1++eval (HEAP h0) [])
+                           in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
                else let h1  = h0 + 1 + n_args
                         is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
                         b   = CHECK_ARGS diff :
@@ -126,34 +126,43 @@ compileFun gr eval st vs (Q (m,id))  h0 bs args =
                               TUCK (ARG_VAR 0) diff :
                               EVAL (HEAP h0) (TailCall diff) :
                               []
-                    in (h1,b:bs,PUT_CLOSURE (length bs):is1++eval (HEAP h0) [])
+                    in (h1,b:bs,PUT_CLOSURE (length bs):is1++eval st (HEAP h0) [])
 compileFun gr eval st vs (QC qid)    h0 bs args =
   compileFun gr eval st vs (Q qid) h0 bs args
 compileFun gr eval st vs (Vr x)      h0 bs args =
-  (h0,bs,eval (getVar vs x) args)
+  (h0,bs,eval st (getVar vs x) args)
 compileFun gr eval st vs (EInt n)    h0 bs _  =
   let h1 = h0 + 2
-  in (h1,bs,PUT_LIT (LInt n) : eval (HEAP h0) [])
+  in (h1,bs,PUT_LIT (LInt n) : eval st (HEAP h0) [])
 compileFun gr eval st vs (K s)       h0 bs _  =
   let h1 = h0 + 2
-  in (h1,bs,PUT_LIT (LStr s) : eval (HEAP h0) [])
+  in (h1,bs,PUT_LIT (LStr s) : eval st (HEAP h0) [])
 compileFun gr eval st vs (EFloat d)  h0 bs _  =
   let h1 = h0 + 2
-  in (h1,bs,PUT_LIT (LFlt d) : eval (HEAP h0) [])
+  in (h1,bs,PUT_LIT (LFlt d) : eval st (HEAP h0) [])
 compileFun gr eval st vs (Typed e _) h0 bs args =
   compileFun gr eval st vs e h0 bs args
 compileFun gr eval st vs (Let (x, (_, e1)) e2) h0 bs args =
   let (h1,bs1,arg,is1) = compileLambda gr st vs [] e1 h0 bs
       (h2,bs2,is2) = compileFun gr eval st ((x,arg):vs) e2 h1 bs1 args
   in (h2,bs2,is1++is2)
-compileFun gr eval st vs (Glue e1 e2) h0 bs args =
+compileFun gr eval st vs e@(Glue e1 e2) h0 bs args =
-  let eval' fun args = [PUSH_FRAME]++is++[EVAL fun' RecCall]
+  let eval' st fun args = [PUSH_FRAME]++is++[EVAL fun' RecCall]
-                       where
+                          where
-                         (st1,is) = pushArgs (st+2) (reverse args)
+                            (st1,is) = pushArgs (st+2) (reverse args)
-                         fun'     = shiftIVal st fun
+                            fun'     = shiftIVal st fun
-      (h1,bs1,is1) = compileFun gr eval' st vs e1 h0 bs  args
+
-      (h2,bs2,is2) = compileFun gr eval' st vs e2 h1 bs1 args
+      flatten (Glue e1 e2) h0 bs =
-  in (h2,bs2,is1++is2++[ADD])
+        let (h1,bs1,is1) = flatten e1 h0 bs
+            (h2,bs2,is2) = flatten e2 h1 bs1
+        in (h2,bs2,is1++is2)
+      flatten e            h0 bs =
+        let (h1,bs1,is1) = compileFun gr eval' (st+3) vs e  h0 bs  args
+        in (h1,bs1,is1++[ADD])
+
+      (h1,bs1,is) = flatten e h0 bs
+
+  in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) [])
 compileFun gr eval st vs e _ _ _ = error (show e)
 
 compileArg gr st vs (Q(m,id)) h0 bs =

src/runtime/c/pgf/data.h

@@ -141,7 +141,9 @@ typedef enum {
   PGF_INSTR_DROP        = 16,
   PGF_INSTR_JUMP        = 17,
   PGF_INSTR_FAIL        = 18,
-  PGF_INSTR_ADD         = 19,
+  PGF_INSTR_PUSH_ACCUM  = 19,
+  PGF_INSTR_POP_ACCUM   = 20,
+  PGF_INSTR_ADD         = 21,
 } PgfInstruction;
 
 typedef GuSeq PgfConcrs;

src/runtime/c/pgf/evaluator.c

@@ -313,6 +313,48 @@ pgf_value2expr(PgfEvalState* state, int level, PgfClosure* clos, GuPool* pool)
 				               PgfExprVar,
 				               &expr, pool);
 			evar->var = level - fun->level - 1;
+		} else if (val->fun->code == state->eval_gates->evaluate_sum) {
+			PgfValueSum* sum = (PgfValueSum*) val->fun;
+
+			PgfExpr e1,e2;
+			PgfExprFun *efun =
+				gu_new_flex_variant(PGF_EXPR_FUN,
+				                    PgfExprFun,
+				                    fun, 2,
+				                    &e1, pool);
+			strcpy(efun->fun, "+");
+
+			PgfExprLit *elit =
+				gu_new_variant(PGF_EXPR_LIT,
+				               PgfExprLit,
+				               &e2, pool);
+			elit->lit = sum->lit;
+			
+			PgfExprApp* eapp =
+				gu_new_variant(PGF_EXPR_APP,
+				               PgfExprApp,
+				               &expr, pool);
+			eapp->fun = e1;
+			eapp->arg = e2;
+	
+			size_t n_consts = gu_buf_length(sum->consts);
+			for (size_t i = 0; i < n_consts; i++) {
+				PgfClosure* con =
+					gu_buf_get(sum->consts, PgfClosure*, i);
+
+				PgfExpr fun = expr;
+				PgfExpr arg = 
+					pgf_value2expr(state, level, con, pool);
+				if (gu_variant_is_null(arg))
+					return gu_null_variant;
+
+				PgfExprApp* e =
+					gu_new_variant(PGF_EXPR_APP,
+					               PgfExprApp,
+					               &expr, pool);
+				e->fun = fun;
+				e->arg = arg;
+			}
 		} else {
 			PgfAbsFun* absfun = gu_container(val->fun, PgfAbsFun, closure);
 			expr   = absfun->ep.expr;
@@ -370,3 +412,118 @@ pgf_compute(PgfPGF* pgf, PgfExpr expr, GuExn* err, GuPool* pool, GuPool* out_poo
 
 	return pgf_value2expr(state, 0, &thunk->header, out_pool);
 }
+
+void
+pgf_evaluate_accum_init_int(PgfEvalState* state, 
+                            PgfEvalAccum* accum, int val)
+{
+	PgfLiteralInt *lit_int =
+		gu_new_variant(PGF_LITERAL_INT,
+	                   PgfLiteralInt,
+	                   &accum->lit,
+					   state->pool);
+	lit_int->val = val;
+	accum->consts = NULL;
+}
+
+void
+pgf_evaluate_accum_init_str(PgfEvalState* state, 
+                            PgfEvalAccum* accum, GuString val)
+{
+	if (val == NULL)
+		val = "";
+
+	PgfLiteralStr *lit_str =
+		gu_new_flex_variant(PGF_LITERAL_STR,
+							PgfLiteralStr,
+							val, strlen(val)+1,
+							&accum->lit, state->pool);
+	strcpy((char*) lit_str->val, (char*) val);
+	accum->consts = NULL;
+}
+
+void
+pgf_evaluate_accum_init_flt(PgfEvalState* state, 
+                            PgfEvalAccum* accum, float val)
+{
+	PgfLiteralFlt *lit_flt =
+		gu_new_variant(PGF_LITERAL_FLT,
+					   PgfLiteralFlt,
+					   &accum->lit,
+					   state->pool);
+	lit_flt->val = val;
+	accum->enter_stack_ptr = state->enter_stack_ptr;
+	state->enter_stack_ptr = ((void*)accum)-sizeof(void*)*2;
+	accum->consts = NULL;
+}
+
+static void
+pgf_evaluate_accum_add_helper(PgfEvalAccum* accum, PgfLiteral lit)
+{
+	GuVariantInfo ei = gu_variant_open(lit);
+	switch (ei.tag) {
+	case PGF_LITERAL_INT: {
+		PgfLiteralInt* lint = ei.data;
+		((PgfLiteralInt*)gu_variant_data(accum->lit))->val += lint->val;
+		break;
+	}
+	case PGF_LITERAL_STR: {
+		PgfLiteralStr* lstr = ei.data;
+		break;
+	}
+	case PGF_LITERAL_FLT: {
+		PgfLiteralFlt* lflt = ei.data;
+		((PgfLiteralFlt*)gu_variant_data(accum->lit))->val += lflt->val;
+		break;
+	}
+	}
+}
+
+void
+pgf_evaluate_accum_add(PgfEvalState* state,
+                       PgfEvalAccum* accum, PgfClosure* closure)
+{
+	if (closure->code == state->eval_gates->evaluate_value_lit) {
+		PgfValueLit* val = (PgfValueLit*) closure;
+		pgf_evaluate_accum_add_helper(accum, val->lit);
+	} else if (closure->code == state->eval_gates->evaluate_value_const) {
+		if (accum->consts == NULL)
+			accum->consts = gu_new_buf(PgfClosure*, state->pool);
+
+		PgfValuePAP* pap = (PgfValuePAP*) closure;
+		
+		if (pap->fun->code == state->eval_gates->evaluate_sum) {
+			PgfValueSum* val = (PgfValueSum*) ((PgfValuePAP*) closure)->fun;
+			pgf_evaluate_accum_add_helper(accum, val->lit);
+
+			size_t n_consts = gu_buf_length(val->consts);
+			for (size_t i = 0; i < n_consts; i++) {
+				PgfClosure* clos = gu_buf_get(val->consts, PgfClosure*, i);
+				gu_buf_push(accum->consts, PgfClosure*, clos);
+			}
+		} else {
+			gu_buf_push(accum->consts, PgfClosure*, closure);
+		}
+	} else {
+		gu_impossible();
+	}
+}
+
+PgfClosure*
+pgf_evaluate_accum_done(PgfEvalState* state, PgfEvalAccum* accum)
+{
+	state->enter_stack_ptr = accum->enter_stack_ptr;
+
+	if (accum->consts == NULL) {
+		PgfValueLit* val = gu_new(PgfValueLit, state->pool);
+		val->header.code = state->eval_gates->evaluate_value_lit;
+		val->lit = accum->lit;
+		return &val->header;
+	} else {
+		PgfValueSum* val = gu_new(PgfValueSum, state->pool);
+		val->header.code = state->eval_gates->evaluate_sum;
+		val->lit = accum->lit;
+		val->consts = accum->consts;
+		return &val->header;
+	}
+}

src/runtime/c/pgf/evaluator.h

@@ -15,9 +15,17 @@ typedef struct {
 	PgfEvalGates* eval_gates; // cached from pgf->abstr->eval_gates
 	GuPool* pool;
 	GuExn* err;
+	void* enter_stack_ptr;
+	void* tmp;              // for temporary register spills
 	PgfIndirection cafs[];  // derived from gu_seq_data(pgf->abstr->eval_gates->cafs)
 } PgfEvalState;
 
+typedef struct {
+	PgfLiteral lit;
+	GuBuf* consts;
+	void* enter_stack_ptr;
+} PgfEvalAccum;
+
 typedef struct PgfEnv PgfEnv;
 
 struct PgfEnv {
@@ -53,6 +61,12 @@ typedef struct {
 	PgfLiteral lit;
 } PgfValueLit;
 
+typedef struct {
+	PgfClosure header;
+	PgfLiteral lit;
+	GuBuf* consts;
+} PgfValueSum;
+
 typedef struct {
 	PgfClosure header;
 	PgfClosure* fun;
@@ -70,6 +84,7 @@ struct PgfEvalGates {
 	PgfFunction evaluate_value_const;
 	PgfFunction evaluate_meta;
 	PgfFunction evaluate_gen;
+	PgfFunction evaluate_sum;
 	PgfFunction evaluate_caf;
 
 	PgfFunction update_closure;
@@ -90,4 +105,23 @@ PgfClosure*
 pgf_evaluate_lambda_application(PgfEvalState* state, PgfExprThunk* lambda,
                                                      PgfClosure* arg);
 
+void
+pgf_evaluate_accum_init_int(PgfEvalState* state, 
+                            PgfEvalAccum* accum, int val);
+
+void
+pgf_evaluate_accum_init_str(PgfEvalState* state, 
+                            PgfEvalAccum* accum, GuString val);
+                            
+void
+pgf_evaluate_accum_init_flt(PgfEvalState* state, 
+                            PgfEvalAccum* accum, float val);
+
+void
+pgf_evaluate_accum_add(PgfEvalState* state, 
+                       PgfEvalAccum* accum, PgfClosure* closure);
+
+PgfClosure*
+pgf_evaluate_accum_done(PgfEvalState* state, PgfEvalAccum* accum);
+
 #endif

src/runtime/c/pgf/jit.c

@@ -371,9 +371,9 @@ pgf_jit_gates(PgfReader* rdr)
 	int closure_arg = jit_arg_p();
 	jit_getarg_p(JIT_VSTATE, es_arg);
 	jit_getarg_p(JIT_VCLOS,  closure_arg);
+	jit_stxi_p(offsetof(PgfEvalState, enter_stack_ptr), JIT_VSTATE, JIT_SP);
 	jit_ldr_p(JIT_R0, JIT_VCLOS);
 	jit_callr(JIT_R0);
-	jit_insn* enter_ret = (void*) jit_get_ip().ptr;
 	jit_movr_p(JIT_RET, JIT_VHEAP);
 	jit_ret();
 
@@ -547,7 +547,9 @@ pgf_jit_gates(PgfReader* rdr)
 	jit_pushr_p(JIT_R0);
 	jit_jmpi(gates->mk_const);
 	jit_patch(ref2);
-	ref2 = jit_bnei_i(jit_forward(), JIT_R0, (int)enter_ret);
+	jit_ldxi_p(JIT_R1, JIT_VSTATE, offsetof(PgfEvalState,enter_stack_ptr));
+	ref2 = jit_bner_p(jit_forward(), JIT_FP, JIT_R1);
+	jit_stxi_p(offsetof(PgfEvalState,tmp), JIT_VSTATE, JIT_R0);
 	jit_subr_p(JIT_R0, JIT_FP, JIT_SP);
 	jit_pushr_i(JIT_R0);
 	jit_prepare(2);
@@ -556,8 +558,8 @@ pgf_jit_gates(PgfReader* rdr)
 	jit_ldxi_p(JIT_R0, JIT_VSTATE, offsetof(PgfEvalState,pool));
 	jit_pusharg_p(JIT_R0);
 	jit_finish(gu_malloc);
-	jit_popr_i(JIT_R1);
 	jit_movr_p(JIT_VHEAP, JIT_RET);
+	jit_popr_i(JIT_R1);
 	jit_movi_p(JIT_R2, gates->evaluate_value_const);
 	jit_str_p(JIT_VHEAP, JIT_R2);
 	jit_stxi_p(offsetof(PgfValuePAP,fun), JIT_VHEAP, JIT_VCLOS);
@@ -570,7 +572,8 @@ pgf_jit_gates(PgfReader* rdr)
 	jit_subi_i(JIT_R1, JIT_R1, sizeof(void*));
 	jit_jmpi(next);
 	jit_patch(ref);
-	jit_jmpi(enter_ret);
+	jit_ldxi_p(JIT_R0, JIT_VSTATE, offsetof(PgfEvalState,tmp));
+	jit_jmpr(JIT_R0);
 	jit_patch(ref2);
 	jit_ldxi_p(JIT_VCLOS, JIT_FP, sizeof(void*));
 	jit_ldr_p(JIT_FP, JIT_FP);
@@ -581,16 +584,21 @@ pgf_jit_gates(PgfReader* rdr)
 	jit_movr_p(JIT_SP, JIT_R0);
 	jit_jmpi(gates->mk_const);
 
-	pgf_jit_make_space(rdr, JIT_CODE_WINDOW*2);
+	pgf_jit_make_space(rdr, JIT_CODE_WINDOW);
 
 	gates->evaluate_gen = jit_get_ip().ptr;
 	jit_jmpi(gates->mk_const);
 
-	pgf_jit_make_space(rdr, JIT_CODE_WINDOW*2);
+	pgf_jit_make_space(rdr, JIT_CODE_WINDOW);
 
 	gates->evaluate_meta = jit_get_ip().ptr;
 	jit_jmpi(gates->mk_const);
 
+	pgf_jit_make_space(rdr, JIT_CODE_WINDOW);
+
+	gates->evaluate_sum = jit_get_ip().ptr;
+	jit_jmpi(gates->mk_const);
+
 	gates->fin.fn = pgf_jit_finalize_cafs;
 	gates->cafs = NULL;
 	gu_pool_finally(rdr->opool, &gates->fin);
@@ -1167,10 +1175,88 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
 #endif
 				jit_jmpi(abstr->eval_gates->mk_const);
 				break;
+			case PGF_INSTR_PUSH_ACCUM:
+				jit_subi_p(JIT_SP, JIT_SP, sizeof(PgfEvalAccum));
+
+				switch (mod) {
+				case 0: {
+					int val = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+					gu_printf(out, err, "PUSH_ACCUM  %d\n", val);
+#endif
+					jit_prepare(3);
+					jit_movi_i(JIT_R0, val);
+					jit_movr_p(JIT_R1, JIT_SP);
+					jit_pusharg_p(JIT_R0);
+					jit_pusharg_p(JIT_R1);
+					jit_pusharg_p(JIT_VSTATE);
+					jit_finish(pgf_evaluate_accum_init_int);
+					break;
+				}
+				case 1: {
+					size_t len = pgf_read_len(rdr);
+					uint8_t* buf = alloca(len*6+1);
+					uint8_t* p   = buf;
+					for (size_t i = 0; i < len; i++) {
+						gu_in_utf8_buf(&p, rdr->in, rdr->err);
+					}
+					*p++ = 0;
+
+					GuString val = 
+						*buf ? gu_string_copy((GuString) buf, rdr->opool)
+						     : NULL;
+#ifdef PGF_JIT_DEBUG
+					gu_printf(out, err, "PUSH_ACCUM  \"%s\"\n", buf);
+#endif
+					jit_prepare(3);
+					jit_movi_p(JIT_R0, val);
+					jit_movr_p(JIT_R1, JIT_SP);
+					jit_pusharg_p(JIT_R0);
+					jit_pusharg_p(JIT_R1);
+					jit_pusharg_p(JIT_VSTATE);
+					jit_finish(pgf_evaluate_accum_init_str);
+					break;
+				}
+				case 2: {
+					double val = pgf_read_double(rdr);
+#ifdef PGF_JIT_DEBUG
+					gu_printf(out, err, "PUSH_ACCUM  %f\n", val);
+#endif
+					jit_prepare_d(1);
+					jit_prepare_i(2);
+					jit_movi_d(JIT_FPR0, val);
+					jit_movr_p(JIT_R1, JIT_SP);
+					jit_pusharg_d(JIT_FPR0);
+					jit_pusharg_p(JIT_R1);
+					jit_pusharg_p(JIT_VSTATE);
+					jit_finish(pgf_evaluate_accum_init_flt);
+					break;
+				}
+				default:
+					gu_impossible();
+				}
+				break;
+			case PGF_INSTR_POP_ACCUM:
+#ifdef PGF_JIT_DEBUG
+				gu_printf(out, err, "POP_ACCUM\n");
+#endif
+				jit_prepare(2);
+				jit_pusharg_p(JIT_SP);
+				jit_pusharg_p(JIT_VSTATE);
+				jit_finish(pgf_evaluate_accum_done);
+				jit_addi_p(JIT_SP, JIT_SP, sizeof(PgfEvalAccum));
+				jit_pushr_p(JIT_RET);
+				break;
 			case PGF_INSTR_ADD:
 #ifdef PGF_JIT_DEBUG
 				gu_printf(out, err, "ADD\n");
 #endif
+				jit_prepare(3);
+				jit_movr_p(JIT_R1, JIT_SP);
+				jit_pusharg_p(JIT_VHEAP);
+				jit_pusharg_p(JIT_R1);
+				jit_pusharg_p(JIT_VSTATE);
+				jit_finish(pgf_evaluate_accum_add);
 				break;
 			default:
 				gu_impossible();

src/runtime/haskell/PGF/Binary.hs

@@ -177,7 +177,11 @@ instance Binary Instr where
   put (DROP n             ) = putWord8 64  >> put n
   put (JUMP l             ) = putWord8 68  >> put l
   put (FAIL               ) = putWord8 72
-  put (ADD                ) = putWord8 76
+  put (PUSH_ACCUM (LInt n)) = putWord8 76 >> put n
+  put (PUSH_ACCUM (LStr s)) = putWord8 77 >> put s
+  put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d
+  put (POP_ACCUM          ) = putWord8 80
+  put (ADD                ) = putWord8 84
 
 instance Binary Type where
   put (DTyp hypos cat exps) = put (hypos,cat,exps)

src/runtime/haskell/PGF/ByteCode.hs

@@ -32,6 +32,8 @@ data Instr
   | DROP {-# UNPACK #-} !Int
   | JUMP {-# UNPACK #-} !CodeLabel
   | FAIL
+  | PUSH_ACCUM Literal
+  | POP_ACCUM
   | ADD
 
 data IVal
@@ -71,6 +73,8 @@ ppInstr (TUCK v n       ) = text "TUCK       " <+> ppIVal v <+> int n
 ppInstr (DROP n         ) = text "DROP       " <+> int n
 ppInstr (JUMP l         ) = text "JUMP       " <+> ppLabel l
 ppInstr (FAIL           ) = text "FAIL"
+ppInstr (PUSH_ACCUM  lit) = text "PUSH_ACCUM " <+> ppLit lit
+ppInstr (POP_ACCUM      ) = text "POP_ACCUM"
 ppInstr (ADD            ) = text "ADD"
 
 ppIVal (HEAP     n) = text "hp"  <> parens (int n)