runs init code from s.c

i.c

@@ -6,6 +6,7 @@
 /* imports */
 extern obj cx_continuation_2Dclosure_2Dcode;
 extern obj cx__2Aglobals_2A;
+extern obj cx__2Atransformers_2A;
 
 #define istagged(o, t) istagged_inlined(o, t) 
 
@@ -15,6 +16,7 @@ static void wrs_integrable(int argc, struct intgtab_entry *pe, obj port);
 static obj *rds_intgtab(obj *r, obj *sp, obj *hp);
 static obj *rds_stox(obj *r, obj *sp, obj *hp);
 static obj *rds_stoc(obj *r, obj *sp, obj *hp);
+static obj *init_modules(obj *r, obj *sp, obj *hp);
 
 /* platform-dependent optimizations */
 #if defined(__clang__)
@@ -138,9 +140,9 @@ typedef obj* regcall (*ins_t)(IPARAMS);
 #endif
 
 static obj vmhost(obj);
-obj vmcases[7] = { 
+obj vmcases[8] = { 
   (obj)vmhost, (obj)vmhost, (obj)vmhost, (obj)vmhost, 
-  (obj)vmhost, (obj)vmhost, (obj)vmhost 
+  (obj)vmhost, (obj)vmhost, (obj)vmhost, (obj)vmhost 
 };
 /* vmhost procedure */
 static obj vmhost(obj pc)
@@ -151,7 +153,7 @@ static obj vmhost(obj pc)
 jump: 
   switch (objptr_from_obj(pc)-vmcases) {
 
-  case 0: /* execute */    
+  case 0: /* execute-thunk-closure */    
     /* r[0] = self, r[1] = k, r[2] = closure */
     { obj k, arg;
     assert(rc == 3);
@@ -249,6 +251,18 @@ jump:
     rc = 3;
     goto jump; }
 
+  case 7: /* initialize-modules */
+    /* r[0] = clo, r[1] = k */
+    { assert(rc == 2);
+    r[0] = r[1];
+    r = cxm_rgc(NULL, VM_REGC + VM_STACK_LEN);
+    hp = init_modules(r, r+2, hp);
+    r[1] = obj_from_ktrap();
+    r[2] = obj_from_void(0);
+    pc = objptr_from_obj(r[0])[0];
+    rc = 3;
+    goto jump; }
+      
   default: /* inter-host call */
     cxg_hp = hp;
     cxm_rgc(r, 1);
@@ -2921,3 +2935,75 @@ static obj *rds_intgtab(obj *r, obj *sp, obj *hp)
   }
   return hp;
 }
+
+/* protects registers from r to sp=r+2; returns new hp */
+static obj *init_module(obj *r, obj *sp, obj *hp, const char **mod)
+{
+  const char **ent;
+  /* make sure we are called in a clean vm state */
+  assert(r = cxg_regs); assert(sp-r == 2); /* k, ra (for temp use) */
+  /* go over module entries and install/execute */
+  for (ent = mod; ent[1] != NULL; ent += 2) {
+    const char *name = ent[0], *data = ent[1];
+    fprintf(stderr, "## initializing: %s\n%s\n", name?name:"NULL", data);
+    if (name != NULL) {
+      /* install sexp-encoded syntax-rules as a transformer */
+      obj sym = mksymbol(internsym((char*)name));
+      obj al = cx__2Atransformers_2A, bnd = mknull();
+      assert(ispair(al)); /* basic transformers already installed */
+      /* look for existing binding (we allow redefinition) */
+      while (al != mknull()) {
+        obj ael = car(al);
+        if (car(ael) != sym) { al = cdr(al); continue; }
+        bnd = ael; break;
+      }
+      /* or add new binding */
+      if (bnd == mknull()) { /* acons (sym . #f) */
+        hreserve(hbsz(3)*2, sp-r);
+        *--hp = obj_from_bool(0); *--hp = sym;
+        *--hp = obj_from_size(PAIR_BTAG); bnd = hendblk(3);
+        *--hp = cx__2Atransformers_2A; *--hp = bnd;
+        *--hp = obj_from_size(PAIR_BTAG); cx__2Atransformers_2A = hendblk(3);
+      }
+      /* sexp-decode data into the cdr of the binding */
+      spush(bnd); /* protect from gc */
+      ra = mkiport_string(sp-r, sialloc((char*)data, NULL));
+      hp = rds_sexp(r, sp, hp);  /* ra=port => ra=sexp/eof */      
+      bnd = spop();
+      assert(ispair(bnd) && (ispair(ra) || issymbol(ra)));
+      cdr(bnd) = ra;
+    } else {
+      /* execute code-encoded thunk */
+      obj *ip;
+#ifdef VM_AC_IN_REG
+      obj *ac;
+#endif      
+      ra = mkiport_string(sp-r, sialloc((char*)data, NULL));
+      hp = rds_seq(r, sp, hp);  /* ra=port => ra=revcodelist/eof */
+      if (!iseof(ra)) hp = revlist2vec(r, sp, hp); /* ra => ra */
+      if (!iseof(ra)) hp = close0(r, sp, hp); /* ra => ra */
+      assert(!iseof(ra));
+      /* ra is a thunk closure to execute */
+      rd = ra;
+      ra = obj_from_fixnum(0); /* argc, shadow ac */
+      rx = obj_from_fixnum(0); /* shadow ip */ 
+      rs = obj_from_fixnum(VM_REGC); /* sp */
+      do { /* unwindi trampoline */
+        reload_ac(); /* ra => ac */
+        reload_ip(); /* rd/rx => ip */
+        reload_sp(); /* rs => sp */
+        hp = (ins_from_obj(*ip))(IARGS1);
+      } while (trampcnd());
+      /* r[0] = k, r[1] = random result */
+    }
+  }
+  return hp;
+}
+
+/* protects registers from r to sp=r+2; returns new hp */
+static obj *init_modules(obj *r, obj *sp, obj *hp)
+{
+  extern char* s_code[]; /* s.c */
+  hp = init_module(r, sp, hp, s_code);
+  return hp;
+}

