LC-Language Source Code

From the book Compiling Lambda Calculus

Provided under the Creative Commons Zero (CC0) licence

You might prefer to download the source code archive

; LC-language -> C compiler
; By Nils M Holm, 2016, 2018
;
; 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/
;
; See "lgo" for usage.

Compiler

(define prim1
  '(car cdr pairp nullp))

(define prim2
  '(cons))

Stage 1 - Syntax Expansion

(define (expand x)

  (define (x-lambda x)
    (let* ((t (cddr x))
           (t (if (null? (cdr t))
                  (exp (car t))
                  (exp `(seq ,@t)))))
      (if (pair? (cadr x))
          (if (null? (cdadr x))
              `(lam ,(caadr x)
                    ,t)
              `(lam ,(caadr x)
                    ,(x-lambda
                       `(lam ,(cdadr x)
                        ,t))))
          `(lam ,(cadr x) ,t))))

  (define (x-app x)
    (if (or (null? (cdr x))
            (null? (cddr x)))
        x
        (x-app `((,(car x) ,(cadr x))
               ,@(cddr x)))))

  (define (newsym)
    (gensym "%"))

  (define (exp-prim x)
    (cond ((memq x prim1)
            (let ((v (newsym)))
              `(lam ,v (,x ,v))))
          ((memq x prim2)
            (let ((v1 (newsym))
                  (v2 (newsym)))
              (exp `(lam (,v1 ,v2)
                      (,x ,v1 ,v2)))))
          (else
            x)))

  (define (lift-prim x)
    (if (and (not (null? (cdr x)))
             (not (null? (cddr x))))
        x
        (let ((v (newsym)))
          `(lam ,v
             (,(car x) ,(cadr x) ,v)))))

  (define (exp x)
    (cond ((not (pair? x))
            (exp-prim x))
          ((memq (car x) prim1)
            `(,(car x) ,(exp (cadr x))))
          ((memq (car x) prim2)
            (lift-prim `(,(car x) ,@(map exp (cdr x)))))
          ((memq (car x) '(if seq set))
            (map exp x))
          ((eq? 'id (car x))
            x)
          ((eq? 'lam (car x))
            (x-lambda x))
          (else
            (x-app (map exp x)))))

  (exp x))

Stage 2 - Closure Conversion

(define (cconv x)

  (define (bind x e n)
    (cons (cons x n) e))

  (define (cc x e n)
    (cond ((assq x e)
            => (lambda (b)
                 `(%ref ,(cdr b))))
          ((not (pair? x))
            x)
          ((eq? 'id (car x))
            x)
          ((eq? 'lam (car x))
            `(lam ,n ,(cc (caddr x)
                          (bind (cadr x) e n)
                          (+ 1 n))))
          (else
            (cons (cc (car x) e n)
                  (cc (cdr x) e n)))))
  (cc x '() 0))

Stage 3 - Tail Call Conversion

(define (but-last x)
  (reverse (cdr (reverse x))))

(define (last x)
  (car (reverse x)))

(define (tconv x)
  (define (tc x n t)
    (cond ((not (pair? x))
            x)
          ((memq (car x) '(id %ref))
            x)
          ((eq? (car x) 'lam)
            `(lam ,(cadr x)
                  ,(tc (caddr x) (+ 1 n) #t)))
          ((eq? (car x) 'set)
            `(set ,(cadr x)
                  ,(tc (caddr x) n #f)))
          ((eq? (car x) 'seq)
            `(seq ,@(map (lambda (x)
                           (tc x n #f))
                         (but-last (cdr x)))
                  ,(tc (last x) n t)))
          ((eq? (car x) 'if)
            `(if ,(tc (cadr x) n #f)
                 ,(tc (caddr x) n t)
                 ,(tc (cadddr x) n t)))
          (else
            `(,(if t '%tail-apply '%apply)
              ,n
              ,@(map (lambda (x)
                       (tc x n #f))
                     x)))))
  (tc x 0 #f))

Stage 4 - C Code Generation

(define (gen x)
  (define n 1)
  (define lp '(t ()))
  (define a 0)

  (define (lit x)
    (if (null? x)
        0
        (begin (set! lp (cons x lp))
               (set! n (+ 1 n))
               n)))

  (define (addr)
    (set! a (+ 1 a))
    a)

  (define (emit* . x)
    (for-each display x))

  (define (emit . x)
    (apply emit* x)
    (newline))

  (define (gjump x)
    (emit "K = " x "; break;"))

  (define (gjumpf x)
    (emit* "if (NIL == vector(S)[--P]) { ")
    (emit* "K = " x "; break; ")
    (emit "}"))

  (define (glab x)
    (emit "case " x ":"))

  (define (genv x)
    (emit "push(vector(E)[" x "]);")
    (emit* "T = box(vector(S)[P-4]); ")
    (emit "vector(E)[" x "] = T;"))

  (define (glambda x)
    (let ((end (addr))
          (fun (addr)))
      (gjump end)
      (glab fun)
      (genv (cadr x))
      (g (caddr x))
      (emit "K = ret(" (cadr x) "); break;")
      (glab end)
      (emit "pushfun(" fun ", " (cadr x) ");")))

  (define (gset x)
    (let ((a (cadadr x)))
      (g (caddr x))
      (emit "car(vector(E)[" a "]) = vector(S)[P-1];")))

  (define (gseq x)
    (for-each (lambda (x)
                (g x)
                (emit "P--;"))
              (but-last (cdr x)))
    (g (last x)))

  (define (gif x)
    (let ((a (addr))
          (c (addr)))
      (g (cadr x))
      (gjumpf a)
      (g (caddr x))
      (gjump c)
      (glab a)
      (g (cadddr x))
      (glab c)))

  (define (gapp x)
    (let ((a (addr)))
      (g (cadddr x))
      (g (caddr x))
      (emit "K = apply("
            a
            ", "
            (if (eq? '%apply (car x)) 0 (cadr x))
            "); break;")
      (glab a)))

  (define (gprim1 x)
    (g (cadddr x))
    (emit* "T = P_" (caddr x) "(vector(S)[P-1]); ")
    (emit "vector(S)[P-1] = T;"))

  (define (gprim2 x)
    (g (cadddr x))
    (g (car (cddddr x)))
    (emit* "T = P_"
           (caddr x)
           "(vector(S)[P-2], "
           "vector(S)[P-1]); ")
    (emit* "vector(S)[P-2] = T; ")
    (emit "P--;"))

  (define (prelude)
    (emit "#include \"lc.c\"")
    (emit "void run(void) {")
    (emit "for (K = 0;;) switch (K) {")
    (emit "case 0:"))

  (define (postlude)
    (emit "printexp(vector(S)[--P]);")
    (emit "return;")
    (emit "}}")
    (emit "int main(void) {")
    (emit "init();")
    (emit "L = mklitpool(\"" (reverse lp) "\");")
    (emit "run();")
    (emit "exit(0);")
    (emit "}"))

  (define (g x)
    (cond ((not (pair? x))
            (emit "#error: L: undefined: " x)
            (error "undefined" x))
          ((eq? (car x) 'id)
            (emit "push(vector(L)[" (lit (cadr x)) "]);"))
          ((eq? (car x) '%ref)
            (emit "push(unbox(vector(E)[" (cadr x) "]));"))
          ((eq? (car x) 'lam)
            (glambda x))
          ((eq? (car x) 'set)
            (gset x))
          ((eq? (car x) 'seq)
            (gseq x))
          ((eq? (car x) 'if)
            (gif x))
          ((memq (caddr x) prim1)
            (gprim1 x))
          ((memq (caddr x) prim2)
            (gprim2 x))
          (else
            (gapp x))))

  (prelude)
  (g x)
  (postlude))

(define (comp x)
  (gen (tconv (cconv (expand x)))))

Runtime Support Module

/*
 * LC-language -> C compiler, runtime
 * By Nils M Holm, 2016, 2017
 *
 * 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, "L error: %s\n", s);
	exit(1);
}

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;
}

void pushfun(int k, int n) {
	cell	fn, ne;

	ne = make_vector(n+1);
	memcpy(vector(ne), vector(E), n*sizeof(cell));
	fn = new_atom(k, ne);
	push(new_atom(T_FUNCTION, fn));
}

int apply(int k, int n) {
	T = vector(S)[P-1];
	P--;
	if (!function_p(T))
		err("application of non-function");
	if (n) {
		vector(E)[n-1] = vector(S)[P-2];
		vector(S)[P-5] = vector(S)[P-1];
		P-=2;
	}
	else {
		push(E);
		push(new_atom(k, NIL));
	}
	E = cddr(T);
	return cadr(T);
}

int ret(int n) {
	int	k;

	T = vector(S)[P-1];
	vector(E)[n] = vector(S)[P-2];
	k = car(vector(S)[P-3]);
	E = vector(S)[P-4];
	P -= 4;
	vector(S)[P-1] = T;
	return k;
}

#define P_cons		cons
#define P_car		car
#define P_cdr		cdr
#define P_pairp(x)	(pair_p(x)? vector(L)[1]: NIL)
#define P_nullp(x)	(NIL == x? vector(L)[1]: NIL)

contact  |  privacy