A fragment of the cache implementation for the simple system:
val W = 32fun mask b = (1 << b) - 1
fun load_sample (p, b) = let wa = p / W let ba = p % W let w0 = (load_word_cached wa) let s0 = (mask b) & (w0 >> ba) if ((ba + b) > W) (let ub = W - ba let w1 = load_word_cached ((p+ub) / W) let s1 = (w1 & (mask (b - ub))) s0 | (s1 << ub)) s0
fun flush_line line = let (addr, clean, mask, v) = line if clean line let v2 = (if (0 = mask) v (v | (mask & (load_word addr)))) let line2 = (addr, true, 0, v2) store_word(addr, v2)
fun load_word_cached(addr) = let (effects,cache) = get_store if (is_pair(cache)) (lw_loop(cache, (), addr)) (load_word(addr))
fun lw_loop(cache, prev_cache, addr) = if (is_pair cache) (let (line, rest) = cache let (addr2, clean, mask, v) = line if (aliases(addr2,addr)) (if (clean or (mask = 0)) (cache_done(prev_cache, rest, addr, true, 0, v)) (error cannot_cross_streams2)) (lw_loop (rest, (line, prev_cache), addr))) ((flush_line(left prev_cache)); (let w = (load_word(addr)) (cache_done ((right prev_cache), (), addr, true, 0, w))))
A fragment of the implementation of the signal interface:
fun memory_empty (start, stop, size, stride) =
(start = stop)
fun memory_next (start, stop, size, stride) =
(v_memory, ((start+stride), stop, size, stride))
fun memory_get (start, stop, size, stride) =
load_sample(start, size)
fun memory_put ((start, stop, size, stride), v) =
store_sample(start, size, v)
fun constant_empty k = true
fun constant_next k = (v_constant, k)
fun constant_get k = k
fun constant_put (k, v) = (error)
fun noise_empty (state, ia, ic, im) = true
fun noise_next (state, ia, ic, im) =
(v_noise, (((lift (ia*state + ic)) % im), ia, ic, im))
fun noise_get (state, ia, ic, im) = state
fun noise_put (state, ia, ic, im) = (error)
fun bin_empty (op, v, w) =
((vec_empty v) and (vec_empty w))
fun bin_next (op, v, w) =
(v_bin, (op, (vec_next v), (vec_next w)))
fun bin_get (op, v, w) =
(do_op (op, (vec_get v), (vec_get w)))
fun bin_put ((op, v, w), q) = (error)
fun delay1_empty (h, v) = (vec_empty v)
fun delay1_next (h, v) =
(v_delay1, ((vec_get v), (vec_next v)))
fun delay1_get (h, v) = h
fun delay1_put ((h, v), q) = (error)
fun scan_empty (op, h, v) = (vec_empty v)
fun scan_next (op, h, v) = (v_scan, (op, (do_op (h, (vec_get v))),
(vec_next v)))
fun scan_get (op, h, v) = h
fun scan_put ((op, h, v), q) = (error)
fun reduce (op, init, vec) =
loop (v, vec) ((lift init), vec)
(vec_empty vec)
((do_op(op, v, (vec_get vec))),
(vec_next vec))
v
fun copy (a, b) =
loop (a, b) (a, b)
((vec_empty a) and (vec_empty b))
((vec_put (b, (vec_get a)));
((vec_next a), (vec_next b)))
()
fun filter (i, k, pre) =
if (is_pair k)
(v_binop, (op_plus,
(v_map, (op_times, (left k), i)),
(filter ((v_delay1, ((debug (left pre)), i)),
(right k), (right pre)))))
i
val sig16 = (v_memory, ((32*('start)+0), (32*('stop)+0), 16, 16))
val sig16_1 = clone sig16
val sig16_2 = clone sig16
val aligned_bytes = ((32*('start)+0), (32*('stop)+0), 8, 8)
val aligned_6s = ((32*'start1+0), (32*'stop1+0), 6, 6)
Programs implemented with the signal library.
val add = (op_plus, sig16, sig16_1, sig16_2)val inc = (op_plus, sig16, (v_constant, 10), sig16_1)
val filter2 = ((v_bin, (op_plus, (v_delay1, (('first), sig16)), sig16)), sig16_2)
val kernel = (1, 2, 4, 2, 1, ()) val prefix = (('a), ('b), ('c), ('d), ('e), ()) val filter5 = ((filter (sig16, kernel, prefix)), sig16_1)
val lut1 = ((v_lut, (('buf), sig8)), sig16)
val wavtab1 = ((v_lut_feedback, (('buf), 1024, 1, 32, ('prev), sig16)), sig16_1)
val fm1 = ((fm_osc ((v_constant, 0), 0, ('buf), 1024, (v_constant, 256), ('init_phase))), sig16)
val fm2 = ((fm_osc ((osc (('buf), 1024, (v_constant, 256), ('phase0))), 1, ('buf), 1024, (v_constant, 256), ('phase1))), sig16)
val rgb2m_1 = rgb2m (rgba_r, rgba_g, rgba_b, mono8) val rgb2m_2 = rgb2m (rgb_r, rgb_g, rgb_b, mono8)
val base64_encode = (aligned_6s, aligned_bytes) val base64_decode = (aligned_bytes, aligned_6s)
Baseline hand-specialized C code.
int
sum16(short *start, short *stop,
int sum) {
while (start != stop) {
sum += *start++;
}
return sum;
}
void
filter2(short *start, short *stop,
short *start1, short *stop1) {
while (start != stop) {
*start1 = start[0] + start[1];
start++;
start1++;
}
}
void
filter5(short *start, short *stop,
short *start1, short *stop1) {
int i, t;
while (start != stop) {
t = 0;
for (i = 0; i < 5; i++)
t += start[i];
*start1 = t;
start++;
start1++;
}
}
int
sum8(int *start, int *stop,
int sum) {
int v;
while(start != stop) {
v = *start;
sum += (((v>>0)&255) +
((v>>8)&255) +
((v>>16)&255) +
((v>>24)&255));
start += 1;
}
return sum;
}
void
iota(int *start, int *stop) {
int i = 0;
while(start != stop) {
*start++ = i | ((i+1)<<8) |
((i+2)<<16) | ((i+3)<<24);
i+=4;
}
}
void
copy(int *start0, int* stop0,
int *start1, int* stop1) {
while (start0 != stop0)
*start0++ = *start1++;
}
void
gaps(int *start0, int* stop0,
int *start1, int* stop1) {
while (start0 != stop0) {
int v = *start0;
int b0 = (v>>0)&255;
int b1 = (v>>8)&255;
int b2 = (v>>16)&255;
int b3 = (v>>24)&255;
int mask = 0xff00ff00;
start1[0] = (start1[0] & mask)
| b0 | (b1 << 16);
start1[1] = (start1[1] & mask)
| b2 | (b3 << 16);
start0++;
start1+=2;
}
}
int
sum12(int *start, int *stop) {
int sum = 0;
while (start != stop) {
int w0 = start[0];
int w1 = start[1];
int w2 = start[2];
sum += ((w0 & 0xfff) +
((w0 >> 12) & 0xfff) +
(((w0 >> 24) & 0xff)
| ((w1 & 0xf) << 8)) +
((w1 >> 4) & 0xfff) +
((w1 >> 16) & 0xfff) +
(((w1 >> 28) & 0xf)
| ((w2 & 0xff) << 4)) +
((w2 >> 8) & 0xfff) +
((w2 >> 20) & 0xfff));
start += 3;
}
return sum;
}
void
fm1(int *lut, int phase,
short *start, short *stop) {
while (start != stop) {
*start++ = lut[phase>>8];
phase += 256;
phase = phase & ((1024*256)-1);
}
}
Buffered versions.
typedef unsigned int bitp;typedef struct { bitp start; bitp stop; int stride; int size; } signal_t;
void decode_signal(signal_t *s, int *v) { bitp s0=s->start, s1=s->stop; int stride = s->stride; int size = s->size; if ((stride&7) == 0 && size == 8 && (s0&7) == 0) { char *p = ((char *)fixaddr(s0>>5)) + ((s0>>3)&3); char *q = ((char *)fixaddr(s1>>5)) + ((s0>>3)&3); stride = stride>>3; while (p != q) { *v++ = *p; p += stride; } } else while (s0 != s1) { *v++ = load_sample(s0, size); s0 += stride; } }
void encode_signal(signal_t *s, int *v) { bitp s0=s->start, s1=s->stop; int stride = s->stride; int size = s->size; if ((stride&7) == 0 && size == 8 && (s0&7) == 0) { char *p = ((char *)fixaddr(s0>>5)) + ((s0>>3)&3); char *q = ((char *)fixaddr(s1>>5)) + ((s0>>3)&3); stride = stride>>3; while (p != q) { *p = *v++; p += stride; } } else while (s0 != s1) { store_sample(s0, size, *v++); s0 += stride; } }
void scale_vector(int *v, int s, int n) { int i; for (i = 0; i < n; i++) v[i] *= s; }
void translate_vector(int *v, int s, int n) { int i; for (i = 0; i < n; i++) v[i] += s; }
void add_vectors(int *v, int *w, int n) { int i; for (i = 0; i < n; i++) w[i] += v[i]; }
void divide_vector(int *v, int s, int n) { int i; for (i = 0; i < n; i++) v[i] /= s; }
rgb2m_buff(signal_t *r, signal_t *g, signal_t *b, signal_t *m, int cr, int cg, int cb, int cs) { int t0[4000]; int t1[4000]; int n = (r->stop - r->stop)/r->stride;
decode_signal(r, t0); scale_vector(t0, cr, n); decode_signal(g, t1); scale_vector(t1, cg, n); add_vectors(t0, t1, n); decode_signal(b, t0); scale_vector(t0, cb, n); add_vectors(t0, t1, n); divide_vector(t1, cs, n); encode_signal(m, t1); }
cs68_buff(signal_t *i, signal_t *o) { int t0[4000]; int n = (i->stop - i->stop)/i->stride; decode_signal(i, t0); translate_vector(t0, 32, n); encode_signal(o, t0); }
Interpreted
Interpreted versions.
typedef unsigned int uint;uint load_sample(uint addr, int len) { int mask = (1 << len) - 1; uint *p = fixaddr(addr >> 5); int o = addr & 31; int r = (*p >> o) & mask; if (len + o >= 32) { int e = (len + o - 32); return r | ((p[1] & ((1 << e) -1 )) << e); } return r; }
void store_sample(uint addr, int len, int v) { int mask = (1 << len) - 1; uint *p = fixaddr(addr >> 5); int o = addr & 31; int prev = (*p & ~(mask<<o)); *p = prev | (v<<o); if (len + o >= 32) { int e = (len + o - 32); store_sample(addr+(32-o), e, (v>>(32-o))); } }
int sum_reduce(uint from, uint to, int bits, int stride) { int sum = 0; while (from != to) { sum += load_sample(from, bits); from += stride; } return sum; }
int cs68(uint from, uint to, uint start0) { while (from != to) { store_sample(start0, 8, 32+(load_sample(from, 6))); start0 += 8; from += 6; } }
Most of the implementation of Sal.
(code lookup
(k M var env)
((prim more? ,pair? env)
(if more? ((prim hd ,car env)
(prim tl ,cdr env)
,@(make 'lookup-found '(k M var tl) 'cl1)
,@(make 'lookup-lost '(k M var tl) 'cl2)
; this unquote is linking/module level
(const assq ,assq-root)
(jump assq cl1 cl2 var hd)))
; raise exception on meta-level, since we don't have them
; here. like a trap.
(const msg "variable ~S not bound")
(prim xx ,error msg var)
,@(call 'k '(M var))))
(code lookup-found
(self val)
(,@(unmake '(k M var tl) 'self)
,@(call 'k '(M val))))
(code lookup-lost
(self val)
(,@(unmake '(k M var tl) 'self)
; search the next frame
(const lookup lookup)
(jump lookup k M var tl)))
(define break-let-clauses
(code-rec1
`((code break-let-clauses
(k M l rv rc)
((prim n ,null? l)
(if n (,@(call 'k '(M rv rc))))
(prim hd ,car l)
(prim tl ,cdr l)
(prim v0 ,car hd)
(prim t0 ,cdr hd)
(prim c0 ,car t0)
(prim rv^ ,cons v0 rv)
(prim rc^ ,cons c0 rc)
(const break-let-clauses break-let-clauses)
(jump break-let-clauses k M tl rv^ rc^))))))
(code apply
(k M prog name args)
((const apply-loop apply-loop)
(jump apply-loop k M prog prog name args)))
(code apply-loop
(k M prog prog2 name args)
((prim more? ,pair? prog)
(prim no-more? ,not more?)
(if no-more? ((const msg "procedure ~S not bound")
(prim xx ,error msg name)
,@(call 'k '(M name))))
(prim d ,car prog)
(prim nm ,car d)
(prim found-defn? ,eq? nm name)
(if found-defn? ((prim d1 ,cdr d)
(prim d2 ,cdr d1)
(prim extern? ,null? d2)
(if extern?
((prim code ,car d1)
(const apply-extern apply-extern)
(jump apply-extern k M code args)))
(prim formals ,car d1)
(prim exp ,car d2)
(const nil ())
(lift nil
(run ,(lambda (self)
(make-multi-env-bt
(make-env-bt
(find-code 'zip root-zip))
(find-code 'subst-cont
self)))))
(const subst subst)
(jump subst k M formals args exp nil prog2)))
(prim rest ,cdr prog)
(const apply-loop apply-loop)
(jump apply-loop k M rest prog2 name args)))
(code expr
(k M exp env prog)
((const expr expr)
(prim is-var? ,symbol? exp)
(if is-var? ((const lookup ,lookup-recur)
(jump lookup k M exp env)))
(prim is-const? ,atom? exp)
(if is-const? ((lift exp)
,@(call 'k '(M exp))))
(prim hd ,car exp)
(prim tl ,cdr exp)
(const get-memory get-memory)
(prim is-get-mem? ,eq? hd get-memory)
(if is-get-mem? (,@(call 'k '(M M))))
(const if-name if)
(prim is-if ,eq? if-name hd)
(if is-if ((prim e0 ,car tl)
(prim rest ,cdr tl)
,@(make 'if-cont '(k rest env prog) 'cl)
(lift cl stack)
(jump expr cl M e0 env prog)))
(const quote quote)
(prim quote? ,eq? quote hd)
(if quote? ((prim e0 ,car tl)
(lift e0)
,@(call 'k '(M e0))))
(const and and)
(prim and? ,eq? and hd)
(if and? ((prim e0 ,car tl)
(prim rest ,cdr tl)
,@(make 'and-cont '(k rest env prog) 'cl)
(lift cl stack)
(jump expr cl M e0 env prog)))
(const or or)
(prim or? ,eq? or hd)
(if or? ((prim e0 ,car tl)
(prim rest ,cdr tl)
,@(make 'or-cont '(k rest env prog) 'cl)
(lift cl stack)
(jump expr cl M e0 env prog)))
(const case case)
(prim case? ,eq? case hd)
(if case? ((prim e0 ,car tl)
(prim rest ,cdr tl)
,@(make 'case-cont '(k rest env prog) 'cl)
(lift cl stack)
(jump expr cl M e0 env prog)))
(const begin begin)
(prim begin? ,eq? begin hd)
(if begin? ((prim e0 ,car tl)
(prim rest ,cdr tl)
(prim one-more ,null? rest)
(if one-more ((jump expr k M e0 env prog)))
,@(make 'begin-cont '(k rest env prog) 'cl)
(lift cl stack)
(jump expr cl M e0 env prog)))
(const lambda lambda)
(prim lambda? ,eq? lambda hd)
(if lambda? ((prim e0 ,car tl)
(prim rest ,cdr tl)
(prim body ,car rest)
,@(make 'lambda-proc '(e0 body env prog) 'lam)
(lift lam)
(lift lam 1 stack)
,@(call 'k '(M lam))))
(const destruct-name destruct)
(prim is-destruct ,eq? destruct-name hd)
(if is-destruct ((prim e0 ,car tl)
(prim rest ,cdr tl)
(prim e1 ,car rest)
(prim r2 ,cdr rest)
(prim body ,car r2)
,@(make 'ds-cont '(k e0 body env prog) 'cl)
(jump expr cl M e1 env prog)))
(const let-name let)
(prim is-let ,eq? let-name hd)
(if is-let ((prim e0 ,car tl)
(prim rest ,cdr tl)
(prim body ,car rest)
,@(make 'blcont '(k body env prog) 'cl)
(const break-let-clauses ,break-let-clauses)
(const nil ())
(jump break-let-clauses cl M e0 nil nil)))
,@(make 'apply-cont '(k hd env prog) 'cl)
(lift cl stack)
(const expr-list expr-list)
(jump expr-list cl M tl env prog)))
(code expr-list
(k M exprs env prog)
((prim is-null ,null? exprs)
(if is-null ((const nil ())
(lift nil (run ,(lambda (self)
(make-spine-static-bt
(find-code 'expr-list-cont2
self) 'r))))
,@(call 'k '(M nil))))
(prim e ,car exprs)
(prim rest ,cdr exprs)
(const expr expr)
,@(make 'expr-list-cont '(k rest env prog) 'cl1)
(lift cl1 stack)
(jump expr cl1 M e env prog)))
(code expr-list-cont
(self M r)
(,@(unmake '(k rest env prog) 'self)
,@(make 'expr-list-cont2 '(k r) 'cl2)
(lift cl2 stack)
(const expr-list expr-list)
(jump expr-list cl2 M rest env prog)))
(code expr-list-cont2
(self M r-tl)
(,@(unmake '(k r-hd) 'self)
(prim r ,cons r-hd r-tl)
,@(call 'k '(M r))))
(code apply-cont
(self M args)
(,@(unmake '(k hd env prog) 'self)
(prim is-prim? ,procedure? hd)
(if is-prim? ((prim r ,apply hd args)
,@(call 'k '(M r))))
(const debug debug)
(prim is-debug? ,eq? hd debug)
(if is-debug? ((prim v ,car args)
(debug v)
,@(call 'k '(M v))))
(const lift lift)
(prim is-lift? ,eq? hd lift)
(if is-lift? ((prim v ,car args)
(prim args1 ,cdr args)
(prim more? ,pair? args1)
(if more? ((prim bt ,car args1)
(lift v 1 bt)
; (lift v 1)
,@(call 'k '(M v))))
(lift v 1)
,@(call 'k '(M v))))
(const set-base set-base)
(prim is-set-base? ,eq? hd set-base)
(if is-set-base? ((prim v ,car args)
(prim args1 ,cdr args)
(prim b ,car args1)
(lift v base 1 b)
,@(call 'k '(M v))))
(const set-memory set-memory!)
(prim is-set-mem? ,eq? hd set-memory)
(if is-set-mem? ((prim new-M ,car args)
(const ok ok)
(lift ok)
,@(call 'k '(new-M ok))))
(prim named-prim
,(lambda (prog name)
(cond ((assq name prog)
=> (lambda (p)
(if (and (null? (cddr p))
(procedure? (cadr p)))
(cadr p)
#f)))
(else #f)))
prog hd)
(if named-prim ((prim r ,apply named-prim args)
,@(call 'k '(M r))))
(prim proc-call? ,assq hd prog)
(if proc-call? ((lift k)
(lift k 1 stack)
(const $inline #f)
(const apply apply)
(jump apply k M prog hd args)))
,@(make 'lambda-call-cont '(k args prog) 'cl)
(lift cl stack)
(const expr expr)
(jump expr cl M hd env prog)))
(code lambda-call-cont
(self M fn)
(,@(unmake '(k args prog) 'self)
(lift k)
(lift k 1 stack)
,@(call 'fn '(k M args))))
(code if-cont
(self M p)
(,@(unmake '(k e12 env prog) 'self)
(if p ((prim e ,car e12)
(const expr expr)
(const $inline #t)
(jump expr k M e env prog)))
(prim e2 ,cdr e12)
(prim e ,car e2)
(const $inline #t)
(const expr expr)
(jump expr k M e env prog)))
(code and-cont
(self M p)
(,@(unmake '(k e12 env prog) 'self)
(if p ((prim e ,car e12)
(const expr expr)
(const $inline #t)
(jump expr k M e env prog)))
(const false #f)
(const $inline #t)
(lift false)
,@(call 'k '(M false))))
(code or-cont
(self M p)
(,@(unmake '(k e12 env prog) 'self)
(if p ((const $inline #t)
,@(call 'k '(M p))))
(const $inline #t)
(prim e ,car e12)
(const expr expr)
(jump expr k M e env prog)))
(code case-cont
(self M key)
(,@(unmake '(k rest env prog) 'self)
(const case-loop case-loop)
(jump case-loop k M key rest env prog)))
(code case-loop
(k M key clauses env prog)
((prim e? ,null? clauses)
(if e? ((const error error)
(lift error)
,@(call 'k '(M error))))
(prim case-e ,car clauses)
(prim pat-e ,car case-e)
(prim tl0 ,cdr case-e)
(prim consq-e ,car tl0)
(prim tl ,cdr clauses)
(prim d? ,eq? pat-e key)
(if d? ((const expr expr)
(const $inline #t)
(jump expr k M consq-e env prog)))
(const $inline #t)
(const case-loop case-loop)
(jump case-loop k M key tl env prog)))
; make this a tail call for the last one!!! XXX
(code begin-cont
(self M r)
(,@(unmake '(k rest env prog) 'self)
(prim done ,null? rest)
(if done (,@(call 'k '(M r))))
(prim e ,car rest)
(prim r2 ,cdr rest)
(prim one-more ,null? r2)
(const expr expr)
(if one-more ((jump expr k M e env prog)))
,@(make 'begin-cont '(k r2 env prog) 'cl)
(jump expr cl M e env prog)))
(code blcont
(self M vars exprs)
(,@(unmake '(k body env prog) 'self)
,@(make 'let-cont '(k vars body env prog) 'cl)
(const expr-list expr-list)
(jump expr-list cl M exprs env prog)))
(code let-cont
(self M vals)
(,@(unmake '(k vars body env prog) 'self)
(const subst subst)
(jump subst k M vars vals body env prog)))
(code ds-cont
(self M vals)
(,@(unmake '(k pat body env prog) 'self)
(const subst subst)
(jump subst k M pat vals body env prog)))
(code subst
(k M vars vals body env prog)
(,@(make 'subst-cont '(k M body env prog) 'cl)
(const zip ,root-zip)
(const nil ())
(lift nil (run ,(lambda (self)
(make-env-bt
(find-code 'zip root-zip)))))
(jump zip cl vars vals nil)))
(code subst-cont
(self frame)
(,@(unmake '(k M body env prog) 'self)
(prim over-spine ,cons frame env)
(const expr expr)
(jump expr k M body over-spine prog)))
(code lambda-proc
(self k M args)
(,@(unmake '(formals body env prog) 'self)
(const subst subst)
(jump subst k M formals args body env prog)))
(define debug-sal
(code-rec1
`((code debug
(self k M v)
((debug v)
,@(call 'k '(M v)))))))
(define debug-cl (cons debug-sal 'coccyx))
(define sal-lib
(append `((set-cache! (cache)
(set-memory! (cons (car (get-memory))
cache)))
(set-space! (space)
(set-memory! (cons space
(cdr (get-memory)))))
(trick (d max) (trick-loop 0 d max))
(trick-loop (s d max)
(if (= s d) s
(trick-loop (+ s 1) d max)))
(even? (i) (zero? (bit-and i 1)))
(length (l)
(if (pair? l)
(+ 1 (length (cdr l)))
0))
(compose (f g) (lambda (x) (f (g x)))))
(map (lambda (op) (list op (eval-at-top op)))
`(+ = * - imod idiv > >= < <= early= error
cons cons3 car cdr null? pair?
zero? eq? lax-zero?
bit-shift-left bit-shift-right
bit-and bit-or bit-not
load-word store-word))))
Code generated demonstrating ordinary recursion. Note the duplication, see Section ss.
(fact (x) (if (= 0 x) 1 (* x (fact (+ x -1))))) -->((code fact (k M x) ((const k0 0) (prim p1 = k0 x) (if p1 ((const k1 1) (prim p car k) (jump p k M k1))) (const k1 1) (prim x-1 - x k1) (const pq (code fin ...)) (const c0 ()) (prim c1 cons x c0) (prim c2 cons k c1) (prim k2 closure-cons pq c2) (lift k2 0 stack) (const p (code fact2 ...)) (jump p k2 M x-1)) ...)
(code fact2 (k M x) ((const k0 0) (prim p1 = k0 x) (if p1 ((const k1 1) (prim p car k) (jump p k M k1))) (const k1 1) (prim x-1 - x k1) (const pq (code fin ...)) (const c0 ()) (prim c1 cons x c0) (prim c2 cons k c1) (prim k2 closure-cons pq c2) (lift k2 0 stack) (const p (code fact2 ...)) (jump p k2 M x-1)) ...)
(code fin (self M r) ((prim d0 cdr self) (prim k car d0) (prim d1 cdr d0) (prim x car d1) (prim d2 cdr d1) (prim xr * x r) (prim p car k) (jump p k M xr)) ...))
Code generated demonstrating tail-recursion:
(even (x) (if (= 0 x) #t (odd (- x 1))))
(odd (x) (if (= 0 x) #f (even (- x 1))))
-->
((code even
(k M x)
((const k0 0)
(prim p1 = k0 x)
(if p1
((const true #t)
(prim p car k)
(jump p k M true)))
(const k1 1)
(prim x-1 - x k1)
(lift k 0 stack)
(const p (code odd ...))
(jump p k M x-1))
...)
(code odd
(k M x)
((const k0 0)
(prim p1 = k0 x)
(if p1
((const false #f)
(prim p car k)
(jump p k M false)))
(const k1 1)
(prim x-1 - x k1)
(lift k 0 stack)
(const p (code even2 ...))
(jump p k M x-1))
...)
(code even2
(k M x)
((const k0 0)
(prim p1 = k0 x)
(if p1
((const true #t)
(prim p car k)
(jump p k M true)))
(const k1 1)
(prim x-1 - x k1)
(lift k 0 stack)
(const p (code odd ...))
(jump p k M x-1))
...))
Code generated for
(object-message (x) ((make-obj x 5) 'vie))(make-obj (a b) (lambda (msg) (case msg (urk (* a 2)) (vie (+ b 3))))) -->
((code object-message (k M x) ((const vie vie) (const k5 5) (const pq (code fin ...)) (const c0 ()) (prim c1 cons vie c0) (prim c2 cons k c1) (prim k2 closure-cons pq c2) (lift k2 0 stack) (const p (code make-obj ...)) (jump p k2 M x k5)) ...)
(code make-obj (k M a b) ((const pq (code unnamed-lambda ...)) (const c0 ()) (prim c1 cons a c0) (prim c2 cons b c1) (prim obj closure-cons pq c2) (lift obj 0 stack) (prim p car k) (jump p k M obj)) ...)
(code fin (self M r) ((prim d0 cdr self) (prim k car d0) (prim d1 cdr d0) (prim msg car d1) (prim d2 cdr d1) (lift k 0 stack) (prim p car r) (const c0 ()) (prim c1 cons msg c0) (jump p r k M c1)) ...)
(code unnamed-lambda (self k M args) ((prim d0 identity self) (prim lam car d0) (prim d1 cdr d0) (prim b car d1) (prim d2 cdr d1) (prim a car d2) (prim d3 cdr d2) (prim msg car args) (prim a2 cdr args) (const urk urk) (prim p1 eq? urk msg) (if p1 ((const k2 2) (prim r * a k2) (prim p car k) (jump p k M r))) (const vie vie) (prim p2 eq? vie msg) (if p2 ((const k3 3) (prim r + b k3) (prim p car k) (jump p k M r))) (const error error) (prim p car k) (jump p k M error)) ...))
Similix 5.0 is a freely available and widely used specializer and
compiler generator. It performs monovariant binding-time analysis, so
we must use continuation-passing style for zero and equality testing.
Cyclic integers are modeled with partially-static data-structures.
Sharing information (and thus a cache) is not supported. Until I find
a way to prevent _sim-memoize from lifting its argument, dynamic
conditionals inside of loops are impossible (note commented out
definition of next for append-signal below.
The ba.adt file (this uses SCM's bit operations):
(defconstr (cyclic * * *))(defconstr (memory-signal * * * *) (constant-signal *) (delay-signal * *) (map-signal * *) (prefix-signal * *) (append-signal * * *) (prefix-list-signal * * *) (binop-signal * * *))
(defprim (divide x y) (inexact->exact (floor (/ x y)))) (defprim 2 << ash) (defprim (>> x y) (ash x (- y))) (defprim 2 & logand) (defprim 2 | logior) (defprim-dynamic (load-word x) x) (defprim-dynamic (lift x) x) (defprim (debug x) (format #t "debug ~S~%" x) x)
The ba.sim file:
(define (push d n)
(if (zero? n)
(_sim-error 'push "push out of range")
(let ((next (- n 1)))
(if (= d next)
next
(push d next)))))
(define (D->C d b)
(let ((r (modulo d b))
(q (divide d b)))
(cyclic b q (push r b))))
(define (set-base c b^)
(caseconstr c
((cyclic b q r)
(if (= b b^) c
(let ((j (lcm b b^)))
(if (= b^ j)
(let ((e (divide b^ b)))
(cyclic b^
(divide q e)
(+ (* b (push (modulo q e) e))
r)))
(let* ((e (divide j b^))
(b^^ (divide b e)))
(set-base (cyclic b^^
(+ (divide r b^^)
(lift (* q e)))
(modulo r b^^))
b^))))))))
(define (+c c s)
(caseconstr c
((cyclic b q r)
(let ((r1 (modulo (+ r s) b))
(q1 (divide (+ r s) b)))
(cyclic b (+ q q1) r1)))))
(define (zero?c c t f)
(caseconstr c
((cyclic b q r)
(if (zero? (modulo r b))
(_sim-memoize (if (zero? q) (t) (f)))
(f)))))
(define (count c r)
(zero?c c
(lambda () r)
(lambda () (count (+c c -1)
(+ r 7)))))
(define (nested-count c r)
(zero?c c
(lambda () r)
(lambda () (nested-count (+c c -1)
(+ r (count c (lift 0)))))))
(define (=c c0 c1 t f)
(caseconstr c0
((cyclic b0 q0 r0)
(caseconstr c1
((cyclic b1 q1 r1)
(if (= b0 b1)
(if (= r0 r1)
(_sim-memoize (if (= q0 q1) (t) (f)))
(f))
(_sim-error '=c "bases differ: ~S ~S" b0 b1)))))))
(define (/c c s)
(caseconstr c
((cyclic b q r)
(if (zero? (modulo b s))
(cyclic (quotient b s) q (quotient r s))
(_sim-error '/c "uneven ~S ~S" b s)))))
(define (%c c s)
(caseconstr c
((cyclic b q r)
(if (= b s) r
(_sim-error '%c "uneven ~S ~S" b s)))))
(define (mask b) (- (<< 1 b) 1))
(define (load-sample p b)
(let* ((W 32)
(wa (/c p W))
(ba (%c p W))
(w0 (load-word wa)))
(if (<= (+ b ba) W)
(& (mask b) (>> w0 ba))
(let* ((under-by (- W ba))
(s0 (& (mask under-by) (>> w0 ba)))
(w1 (load-word (/c (+c p under-by) W)))
(s1 (& w1 (mask (- b under-by)))))
(| s0 (<< s1 under-by))))))
(define (sum start stop size stride rez)
(=c start stop
(lambda () rez)
(lambda () (sum (+c start stride) stop size stride
(+ rez (load-sample start size))))))
(define (get s)
(caseconstr s
((memory-signal start stop size stride)
(load-sample start size))
((constant-signal c) c)
((delay-signal v s) v)
((prefix-signal v s) v)
((prefix-list-signal hd tl s) hd)
((append-signal hd tl s1) hd)
((map-signal f s) (f (get s)))
((binop-signal f s0 s1)
(f (get s0) (get s1)))))
(define (end? s t f)
(caseconstr s
((memory-signal start stop size stride)
(=c start stop t f))
((constant-signal c) (t))
((delay-signal v s) (end? s t f))
((prefix-signal v s) (f))
((prefix-list-signal hd tl s) (f))
((append-signal hd tl s1) (f))
((map-signal op s) (end? s t f))
((binop-signal op s0 s1)
(end? s0 (lambda () (end? s1 t f)) f)))) ; duplication
(define (next s)
(caseconstr s
((memory-signal start stop size stride)
(memory-signal (+c start stride) stop size stride))
((constant-signal c) s)
((delay-signal v s) (delay-signal (get s) (next s)))
((prefix-signal v s) s)
((prefix-list-signal hd tl s)
(if (null? tl) s (prefix-list-signal (car tl) (cdr tl) s)))
((map-signal f s) (map-signal f (next s)))
#| ((append-signal hd tl s1)
(end? tl
(lambda () s1)
(lambda ()
(append-signal (get tl) (next tl) s1)))) |#
((binop-signal f s0 s1)
(binop-signal f (next s0) (next s1)))))
(define (plus x y) (+ x y))
(define (times x y) (* x y))
(define (reduce s r f)
(end? s
(lambda () r)
(lambda () (reduce (next s) (f r (get s)) f))))
(define (filter prefix kernel in)
(if (null? prefix)
(constant-signal 0)
(binop-signal plus
(map-signal (lambda (v)
(* (car kernel) v))
in)
(filter (cdr prefix)
(cdr kernel)
(delay-signal (car prefix)
in)))))
Delimited Control: shift/reset
The material in this section is extracted from Sections 2 and 5.2 of
[DaFi92]. Shift is similar to Scheme's call/cc (call with
current continuation), but the extent of the escape procedure is
limited by reset. Figure cpssr gives the formal semantics of
shift and reset. Conceptually, they serve as composition and identity
of continuations. [LaDa94] provides an explanation their
application to partial evaluation.
Here is a simple example:
In the following example, 
is a boolean-valued term with free
variables 
. Sat is true if and only if is
satisfiable. Each call to the flip function tries returning
twice, so every possible assignement of truth values is tried until is satisfied.
terms into continuation-passing style
(CPS). The last two lines define shift and reset.