mirror of
https://github.com/false-schemers/skint.git
synced 2025-02-02 07:57:06 +01:00
runs init code from s.c
This commit is contained in:
ESL
parent
630dafe480
commit
166d6dbd8c
4 changed files with 692 additions and 517 deletions
92
i.c
92
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;
|
||||
}
|
||||
|
|
|
|||
36
s.c
36
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"
|
||||
|
|
|
|||
40
src/c.sf
40
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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue