Add: serializer

Author: codybartfast

src/custom.c

@@ -278,6 +278,37 @@ static obj add_extras(int ex, obj env)
 		define_variable(of_identifier("set-cdr!"),
 				of_function(set_cdr_p), env);
 	}
+	if (ex >= 338) {
+		evalstr("(define (clear! cell)"
+			"  (set-car! cell false))",
+			env);
+		evalstr("(define (test-and-set! cell)"
+			"  (__%%lock"
+			"    (if (car cell)"
+			"        true"
+			"        (begin (set-car! cell true)"
+			"               false))))",
+			env);
+		evalstr("(define (make-mutex)"
+			"  (let ((cell (list false)))            "
+			"    (define (the-mutex m)"
+			"      (cond ((eq? m 'acquire)"
+			"             (if (test-and-set! cell)"
+			"                 (the-mutex 'acquire)))"
+			"            ((eq? m 'release) (clear! cell))))"
+			"    the-mutex))",
+			env);
+		evalstr("(define (make-serializer)"
+			"  (let ((mutex (make-mutex)))"
+			"    (lambda (p)"
+			"      (define (serialized-p . args)"
+			"        (mutex 'acquire)"
+			"        (let ((val (apply p args)))"
+			"          (mutex 'release)"
+			"          val))"
+			"      serialized-p)))",
+			env);
+	}
 	if (ex >= 350) {
 		evalstr("(define (force delayed-obj) (delayed-obj))", env);
 		add_stream(env);

src/eceval.c

@@ -88,6 +88,7 @@ static void set_proc_name(struct core *cr)
 
 static obj ecevalgoto(struct core *cr, bool yield)
 {
+	bool locked = false;
 	obj go_obj = restore(cr);
 	goto go_obj;
 
@@ -141,6 +142,8 @@ static obj ecevalgoto(struct core *cr, bool yield)
 		goto ev_parallel_eval;
 	if (is_parallel_execute(cr->expr))
 		goto ev_parallel_execute;
+	if (is_lock(cr->expr))
+		goto ev_lock;
 	if (is_ecapply(cr->expr))
 		goto ev_apply;
 	if (is_application(cr->expr))
@@ -407,6 +410,21 @@ static obj ecevalgoto(struct core *cr, bool yield)
 	go_obj = cr->cont;
 	goto go_obj;
 
+ev_lock:
+	if (locked) {
+		return error_internal(AREA, "Attempted to lock twice");
+	}
+	save(cr->cont, cr);
+	locked = true;
+	cr->cont = ev_lock_done;
+	cr->expr = cons(begin, cdr(cr->expr));
+	goto eval_dispatch;
+
+ev_lock_done:
+	cr->cont = restore(cr);
+	locked = false;
+	goto go_cont;
+
 // new
 ev_apply:
 	save(cr->cont, cr);
@@ -442,13 +460,12 @@ static obj ecevalgoto(struct core *cr, bool yield)
 	return error_eval(AREA, "Unknown procedure type: %s", errstr(cr->proc));
 
 go_cont:
-	if (yield) {
+	if (yield && !locked) {
 		save(cr->cont, cr);
 		return yielded;
 	}
 	go_obj = cr->cont;
 go_obj:
-// printf("obj: %s\n", to_string(go_obj));
 	if (is_eq(go_obj, ev_return_caller))
 		return cr->val;
 	if (is_eq(go_obj, ev_appl_accum_last_arg))
@@ -469,6 +486,8 @@ static obj ecevalgoto(struct core *cr, bool yield)
 		goto eval_dispatch;
 	if (is_eq(go_obj, ev_if_decide))
 		goto ev_if_decide;
+	if (is_eq(go_obj, ev_lock_done))
+		goto ev_lock_done;
 	if (is_eq(go_obj, ev_quoted))
 		goto ev_quoted;
 	if (is_eq(go_obj, ev_sequence_continue))

src/mceval.c

@@ -626,3 +626,8 @@ bool is_parallel_eval(obj exp)
 {
 	return is_tagged_list(exp, parallel_eval_s);
 }
+
+bool is_lock(obj exp)
+{
+	return is_tagged_list(exp, lock);
+}

src/mceval.h

@@ -72,5 +72,6 @@ obj quasi_to_combination(obj exp);
 
 bool is_parallel_execute(obj exp);
 bool is_parallel_eval(obj exp);
+bool is_lock(obj exp);
 
 #endif

src/obj.c

@@ -256,6 +256,7 @@ SYMBOL_VAR(lambda)
 SYMBOL_VAR(let)
 SYMBOL_VAR(letrec)
 const obj letstar = SYMBOL("let*");
+const obj lock = SYMBOL("__%%lock");
 const obj memo_proc = SYMBOL("memo-proc");
 const obj or_s = SYMBOL("or");
 const obj parallel_eval_s = SYMBOL("parallel-eval");
@@ -279,6 +280,7 @@ SYMBOL_VAR(ev_assignment_1)
 SYMBOL_VAR(ev_definition_1)
 SYMBOL_VAR(ev_eval_dispatch)
 SYMBOL_VAR(ev_if_decide)
+SYMBOL_VAR(ev_lock_done)
 SYMBOL_VAR(ev_quoted)
 SYMBOL_VAR(ev_sequence_continue)
 SYMBOL_VAR(ev_timed_done)

src/obj.h

@@ -138,6 +138,7 @@ extern const obj lambda;
 extern const obj let;
 extern const obj letrec;
 extern const obj letstar;
+extern const obj lock;
 extern const obj memo_proc;
 extern const obj or_s;
 extern const obj parallel_eval_s;
@@ -161,6 +162,7 @@ extern const obj ev_assignment_1;
 extern const obj ev_definition_1;
 extern const obj ev_eval_dispatch;
 extern const obj ev_if_decide;
+extern const obj ev_lock_done;
 extern const obj ev_quoted;
 extern const obj ev_sequence_continue;
 extern const obj ev_timed_done;