Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-26 21:58:51 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

letcc/withcc: k is now a procedure, allow bodies

Browse source
This commit is contained in:
ESL 2023-03-11 01:50:00 -05:00
parent eddf65f62c
commit 25fa48c928
4 changed files with 823 additions and 777 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
i.c
View file

@ -7,6 +7,7 @@
extern obj cx__2Aglobals_2A;
extern obj cx__2Atransformers_2A;
extern obj cx_continuation_2Dclosure_2Dcode;
extern obj cx_continuation_2Dadapter_2Dcode;
extern obj cx_callmv_2Dadapter_2Dclosure;
#define istagged(o, t) istagged_inlined(o, t)
@ -469,29 +470,31 @@ define_instruction(lck) {
int m = fixnum_from_obj(*ip++);
int n; cki(sref(m)); ckx(sref(m+1));
n = (int)(sp-m-(r+VM_REGC));
hp_reserve(hbsz(n+1));
hp_reserve(vmclobsz(n+1));
hp -= n; memcpy(hp, sp-n-m, n*sizeof(obj));
*--hp = obj_from_size(VECTOR_BTAG);
ac = hendblk(n+1); /* stack copy */
*--hp = cx_continuation_2Dadapter_2Dcode;
ac = hpushvmclo(n+1);
gonexti();
}
define_instruction(lck0) {
int n; cki(sref(0)); ckx(sref(1));
n = (int)(sp-(r+VM_REGC));
hp_reserve(hbsz(n+1));
hp_reserve(vmclobsz(n+1));
hp -= n; memcpy(hp, sp-n, n*sizeof(obj));
*--hp = obj_from_size(VECTOR_BTAG);
ac = hendblk(n+1); /* stack copy */
*--hp = cx_continuation_2Dadapter_2Dcode;
ac = hendblk(n+1);
gonexti();
}
define_instruction(wck) {
obj v = ac, t = spop(); int n; ckx(t); ckv(v);
n = vectorlen(v);
obj x = ac, t = spop(); int n; ckx(t); ckx(x);
if (vmcloref(x, 0) != cx_continuation_2Dadapter_2Dcode)
failactype("continuation");
n = vmclolen(x) - 1;
assert((cxg_rend - cxg_regs - VM_REGC) > n);
sp = r + VM_REGC; /* stack is empty */
memcpy(sp, &vectorref(v, 0), n*sizeof(obj));
memcpy(sp, &vmcloref(x, 1), n*sizeof(obj));
sp += n; /* contains n elements now */
rd = t; rx = obj_from_fixnum(0);
ac = obj_from_fixnum(0);
@ -499,11 +502,13 @@ define_instruction(wck) {
}
define_instruction(wckr) {
obj v = ac, o = spop(); int n; ckv(v);
n = vectorlen(v);
obj x = ac, o = spop(); int n; ckx(x);
if (vmcloref(x, 0) != cx_continuation_2Dadapter_2Dcode)
failactype("continuation");
n = vmclolen(x) - 1;
assert((cxg_rend - cxg_regs - VM_REGC) > n);
sp = r + VM_REGC; /* stack is empty */
memcpy(sp, &vectorref(v, 0), n*sizeof(obj));
memcpy(sp, &vmcloref(x, 1), n*sizeof(obj));
sp += n;
ac = o;
rx = spop();
@ -511,6 +516,28 @@ define_instruction(wckr) {
retfromi();
}
define_instruction(rck) {
/* in: ac:argc, args on stack, rd display is saved stack */
if (ac == obj_from_fixnum(1)) { /* easy, popular case */
ac = rd;
goi(wckr);
} else { /* multiple results case */
int c = fixnum_from_obj(ac), n = vmclolen(rd) - 1;
obj *ks = &vmcloref(rd, 1), *ke = ks + n;
if (ke-ks > 3 && *--ke == obj_from_fixnum(0) && *--ke == cx_callmv_2Dadapter_2Dclosure) {
obj *sb = r + VM_REGC;
rd = *--ke; rx = obj_from_fixnum(0); n = ke - ks; /* cns */
/* arrange stack as follows: [ks..ke] [arg ...] */
assert((cxg_rend - cxg_regs - VM_REGC) > n + c);
if (c) memmove(sb+n, sp-c, c*sizeof(obj));
memcpy(sb, ks, n*sizeof(obj));
sp = sb+n+c; callsubi();
} else {
fail("multiple values returned to single value continuation");
}
}
}
define_instruction(save) {
int dx = fixnum_from_obj(*ip++);
spush(rd);

1
i.h
View file

@ -62,6 +62,7 @@ declare_instruction(rcmv, "K5", 0, NULL, 0, NULL)
declare_instruction(sdmv, "K6", 0, NULL, 0, NULL)
declare_instruction(lck, "k", 1, NULL, 0, NULL)
declare_instruction(lck0, "k0", 0, NULL, 0, NULL)
declare_instruction(rck, "k!", 0, NULL, 0, NULL)
declare_instruction(wck, "w", 0, NULL, 0, NULL)
declare_instruction(wckr, "w!", 0, NULL, 0, NULL)
declare_instruction(save, "$", 's', NULL, 0, NULL)

1535
k.c
View file

File diff suppressed because it is too large Load diff

13
src/k.sf
View file

@ -129,9 +129,9 @@
(cons x (loop (car rest) (cdr rest))))))
(define (list1? x) (and (pair? x) (null? (cdr x))))
(define (list1+? x) (and (pair? x) (list? (cdr x))))
(define (list2? x) (and (pair? x) (list1? (cdr x))))
(define (list3? x) (and (pair? x) (list2? (cdr x))))
(define (list4? x) (and (pair? x) (list3? (cdr x))))
(define (list2+? x) (and (pair? x) (list1+? (cdr x))))
;---------------------------------------------------------------------------------------------
@ -329,16 +329,16 @@
(error 'transform "improper lambda* form")))
(define (xform-letcc tail env)
(if (and (list2? tail) (id? (car tail)))
(if (and (list2+? tail) (id? (car tail)))
(let* ([var (car tail)] [nvar (gensym (id->sym var))])
(list 'letcc nvar
(xform #f (cadr tail) (add-var var nvar env))))
(xform-body (cdr tail) (add-var var nvar env))))
(error 'transform "improper letcc form")))
(define (xform-withcc tail env)
(if (list2? tail)
(if (list2+? tail)
(list 'withcc (xform #f (car tail) env)
(xform #f (cadr tail) env))
(xform-body (cdr tail) env))
(error 'transform "improper withcc form")))
(define (xform-body tail env)
@ -1238,6 +1238,7 @@
; NB: 'nuate' restores stack with fn arg on top of return triple
(define continuation-closure-code (decode "%1.0K2]1"))
(define continuation-adapter-code (decode "k!"))
; adapter closure for values/call-with-values pair
(define callmv-adapter-closure (make-closure (decode "K5")))