From the book Compiling Lambda Calculus
Provided under the Creative Commons Zero (CC0) licence
You might prefer to download the source code archive
; Scheme_3 compiler with C code back-end ; By Nils M Holm, 2016 ; ; Provided under the Creative Common Zero (CC0) license ; (https://creativecommons.org/publicdomain/zero/1.0/) ; ; From the book COMPILING LAMBDA CALCULUS, http://t3x.org/clc/ ; Example: (with-output-to-file "tmp.c" ; (lambda () ; (comp '(((lambda (x) (lambda (y) (cons x y))) 'x) 'y)))) ; ; ;; And then: cc -o tmp tmp.c s9core.c && ./tmp (define version 8) (define (but-last x) (reverse (cdr (reverse x)))) (define (last x) (car (reverse x))) (define (lc-error m . a) (apply error (string-append "lc: " m) a))
(define prim-op cadr) (define prim-args cddr) (define prim-narg caddr) (define primitives '((cons %cons 2 #f) (car %car 1 #f) (cdr %cdr 1 #f) (pair? %pair? 1 #f) (null? %null? 1 #f)))
(define (stage1 x) (define (flatten x) (define (f x r) (cond ((null? x) r) ((pair? x) (f (car x) (f (cdr x) r))) (else (cons x r)))) (f x '())) (define (bind xs e n) (if (null? xs) e (cons (cons (car xs) n) (bind (cdr xs) e (+ 1 n))))) (define (cconv x e n) (cond ((assq x e) => (lambda (b) `(%ref ,(cdr b)))) ((not (pair? x)) x) ((eq? 'quote (car x)) x) ((eq? 'lambda (car x)) (let ((a (flatten (cadr x)))) `(lambda (,n ,(+ n (length a)) ,(not (list? (cadr x)))) ,@(cconv (cddr x) (bind a e n) (+ (length a) n))))) (else (cons (cconv (car x) e n) (cconv (cdr x) e n))))) (define (closure-conv x) (cconv x '() 0)) (define (assert-args! x n v) (let ((k (length (cdr x)))) (cond ((= k n)) ((and (> k n) v)) (else (lc-error "wrong argument count" x))))) (define (new-sym i) (string->symbol (string-append "x" (number->string i)))) (define (prim-fun x) (let vars ((i (prim-narg x)) (v '())) (if (zero? i) (cons '%lambda (cdr (closure-conv `(lambda ,v (,(prim-op x) ,@v))))) (vars (- i 1) (cons (new-sym i) v))))) (define (comp-expr x t) (cond ((assq x primitives) => prim-fun) ((symbol? x) (lc-error "undefined" x)) ((not (pair? x)) x) ((eq? 'quote (car x)) (assert-args! x 1 #f) `(%quote ,(cadr x))) ((eq? 'lambda (car x)) (assert-args! x 2 #t) `(%lambda ,(cadr x) ,(if (null? (cdddr x)) (comp-expr (caddr x) #t) (comp-expr (cons 'begin (cddr x)) #t)))) ((eq? '%ref (car x)) x) ((eq? 'if (car x)) (assert-args! x 3 #f) `(%if ,(comp-expr (cadr x) #f) ,(comp-expr (caddr x) t) ,(comp-expr (cadddr x) t))) ((eq? 'set! (car x)) (assert-args! x 2 #f) `(%set! ,(cadr x) ,(comp-expr (caddr x) #f))) ((eq? 'begin (car x)) (assert-args! x 1 #t) `(%begin ,@(map (lambda (x) (comp-expr x #f)) (but-last (cdr x))) ,(comp-expr (last x) t))) ((assq (car x) primitives) => (lambda (i) (apply assert-args! x (prim-args i)) `(,(prim-op i) ,@(map (lambda (x) (comp-expr x #f)) (cdr x))))) (else `(,(if t '%tail-apply '%apply) ,@(map (lambda (x) (comp-expr x #f)) x))))) (comp-expr (closure-conv x) #f))
(define (stage2 x) (define fp-osize car) (define fp-nsize cadr) (define fp-var? caddr) (define Prog '()) (define Lab 0) (define Lit (reverse '(() t))) (define Nlit 1) (define (newlabel) (set! Lab (+ 1 Lab)) Lab) (define (newlit) (set! Nlit (+ 1 Nlit)) Nlit) (define (emit x) (set! Prog (cons x Prog))) (define (comp-lambda x) (let ((osize (fp-osize (cadr x))) (nsize (fp-nsize (cadr x))) (funlab (newlabel)) (endlab (newlabel))) (emit `(%%jump ,endlab)) (emit `(%%label ,funlab)) (if (fp-var? (cadr x)) (emit `(%%collect-args ,(- nsize osize)))) (emit `(%%save-vars ,osize ,nsize)) (emit `(%%assert-args ,(- nsize osize))) (let loop ((i 0)) (if (< i (- nsize osize)) (begin (emit `(%%setup-env ,i ,(- nsize i 1))) (loop (+ 1 i))))) (comp-s2 (caddr x)) (emit `(%%return)) (emit `(%%label ,endlab)) (emit `(%%fun ,funlab ,osize ,nsize)))) (define (comp-apply x t) (let ((k (newlabel))) (for-each comp-s2 (cddr x)) (emit `(%%val ,(length (cddr x)))) (comp-s2 (cadr x)) (emit (if t `(%%tail-apply ,k) `(%%apply ,k))) (emit `(%%label ,k)))) (define (comp-ref x) (emit `(%%ref ,(cadr x)))) (define (comp-quote x) (if (null? (cadr x)) (emit '(%%lit 0)) (begin (set! Lit (cons (cadr x) Lit)) (emit `(%%lit ,(newlit)))))) (define (comp-if x) (let ((tlab (newlabel)) (flab (newlabel))) (comp-s2 (cadr x)) (emit `(%%jump-false ,flab)) (comp-s2 (caddr x)) (emit `(%%jump ,tlab)) (emit `(%%label ,flab)) (comp-s2 (cadddr x)) (emit `(%%label ,tlab)))) (define (comp-begin x) (let loop ((x (cdr x))) (cond ((null? (cdr x)) (comp-s2 (car x))) (else (comp-s2 (car x)) (emit '(%%drop)) (loop (cdr x)))))) (define (comp-set x) (comp-s2 (caddr x)) (let ((loc (cadr x))) (emit `(%%set-ref! ,(cadr loc))))) (define (comp-prim x p) (for-each comp-s2 (cdr x)) (emit (cond ((eq? '%cons p) '(%%cons)) ((eq? '%car p) '(%%car)) ((eq? '%cdr p) '(%%cdr)) ((eq? '%pair? p) '(%%pair?)) ((eq? '%null? p) '(%%null?))))) (define prim-ops (map cadr primitives)) (define (comp-s2 x) (cond ((eq? '%lambda (car x)) (comp-lambda x)) ((eq? '%apply (car x)) (comp-apply x #f)) ((eq? '%tail-apply (car x)) (comp-apply x #t)) ((eq? '%ref (car x)) (comp-ref x)) ((eq? '%quote (car x)) (comp-quote x)) ((eq? '%if (car x)) (comp-if x)) ((eq? '%set! (car x)) (comp-set x)) ((eq? '%begin (car x)) (comp-begin x)) ((memq (car x) prim-ops) => (lambda (i) (comp-prim x (car i)))) (else (error "unknown op in stage2" x)))) (comp-s2 x) (emit '(%%halt)) (cons (cons '%%litpool (reverse Lit)) (reverse Prog)))
(define (stage3 x) (define (emit* . x) (for-each display x)) (define (emit . x) (apply emit* x) (newline)) (define (comp x) (let ((op (car x))) (cond ((eq? op '%%apply) (emit "K = apply(" (cadr x) ", 0); break;")) ((eq? op '%%assert-args) (emit* "if ((int) car(vector(S)[P-4]) != ") (emit (cadr x) ") err1();")) ((eq? op '%%car) (emit "vector(S)[P-1] = car(vector(S)[P-1]);")) ((eq? op '%%cdr) (emit "vector(S)[P-1] = cdr(vector(S)[P-1]);")) ((eq? op '%%collect-args) (emit "collect_args(" (cadr x) ");")) ((eq? op '%%cons) (emit* "vector(S)[P-2] = cons(vector(S)[P-2],") (emit " vector(S)[P-1]); P--;")) ((eq? op '%%drop) (emit "P--;")) ((eq? op '%%fun) (emit "pushfun(" (cadr x) ", " (caddr x) ", " (cadddr x) ");")) ((eq? op '%%halt) (emit "printexp(pop());") (emit "exit(0);")) ((eq? op '%%jump) (emit "K = " (cadr x) "; break;")) ((eq? op '%%jump-false) (emit "if (pop() == NIL) { K = " (cadr x) "; break; }")) ((eq? op '%%label) (emit "case " (cadr x) ":")) ((eq? op '%%lit) (emit "push(vector(L)[" (cadr x) "]);")) ((eq? op '%%litpool) (emit "L = mklitpool(\"" (cdr x) "\");") (emit "for (K = 0;;) switch (K) {") (emit "case 0:")) ((eq? op '%%null?) (emit* "vector(S)[P-1] = NIL == vector(S)[P-1]?") (emit "vector(L)[1]: NIL;")) ((eq? op '%%pair?) (emit* "vector(S)[P-1] = pair_p(vector(S)[P-1])?") (emit "vector(L)[1]: NIL;")) ((eq? op '%%ref) (emit "push(unbox(vector(E)[" (cadr x) "]));")) ((eq? op '%%return) (emit "K = ret(); break;")) ((eq? op '%%save-vars) (emit "save_vars(" (cadr x) ", " (caddr x) ");")) ((eq? op '%%set-ref!) (emit "car(vector(E)[" (cadr x) "]) = vector(S)[P-1];")) ((eq? op '%%setup-env) (emit* "T = box(vector(S)[P" (- -5 (cadr x)) "]); ") (emit "vector(E)[" (caddr x) "] = T;")) ((eq? op '%%tail-apply) (emit "K = apply(" (cadr x) ", 1); break;")) ((eq? op '%%val) (emit "pushval(" (cadr x) ");")) (else (lc-error "bad opcode" x))))) (emit "#include \"scm8.c\"") (emit "int main(void) {") (emit "init();") (for-each comp x) (emit "}}")) (define (comp x) (stage3 (stage2 (stage1 x))))
/* * Scheme_3 compiler runtime * By Nils M Holm, 2016 * * Provided under the Creative Common Zero (CC0) license * (https://creativecommons.org/publicdomain/zero/1.0/) * * From the book COMPILING LAMBDA CALCULUS, http://t3x.org/clc/ */ #include "s9core.h" #include "s9import.h" #define SEG 1000 #define box(x) cons((x),NIL) #define unbox car cell E, L, S, T; int K, P, Z; char *I; cell *R[] = { &E, &L, &S, &T, NULL }; void err(char *s) { fprintf(stderr, "LC8 error: %s\n", s); exit(1); } void err1(void) { err("wrong number of arguments"); } void init(void) { s9_init(R); P = 0; Z = SEG; S = make_vector(Z); } cell readexp(void) { #define B 256 char b[B]; int i; cell n, a, p; while (isspace(*I)) I++; if ('(' == *I) { I++; a = NIL; n = readexp(); while (n != VOID) { if (NIL == a) { save(a = cons(NIL, NIL)); } else { p = cons(NIL, NIL); cdr(a) = p; a = cdr(a); } car(a) = n; n = readexp(); } if (NIL == a) return NIL; return unsave(1); } else if (')' == *I) { I++; return VOID; } else { for (i = 0; !isspace(*I) && ')' != *I; i++) { b[i] = *I++; if (i >= B) err("symbol too long"); } b[i] = 0; return symbol_ref(b); } } void px(cell x) { if (function_p(x)) { printf("#<function %d>", (int) cadr(x)); } else if (symbol_p(x)) { printf("%s", symbol_name(x)); } else if (NIL == x) { printf("()"); } else { putchar('('); while (!atom_p(x)) { px(car(x)); x = cdr(x); if (pair_p(x)) putchar(' '); } if (x != NIL) { printf(" . "); px(x); } putchar(')'); } } void printexp(cell x) { px(x); putchar('\n'); } cell mklitpool(char *s) { cell n, v, *vv; int i; I = s; n = readexp(); save(n); v = make_vector(length(n)); unsave(1); vv = vector(v); for (i = 0; n != NIL; n = cdr(n)) vv[i++] = car(n); return v; } void push(cell x) { cell v; if (P >= Z) { T = x; v = make_vector(Z+SEG); memcpy(vector(v), vector(S), Z*sizeof(cell)); Z += SEG; S = v; } vector(S)[P++] = x; } cell pop(void) { if (P < 0) err("stack underflow"); return vector(S)[--P]; } void pushval(int n) { push(new_atom(n, NIL)); } int popval(void) { return car(pop()); } void pushfun(int k, int n, int z) { cell fn, ne; ne = make_vector(z); memcpy(vector(ne), vector(E), n*sizeof(cell)); fn = new_atom(k, ne); push(new_atom(T_FUNCTION, fn)); } void collect_args(int na) { cell k, e, va; int n, i; k = vector(S)[P-1]; e = vector(S)[P-2]; n = car(vector(S)[P-3]); if (n < na-1) err1(); save(va = NIL); for (i = 0; n-i >= na; i++) { va = cons(vector(S)[P-4-i], va); car(Stack) = va; } va = unsave(1); P = P-i+1; vector(S)[P-1] = k; vector(S)[P-2] = e; vector(S)[P-4] = va; /* save va first! */ vector(S)[P-3] = box(na); } void save_vars(int n, int k) { cell v; int i; v = make_vector(k-n); for (i=n; i<k; i++) vector(v)[i-n] = vector(E)[i]; push(v); } void restore_vars(cell v) { int kv, ke, i; kv = vector_len(v); ke = vector_len(E); for (i=0; i<kv; i++) vector(E)[ke-kv+i] = vector(v)[i]; } int apply(int k, int tco) { int m, n; cell e, kk; T = pop(); if (!function_p(T)) err("application of non-function"); if (tco) { m = unbox(vector(S)[P-1])+1; restore_vars(vector(S)[P-3]); kk = vector(S)[P-m-2]; e = vector(S)[P-m-3]; n = unbox(vector(S)[P-m-4])+1; memcpy(&vector(S)[P-m-n-3], &vector(S)[P-m], m*sizeof(cell)); P -= n+1; vector(S)[P-1] = kk; vector(S)[P-2] = e; E = cddr(T); return cadr(T); } push(E); pushval(k); E = cddr(T); return cadr(T); } int ret(void) { int k, n; T = pop(); restore_vars(pop()); k = popval(); E = pop(); n = popval(); P -= n; push(T); return k; }