Add: parallel eval (called execute)

Author: codybartfast

src/eceval.c

@@ -16,6 +16,8 @@
 
 #define AREA "ECEVAL"
 
+static obj parallel_execute(obj actions, obj env);
+
 // ln 182
 static obj empty_arglist(void)
 {
@@ -134,6 +136,8 @@ static obj ecevalgoto(struct core *cr, bool yield)
 		goto ev_cons_stream;
 	if (is_time(cr->expr))
 		goto ev_timed;
+	if (is_parallel_execute(cr->expr))
+		goto ev_concurrent_execute;
 	if (is_ecapply(cr->expr))
 		goto ev_apply;
 	if (is_application(cr->expr))
@@ -390,6 +394,9 @@ static obj ecevalgoto(struct core *cr, bool yield)
 	goto go_cont;
 
 // new
+ev_concurrent_execute:
+	return parallel_execute(cdr(cr->expr), cr->env);
+// new
 ev_apply:
 	save(cr->cont, cr);
 	save(cr->env, cr);
@@ -462,14 +469,59 @@ static obj ecevalgoto(struct core *cr, bool yield)
 
 obj eceval(obj expression, obj _environment)
 {
-	obj rslt;
-
 	struct core *cr = dfltcore();
 	cr->expr = expression;
 	cr->env = _environment;
 	cr->cont = ev_return_caller;
 	save_nogc(ev_eval_dispatch, cr);
-	while (is_yielded(rslt = ecevalgoto(cr, false)))
-		;
-	return rslt;
+	return ecevalgoto(cr, false);
+}
+
+static int rand_below(int n)
+{
+	return plat_rand() % n;
+}
+
+static obj parallel_execute(obj actions, obj env)
+{
+	static bool running[NCORE];
+	static int free = 0;
+	int i, j, runcount;
+
+	while (is_pair(actions)) {
+		free++;
+		if (free == NCORE) {
+			return error_arity(
+				AREA,
+				"parallel-execute takes at most %d expressions",
+				(NCORE - 1));
+		}
+		struct core *cr = getcore(free);
+		running[free] = true;
+		cr->expr = car(actions);
+		cr->env = env;
+		cr->cont = ev_return_caller;
+		save_nogc(ev_eval_dispatch, cr);
+		actions = cdr(actions);
+	}
+
+	runcount = free;
+
+	while (runcount) {
+		for (i = 1; i <= free; i++) {
+			if (!running[i]) {
+				continue;
+			}
+			int clicks = rand_below(32);
+			for (j = 0; j < clicks; j++) {
+				if (!is_yielded(ecevalgoto(getcore(i), true))) {
+					running[i] = false;
+					runcount--;
+					break;
+				}
+			}
+		}
+	}
+
+	return finished;
 }

src/mceval.c

@@ -614,3 +614,8 @@ obj quasi_to_combination(obj exp)
 {
 	return quasi_dat(cadr(exp));
 }
+
+bool is_parallel_execute(obj exp)
+{
+	return is_tagged_list(exp, parallel_execute_s);
+}

src/mceval.h

@@ -70,4 +70,6 @@ bool is_amb(obj exp);
 bool is_quasiquote(obj exp);
 obj quasi_to_combination(obj exp);
 
+bool is_parallel_execute(obj exp);
+
 #endif

src/obj.c

@@ -250,13 +250,15 @@ const obj cons_stream = SYMBOL("cons-stream");
 SYMBOL_VAR(define)
 SYMBOL_VAR(delay)
 const obj else_s = SYMBOL("else");
+SYMBOL_VAR(finished)
 const obj if_s = SYMBOL("if");
+SYMBOL_VAR(lambda)
 SYMBOL_VAR(let)
 SYMBOL_VAR(letrec)
 const obj letstar = SYMBOL("let*");
 const obj memo_proc = SYMBOL("memo-proc");
-SYMBOL_VAR(lambda)
 const obj or_s = SYMBOL("or");
+const obj parallel_execute_s = SYMBOL("parallel-execute");
 SYMBOL_VAR(quasiquote)
 SYMBOL_VAR(quote)
 const obj set = SYMBOL("set!");

src/obj.h

@@ -132,14 +132,15 @@ extern const obj cons_stream;
 extern const obj define;
 extern const obj delay;
 extern const obj else_s;
-extern const obj failed;
+extern const obj finished;
 extern const obj if_s;
+extern const obj lambda;
 extern const obj let;
 extern const obj letrec;
 extern const obj letstar;
-extern const obj lambda;
 extern const obj memo_proc;
 extern const obj or_s;
+extern const obj parallel_execute_s;
 extern const obj quasiquote;
 extern const obj quote;
 extern const obj set;

src/primproc.c

@@ -423,7 +423,7 @@ errno_t rand_s(unsigned *);
 #define PLAT_RAND_MAX RAND_MAX
 #endif
 
-static Integer plat_rand(void)
+Integer plat_rand(void)
 {
 #ifdef _WIN32
 	unsigned r;

src/primproc.h

@@ -27,6 +27,7 @@ obj arctan(const obj);
 obj flr(const obj);
 obj sqroot(const obj);
 
+Integer plat_rand(void);
 obj rnd(const obj);
 obj runtime(const obj);
 obj ticks(const obj);

src/register.c

@@ -7,14 +7,14 @@
 
 #define AREA "REGISTER"
 
-static struct core cores[ncore];
+static struct core cores[NCORE];
 
 // global-env
 obj ambenv;
 obj anenv;
 obj svtmp;
 
-const int rootlen = nother + ncore;
+const int rootlen = NOTHER + NCORE;
 static obj rootlst;
 
 static void init(void)
@@ -25,14 +25,14 @@ static void init(void)
 
 	rootlst = emptylst;
 	int i, j;
-	for (i = 0; i < ncore; i++) {
+	for (i = 0; i < NCORE; i++) {
 		obj reglst = emptylst;
-		for (j = 0; j < nreg; j++) {
+		for (j = 0; j < NREG; j++) {
 			reglst = cons(unspecified, reglst);
 		}
 		rootlst = cons(reglst, rootlst);
 	}
-	for (i = 0; i < nother; i++) {
+	for (i = 0; i < NOTHER; i++) {
 		rootlst = cons(unspecified, rootlst);
 	}
 	initdone = true;
@@ -55,7 +55,7 @@ obj getroot(void)
 	set_car(lst, svtmp);
 	lst = cdr(lst);
 
-	for (i = 0; i < ncore; i++, lst = cdr(lst)) {
+	for (i = 0; i < NCORE; i++, lst = cdr(lst)) {
 		struct core *cr = &cores[i];
 		obj reglst = car(lst);
 
@@ -104,7 +104,7 @@ void setroot(obj rlst)
 	svtmp = car(lst);
 	lst = cdr(lst);
 
-	for (i = 0; i < ncore; i++, lst = cdr(lst)) {
+	for (i = 0; i < NCORE; i++, lst = cdr(lst)) {
 		struct core *cr = &cores[i];
 		obj reglst = car(lst);
 
@@ -134,6 +134,16 @@ void setroot(obj rlst)
 	}
 }
 
+struct core *getcore(int idx)
+{
+	if (idx < 0 || NCORE <= idx) {
+		eprintf(AREA, "Invalid core index: %d", idx);
+		exit(1);
+	}
+	init();
+	return &cores[idx];
+}
+
 struct core *dfltcore(void)
 {
 	init();

src/register.h

@@ -14,15 +14,16 @@ struct core {
 	obj unev; //  7
 	obj val; //   8
 };
-#define nreg 8
-#define ncore 16
+#define NREG 8
+#define NCORE 16
 
 // global-env      // 1
 extern obj ambenv; // 2
 extern obj anenv; //  3
 extern obj svtmp; //  4
-#define nother 4
+#define NOTHER 4
 
+struct core *getcore(int);
 struct core *dfltcore(void);
 obj getroot(void);
 void setroot(obj);