adding experimental auto-force capability

eval.c

@@ -1264,6 +1264,17 @@ sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, se
 #endif
 #endif
 
+#if SEXP_USE_AUTO_FORCE
+sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp thunk) {
+  sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, thunk);
+  sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
+  sexp_promise_donep(res) = 0;
+  sexp_promise_thunk(res) = thunk;
+  sexp_promise_value(res) = SEXP_VOID;
+  return res;
+}
+#endif
+
 #ifdef PLAN9
 #include "opt/plan9.c"
 #endif
@@ -1642,6 +1653,9 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) {
 #endif
 #if SEXP_USE_GREEN_THREADS
   sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1));
+#endif
+#if SEXP_USE_AUTO_FORCE
+  sexp_push(ctx, tmp, sym=sexp_intern(ctx, "auto-force", -1));
 #endif
   sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1));
   sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp);

include/chibi/eval.h

@@ -123,6 +123,7 @@ enum sexp_opcode_names {
   SEXP_OP_READ_CHAR,
   SEXP_OP_PEEK_CHAR,
   SEXP_OP_YIELD,
+  SEXP_OP_FORCE,
   SEXP_OP_RET,
   SEXP_OP_DONE,
   SEXP_OP_NUM_OPCODES

include/chibi/features.h

@@ -249,6 +249,10 @@
 #define SEXP_USE_GREEN_THREADS ! SEXP_USE_NO_FEATURES
 #endif
 
+#ifndef SEXP_USE_AUTO_FORCE
+#define SEXP_USE_AUTO_FORCE 0
+#endif
+
 #ifndef SEXP_USE_NATIVE_X86
 #define SEXP_USE_NATIVE_X86 0
 #endif

include/chibi/sexp.h

@@ -118,6 +118,7 @@ enum sexp_types {
   SEXP_STACK,
   SEXP_CONTEXT,
   SEXP_CPOINTER,
+  SEXP_PROMISE,
   SEXP_NUM_CORE_TYPES
 };
 
@@ -349,6 +350,12 @@ struct sexp_struct {
       sexp bc, lambda, stack, env, fv, parent, child,
         globals, params, proc, name, specific, event;
     } context;
+#if SEXP_USE_AUTO_FORCE
+    struct {
+      int donep;
+      sexp thunk, value;
+    } promise;
+#endif
   } value;
 };
 
@@ -544,6 +551,7 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_seqp(x)        (sexp_check_tag(x, SEXP_SEQ))
 #define sexp_litp(x)        (sexp_check_tag(x, SEXP_LIT))
 #define sexp_contextp(x)    (sexp_check_tag(x, SEXP_CONTEXT))
+#define sexp_promisep(x)    (sexp_check_tag(x, SEXP_PROMISE))
 
 #define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x))
 
@@ -776,6 +784,10 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_stack_top(x)     (sexp_field(x, stack, SEXP_STACK, top))
 #define sexp_stack_data(x)    (sexp_field(x, stack, SEXP_STACK, data))
 
+#define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep))
+#define sexp_promise_thunk(x) (sexp_field(x, promise, SEXP_PROMISE, thunk))
+#define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value))
+
 #define sexp_context_env(x)      (sexp_field(x, context, SEXP_CONTEXT, env))
 #define sexp_context_stack(x)    (sexp_field(x, context, SEXP_CONTEXT, stack))
 #define sexp_context_depth(x)    (sexp_field(x, context, SEXP_CONTEXT, depth))

lib/init.scm

@@ -300,20 +300,6 @@
    (lambda (expr rename compare)
      `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; promises
-
-(define (make-promise thunk)
-  (lambda ()
-    (let ((computed? #f) (result #f))
-      (if (not computed?)
-          (begin
-            (set! result (thunk))
-            (set! computed? #t)))
-      result)))
-
-(define (force x) (if (procedure? x) (x) x))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; exceptions
 
@@ -876,3 +862,19 @@
              ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
              (else (expand (cdr ls))))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; promises
+
+(cond-expand
+ (auto-force
+  (define (force x) x))
+ (else
+  (define (make-promise thunk)
+   (lambda ()
+     (let ((computed? #f) (result #f))
+       (if (not computed?)
+           (begin
+             (set! result (thunk))
+             (set! computed? #t)))
+       result)))
+  (define (force x) (if (procedure? x) (x) x))))

opcodes.c

@@ -178,6 +178,7 @@ _FN2(SEXP_VOID, _I(SEXP_STRING), _I(SEXP_BOOLEAN), "add-module-directory", 0, se
 #if SEXP_USE_GREEN_THREADS
 _OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, SEXP_VOID, SEXP_FALSE, SEXP_FALSE, SEXP_FALSE, 0, "thread-yield!", 0, NULL),
 #endif
+#if SEXP_USE_AUTO_FORCE
+_FN1(_I(SEXP_PROMISE), _I(SEXP_PROCEDURE), "make-promise", 0, sexp_make_promise),
+#endif
 };
-
-

opt/opcode_names.h

@@ -17,5 +17,5 @@ static const char* reverse_opcode_names[] =
    "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
    "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
    "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR",
-   "YIELD", "RET", "DONE",
+   "YIELD", "FORCE", "RET", "DONE",
   };

sexp.c

@@ -116,6 +116,9 @@ static struct sexp_type_struct _sexp_type_specs[] = {
   {SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), 0, 0, 0, 0, 0, 0, "stack", SEXP_FALSE, SEXP_FALSE, NULL},
   {SEXP_CONTEXT, sexp_offsetof(context, bc), 13, 13, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, "context", SEXP_FALSE, SEXP_FALSE, NULL},
   {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, "cpointer", SEXP_FALSE, SEXP_FALSE, NULL},
+#if SEXP_USE_AUTO_FORCE
+  {SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, "promise", SEXP_FALSE, SEXP_FALSE, NULL},
+#endif
 };
 
 #if SEXP_USE_GLOBAL_TYPES

vm.c

@@ -232,8 +232,14 @@ static void generate_opcode_app (sexp ctx, sexp app) {
     ls = ((sexp_opcode_inverse(op)
            && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC))
           ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app)));
-    for ( ; sexp_pairp(ls); ls = sexp_cdr(ls))
+    for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) {
       generate(ctx, sexp_car(ls));
+#if SEXP_USE_AUTO_FORCE
+      if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR)
+          || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR)
+        emit(ctx, SEXP_OP_FORCE);
+#endif
+    }
 
   }
 
@@ -1423,6 +1429,22 @@ sexp sexp_vm (sexp ctx, sexp proc) {
 #endif
     _PUSH(SEXP_VOID);
     break;
+  case SEXP_OP_FORCE:
+#if SEXP_USE_AUTO_FORCE
+    while (sexp_promisep(_ARG1)) {
+      if (sexp_promise_donep(_ARG1)) {
+        _ARG1 = sexp_promise_value(_ARG1);
+      } else {
+        sexp_context_top(ctx) = top;
+        tmp1 = sexp_apply(ctx, sexp_promise_thunk(_ARG1), SEXP_NULL);
+        sexp_promise_value(_ARG1) = tmp1;
+        sexp_promise_donep(_ARG1) = 1;
+        sexp_promise_thunk(_ARG1) = SEXP_FALSE;
+        _ARG1 = tmp1;
+      }
+    }
+#endif
+    break;
   case SEXP_OP_RET:
     i = sexp_unbox_fixnum(stack[fp]);
     stack[fp-i] = _ARG1;