s.c

@@ -374,16 +374,20 @@ char *s_code[] = {
   "&0{%1.0N4]1}@!(y18:%25residual-integer?)",
 
   "complex?",
-  "y7:number?",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py7:number?;y4:args;;;l2:y1:_;"
+  "y7:number?;;",
 
   "real?",
-  "y7:number?",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py7:number?;y4:args;;;l2:y1:_;"
+  "y7:number?;;",
 
   "rational?",
-  "y8:integer?",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py8:integer?;y4:args;;;l2:y1:_"
+  ";y8:integer?;;",
 
   "exact-integer?",
-  "y7:fixnum?",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py7:fixnum?;y4:args;;;l2:y1:_;"
+  "y7:fixnum?;;",
 
   "exact?",
   "l4:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y5:%25fixp;l2:y4:%25ckn;y1:x"
@@ -543,10 +547,12 @@ char *s_code[] = {
   "&0{%2.0%nG6]2}@!(y19:%25residual-remainder)",
 
   "truncate-quotient",
-  "y8:quotient",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py8:quotient;y4:args;;;l2:y1:_"
+  ";y8:quotient;;",
 
   "truncate-remainder",
-  "y9:remainder",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py9:remainder;y4:args;;;l2:y1:"
+  "_;y9:remainder;;",
 
   "modquo",
   "l4:y12:syntax-rules;n;l2:l3:y1:_;y1:x;y1:y;;l2:y4:%25mqu;l2:y4:%25ckn;"
@@ -563,10 +569,12 @@ char *s_code[] = {
   "&0{%2.0%nG4]2}@!(y16:%25residual-modulo)",
 
   "floor-quotient",
-  "y6:modquo",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py6:modquo;y4:args;;;l2:y1:_;y"
+  "6:modquo;;",
 
   "floor-remainder",
-  "y6:modulo",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py6:modulo;y4:args;;;l2:y1:_;y"
+  "6:modulo;;",
 
   "boolean?",
   "l4:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y6:%25boolp;y1:x;;;l2:y1:_;y"
@@ -1144,7 +1152,8 @@ char *s_code[] = {
   ";y1:x;l4:y5:list*;y1:y;y1:z;y3:...;;;;l2:y1:_;y15:%25residual-list*;;",
 
   "cons*",
-  "y5:list*",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py5:list*;y4:args;;;l2:y1:_;y5"
+  ":list*;;",
 
   "map",
   "l4:y12:syntax-rules;n;l2:l3:y1:_;y3:fun;y3:lst;;l3:y3:let;l1:l2:y1:f;y"
@@ -1166,7 +1175,8 @@ char *s_code[] = {
   "&0{%1.0V0]1}@!(y17:%25residual-vector?)",
 
   "vector",
-  "y4:%25vec",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py4:%25vec;y4:args;;;l2:y1:_;y"
+  "4:%25vec;;",
 
   "make-vector",
   "l5:y12:syntax-rules;n;l2:l2:y1:_;y1:n;;l3:y4:%25vmk;l2:y4:%25ckk;y1:n;"
@@ -1418,10 +1428,12 @@ char *s_code[] = {
   "p;l5:y5:list*;y1:a;y1:b;y3:...;y1:l;;;;l2:y1:_;y15:%25residual-apply;;",
 
   "call/cc",
-  "y4:%25ccc",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py4:%25ccc;y4:args;;;l2:y1:_;y"
+  "4:%25ccc;;",
 
   "call-with-current-continuation",
-  "y7:call/cc",
+  "l4:y12:syntax-rules;n;l2:py1:_;y4:args;;py7:call/cc;y4:args;;;l2:y1:_;"
+  "y7:call/cc;;",
 
   "input-port?",
   "l4:y12:syntax-rules;n;l2:l2:y1:_;y1:x;;l2:y4:%25ipp;y1:x;;;l2:y1:_;y21"

src/c.sf

@@ -376,7 +376,7 @@
     (cond [(binding? bnd)
            ; special case: syntax-rules in sexp form (left by init)
            (let ([val (binding-val bnd)])
-             (when (and (pair? val) (eq? (car val) 'syntax-rules))
+             (if (and (pair? val) (eq? (car val) 'syntax-rules))  
                  (binding-set-val! bnd (transform #t val))))
            bnd]
           [(symbol? id)
@@ -1028,6 +1028,9 @@
             [(eq? v 'define-inline) '_]
             [(pair? v) (cons (hack (car v)) (hack (cdr v)))]
             [else v])))
+  ; wrap symbolic definitions so init code can use them
+  (when (symbol? xval)
+    (set! xval (list 'syntax-rules '() (list '(_ . args) (cons xval 'args)) (list '_ xval))))
   (let ([p (open-output-string)]) (write-serialized-sexp xval p)
     (display-code (get-output-string p) oport) (newline oport)))
 
@@ -1101,38 +1104,12 @@
 
 
 ;---------------------------------------------------------------------------------------------
-; Test environment
+; Initial environment
 ;---------------------------------------------------------------------------------------------
 
 ; NB: 'nuate' restores stack with fn arg on top of return triple
 (define continuation-closure-code (decode "%1.0K2]1"))
 
-#|
-(define (install-global-lambdas)
-  (define (install-global-lambda! sym cstr)
-    (index-set-global! (global-location sym) (make-closure (decode cstr))))
-  ; top-level definitions using integrables 
-  (install-global-lambda! 'eq? "%2.1,.1q]2")
-  (install-global-lambda! 'car "%1.0a]1")
-  (install-global-lambda! 'cdr "%1.0d]1")
-  (install-global-lambda! 'null? "%1.0u]1")
-  (install-global-lambda! 'pair? "%1.0p]1")
-  (install-global-lambda! 'cons "%2.1,.1c]2")
-  (install-global-lambda! 'list "%!0.0]1")
-  (install-global-lambda! 'append "%2.1,.1L6]2")
-  (install-global-lambda! '+ "%2.1,.1+]2")
-  (install-global-lambda! '- "%2.1,.1-]2")
-  (install-global-lambda! '* "%2.1,.1*]2")
-  (install-global-lambda! '< "%2.1,.1<]2")
-  (install-global-lambda! '= "%2.1,.1=]2")
-  (install-global-lambda! 'zero? "%1.0z]1")
-  (install-global-lambda! 'not "%1.0~]1")
-  (install-global-lambda! 'string<? "%2'0,.2,.2O6<]2")
-  (install-global-lambda! 'deserialize-sexp "%1.0U3]1")
-  (install-global-lambda! 'deserialize-code "%1.0U4]1")
-  (install-global-lambda! 'call/cc "%1K1,.1[11"))
-|#
-
 (define install-global-lambdas
   (%prim "{ /* define install-global-lambdas */
     static obj c[] = { obj_from_objptr(vmcases+6) };
@@ -1140,6 +1117,13 @@
 
 (install-global-lambdas)
 
+(define initialize-modules
+  (%prim "{ /* define initialize-modules */
+    static obj c[] = { obj_from_objptr(vmcases+7) };
+    $return objptr(c); }"))
+
+(initialize-modules)
+
 
 ;---------------------------------------------------------------------------------------------
 ; Tests