rain-1 · February 17, 2019 16:46 · rain-1 · Mar 6, 2019
diff --git a/serialize-lisp.rkt b/serialize-lisp.rkt
 #lang racket

 ;; This implements a baby lisp interpreter using closure conversion pass before execution
 ;; It supports serialization of closures (e.g. for partial evaluation/staging) and reading back and executing those objects

 (require data/queue)

 ;; closure conversion for lambda calculus
 ;;
 ;; the input language is:
 ;;
 ;; <l> ::= <var>
 ;;       | <datum>
 ;;       | (lambda (<var> ...) <l> ...)
 ;;       | (if <l> <l> <l>)
 ;;       | (begin <l> ...)
 ;;       | (<l> <l> ...)
 ;;
 ;; the output language is
 ;;
 ;; <cc> ::= (var loc <index>)
 ;;        | (var env <index>)
 ;;        | (var glo <var>)
 ;;        | (datum <datum>)
 ;;        | (closure (<capture> ...) <cc>)
 ;;        | (if <cc> <cc> <cc>)
 ;;        | (begin <cc> ...)
 ;;        | (app <cc> <cc> ...)
 ;;
 ;; <capture> ::= (var loc <index>)
 ;;             | (var env <index>)
 ;;
 ;; Variables have been annotated with their storage type and
 ;; lambda functions have been replaced with closure objects
 ;; all of the variables captured by a lambda have been packaged
 ;; up with the closure object


 ;;;; HELPERS

 (define (every p l)
  (if (null? l)
      #t
      (and (p (car l)) (every p (cdr l)))))

 (define (index v l)
  (for/first ([i (in-naturals)]
              [elt (in-list l)]
              #:when (equal? elt v))
    i))

 (define (queue-index v q)
  (for/first ([i (in-naturals)]
              [elt (in-queue q)]
              #:when (equal? elt v))
    i))

 (define-syntax mapply
  (syntax-rules ()
    ((mapply f xs arg ...)
     (map (lambda (x) (f x arg ...)) xs))))


 ;;;; SHAPES

 (define (var? x) (symbol? x))
 (define (datum? x) (or (boolean? x) (number? x)))
 (define (lambda? x)
  (if (and (pair? x) (eq? 'lambda (car x)))
      (if (and (every symbol? (cadr x))
               (not (null? (cddr x))))
          #t
          (error "malformed lambda expression" x))
      #f))
 (define (lambda-bindings x) (cadr x))
 (define (lambda-body x) (implicit-begin (cddr x)))
 (define (if? x) (and (pair? x) (eq? 'if (car x))))
 (define (begin? x) (and (pair? x) (eq? 'begin (car x))))
 (define (application? x) (pair? x))

 (define (quoted-symbol? x)
  (and (pair? x)
       (eq? (car x) 'quote)
       (pair? (cdr x))
       (null? (cddr x))
       (or (symbol? (cadr x))
           (null? (cadr x)))))

 (define (implicit-begin xs)
  (if (null? xs)
      (error "empty expression list")
      (if (null? (cdr xs))
          (car xs)
          `(begin . ,xs))))


 ;; CLOSURE CONVERSION

 (struct closure (arity env body) #:prefab)

 (struct scope (locals env captures globals))
 ;;
 ;; locals is a list of symbols
 ;; - it's the variables bound by the current lambda alternatively the top stack frame
 ;;
 ;; env is a list of symbols
 ;; - is a list of every non-global variable that has been brought into scope by lambda binders
 ;;   for example in (lambda (a b) (lambda (x y) <here>)) at the point <here> the env is (x y a b)
 ;;
 ;; captures is a queue of symbols
 ;; - If you reference a variable that isn't global or local it'll be captured and put into this queue
 ;;   at the end of processing a subexpression, this queue becomes the closure environment
 ;;
 ;; globals is a list of symbols
 ;; - car, cdr, cons etc.

 (define (classify var scope)
  ;; classify a variable with its storage type based on a scope
  (cond ((index var (scope-locals scope))
         => (lambda (i) `(var loc ,i)))
        ((member var (scope-env scope))
         (cond ((queue-index var (scope-captures scope))
                => (lambda (i) `(var env ,i)))
               (else
                (enqueue! (scope-captures scope) var)
                (let ((i (- (queue-length (scope-captures scope)) 1)))
                  `(var env ,i)))))
        ((assoc var (scope-globals scope))
         `(var glo ,var))
        (else (error "unbound variable error" var))))

 (define (cc exp sc)
  (cond ((var? exp) (classify exp sc))

        ((datum? exp) `(datum ,exp))
        ((quoted-symbol? exp) `(datum ,(cadr exp)))

        ((lambda? exp)
         (let* ((vars (lambda-bindings exp))
                (body (lambda-body exp))
                (captures^ (make-queue))
                (sc^ (scope vars
                            (append (scope-locals sc) (scope-env sc))
                            captures^
                            (scope-globals sc)))
                (body^ (cc body sc^)))
           (closure (length vars) (mapply cc (queue->list captures^) sc) body^)))

        ((if? exp)
         `(if . ,(mapply cc (cdr exp) sc)))
        
        ((begin? exp)
         `(begin . ,(mapply cc (cdr exp) sc)))

        ((application? exp)
         `(app . ,(mapply cc exp sc)))

        (else (error "malformed expression in cc" exp))))

 ;;;; INTERPRETER

 (define-syntax make-globals
  (syntax-rules ()
    ((_ <sym> ...) `((<sym> . ,<sym>) ...))))

 (define y-comb
  '(lambda (f)
     ((lambda (g) (g g))
      (lambda (g)       
        (f (lambda (a) ((g g) a)))))))

 (define globals
  (make-globals
   car cdr cons null?
   read write))

 (struct stack-frame (locals env) #:transparent)

 (define (exec exp stk)
 ;  (print `(exec ,exp ,stk))
  (match exp
    (`(var loc ,i)
     (list-ref (stack-frame-locals (car stk)) i))
    (`(var env ,i)
     (list-ref (stack-frame-env (car stk)) i))
    (`(var glo ,g)
     (cond ((assoc g globals) => (lambda (entry) (cdr entry)))
           (else (error "exec: missing global" g))))

    (`(datum ,d) d)

    ((closure arity caps body) (closure arity (mapply exec caps stk) body))

    (`(if ,t ,c ,a)
     (if (exec t stk)
         (exec c stk)
         (exec a stk)))

    (`(begin . ,exps)
     (let loop ((exps exps) (res #f))
       (if (null? exps)
           res
           (loop (cdr exps) (exec (car exps) stk)))))

    (`(app . ,exps)
     (let ((exps^ (mapply exec exps stk)))
       (exec/apply (car exps^) (cdr exps^) stk)))

    (else (error "exec: unknown" exp))))

 (define (exec/apply f xs stk)
  (cond ((closure? f)
         (unless (= (closure-arity f) (length xs))
           (error "exec/apply: closure applied with wrong arity" (list (closure-arity f) (length xs))))
         (exec (closure-body f)
               (cons (stack-frame xs (closure-env f)) stk)))
        ((procedure? f)
         (apply f xs))
        (else (error "exec/apply: not a closure or procedure" f))))

 ;;;; TESTING, EXAMPLES

 (define (print x) (display x) (newline))

 (define (go exp)
  (let ((res
         (cc exp (scope '()
                        '()
                        (make-queue)
                        globals))))
 ;    (print res)
    (let ((res^
           (exec res '())))
      (print exp)
      (display "==> ")
      (print res^)
      (newline))))

 (define (test)
  (go '3)
  (go '((lambda (x) x) 3))
  (go '((lambda (x y) x) 3 5))
  (go '((lambda (x y) y) 3 5))
  (go '((lambda (k x y) (car (k y x))) cons 7 5))
  (go '((lambda (k x y) (cdr (k y x))) cons 7 5))
  (go '(((lambda (x) (lambda (y) y)) 1) 2))
  (go '(((lambda (x) (lambda (y) x)) 1) 2))
  (go '((((lambda (x) (lambda (y) (lambda (z) z))) 1) 2) 3))
  (go '((((lambda (x) (lambda (y) (lambda (z) y))) 1) 2) 3))
  (go '((((lambda (x) (lambda (y) (lambda (z) x))) 1) 2) 3))
  (go '((lambda (f) ((f 'a) 'b)) (lambda (x) (lambda (y) y))))
  (go '((lambda (f) ((f 'a) 'b)) (lambda (x) (lambda (y) x))))
  (go '((lambda (kons kar kdr)
          (cons (kar (kons 'a 'b))
                (kdr (kons 'a 'b))))
        (lambda (p q)
          (lambda (c)
            (c p q)))
        (lambda (c) (c (lambda (p q) p)))
        (lambda (c) (c (lambda (p q) q)))))
  (go '(if #t 'true 'false))
  (go '(if #f 'true 'false))
  (go `(((lambda (y l2)
           (y (lambda (append)
                (lambda (l1)
                  (if (null? l1)
                      l2
                      (cons (car l1) (append (cdr l1))))))))
         ,y-comb
         (cons 'a (cons 'b (cons 'c '()))))
        (cons 'x (cons 'y (cons 'z '())))))
  (go `(((,y-comb (lambda (append)
              (lambda (l1)
                (if (null? l1)
                    (lambda (l2) l2)
                    ((lambda (ev1 ev2)
                       (lambda (l2)
                         (cons ev1 (ev2 l2))))
                     (car l1)
                     (append (cdr l1)))))))
         (cons 'a (cons 'b (cons 'c '()))))
        (cons 'x (cons 'y (cons 'z '())))))
  (go `(write ((,y-comb (lambda (append)
                          (lambda (l1)
                            (if (null? l1)
                                (lambda (l2) l2)
                                ((lambda (ev1 ev2)
                                   (lambda (l2)
                                     (cons ev1 (ev2 l2))))
                                 (car l1)
                                 (append (cdr l1)))))))
               (cons 'a (cons 'b (cons 'c '()))))))
  (go `((read) (cons 'x (cons 'y (cons 'z '())))))
  )

 ;; pasted the above into the READ prompt
 ;;
 ;; #s(closure 1 (a #s(closure 1 (b #s(closure 1 (c #s(closure 1 () (var loc 0))) (app (var glo cons) (var env 0) (app (var env 1) (var loc 0))))) (app (var glo cons) (var env 0) (app (var env 1) (var loc 0))))) (app (var glo cons) (var env 0) (app (var env 1) (var loc 0))))
 ;
 ;; ((read) (cons 'x (cons 'y (cons 'z '()))))
 ;; ==> (a b c x y z)

 (test)
	#lang racket

	;; This implements a baby lisp interpreter using closure conversion pass before execution
	;; It supports serialization of closures (e.g. for partial evaluation/staging) and reading back and executing those objects

	(require data/queue)

	;; closure conversion for lambda calculus
	;;
	;; the input language is:
	;;
	;; <l> ::= <var>
	;; \| <datum>
	;; \| (lambda (<var> ...) <l> ...)
	;; \| (if <l> <l> <l>)
	;; \| (begin <l> ...)
	;; \| (<l> <l> ...)
	;;
	;; the output language is
	;;
	;; <cc> ::= (var loc <index>)
	;; \| (var env <index>)
	;; \| (var glo <var>)
	;; \| (datum <datum>)
	;; \| (closure (<capture> ...) <cc>)
	;; \| (if <cc> <cc> <cc>)
	;; \| (begin <cc> ...)
	;; \| (app <cc> <cc> ...)
	;;
	;; <capture> ::= (var loc <index>)
	;; \| (var env <index>)
	;;
	;; Variables have been annotated with their storage type and
	;; lambda functions have been replaced with closure objects
	;; all of the variables captured by a lambda have been packaged
	;; up with the closure object


	;;;; HELPERS

	(define (every p l)
	(if (null? l)
	#t
	(and (p (car l)) (every p (cdr l)))))

	(define (index v l)
	(for/first ([i (in-naturals)]
	[elt (in-list l)]
	#:when (equal? elt v))
	i))

	(define (queue-index v q)
	(for/first ([i (in-naturals)]
	[elt (in-queue q)]
	#:when (equal? elt v))
	i))

	(define-syntax mapply
	(syntax-rules ()
	((mapply f xs arg ...)
	(map (lambda (x) (f x arg ...)) xs))))


	;;;; SHAPES

	(define (var? x) (symbol? x))
	(define (datum? x) (or (boolean? x) (number? x)))
	(define (lambda? x)
	(if (and (pair? x) (eq? 'lambda (car x)))
	(if (and (every symbol? (cadr x))
	(not (null? (cddr x))))
	#t
	(error "malformed lambda expression" x))
	#f))
	(define (lambda-bindings x) (cadr x))
	(define (lambda-body x) (implicit-begin (cddr x)))
	(define (if? x) (and (pair? x) (eq? 'if (car x))))
	(define (begin? x) (and (pair? x) (eq? 'begin (car x))))
	(define (application? x) (pair? x))

	(define (quoted-symbol? x)
	(and (pair? x)
	(eq? (car x) 'quote)
	(pair? (cdr x))
	(null? (cddr x))
	(or (symbol? (cadr x))
	(null? (cadr x)))))

	(define (implicit-begin xs)
	(if (null? xs)
	(error "empty expression list")
	(if (null? (cdr xs))
	(car xs)
	`(begin . ,xs))))


	;; CLOSURE CONVERSION

	(struct closure (arity env body) #:prefab)

	(struct scope (locals env captures globals))
	;;
	;; locals is a list of symbols
	;; - it's the variables bound by the current lambda alternatively the top stack frame
	;;
	;; env is a list of symbols
	;; - is a list of every non-global variable that has been brought into scope by lambda binders
	;; for example in (lambda (a b) (lambda (x y) <here>)) at the point <here> the env is (x y a b)
	;;
	;; captures is a queue of symbols
	;; - If you reference a variable that isn't global or local it'll be captured and put into this queue
	;; at the end of processing a subexpression, this queue becomes the closure environment
	;;
	;; globals is a list of symbols
	;; - car, cdr, cons etc.

	(define (classify var scope)
	;; classify a variable with its storage type based on a scope
	(cond ((index var (scope-locals scope))
	=> (lambda (i) `(var loc ,i)))
	((member var (scope-env scope))
	(cond ((queue-index var (scope-captures scope))
	=> (lambda (i) `(var env ,i)))
	(else
	(enqueue! (scope-captures scope) var)
	(let ((i (- (queue-length (scope-captures scope)) 1)))
	`(var env ,i)))))
	((assoc var (scope-globals scope))
	`(var glo ,var))
	(else (error "unbound variable error" var))))

	(define (cc exp sc)
	(cond ((var? exp) (classify exp sc))

	((datum? exp) `(datum ,exp))
	((quoted-symbol? exp) `(datum ,(cadr exp)))

	((lambda? exp)
	(let* ((vars (lambda-bindings exp))
	(body (lambda-body exp))
	(captures^ (make-queue))
	(sc^ (scope vars
	(append (scope-locals sc) (scope-env sc))
	captures^
	(scope-globals sc)))
	(body^ (cc body sc^)))
	(closure (length vars) (mapply cc (queue->list captures^) sc) body^)))

	((if? exp)
	`(if . ,(mapply cc (cdr exp) sc)))

	((begin? exp)
	`(begin . ,(mapply cc (cdr exp) sc)))

	((application? exp)
	`(app . ,(mapply cc exp sc)))

	(else (error "malformed expression in cc" exp))))

	;;;; INTERPRETER

	(define-syntax make-globals
	(syntax-rules ()
	((_ <sym> ...) `((<sym> . ,<sym>) ...))))

	(define y-comb
	'(lambda (f)
	((lambda (g) (g g))
	(lambda (g)
	(f (lambda (a) ((g g) a)))))))

	(define globals
	(make-globals
	car cdr cons null?
	read write))

	(struct stack-frame (locals env) #:transparent)

	(define (exec exp stk)
	; (print `(exec ,exp ,stk))
	(match exp
	(`(var loc ,i)
	(list-ref (stack-frame-locals (car stk)) i))
	(`(var env ,i)
	(list-ref (stack-frame-env (car stk)) i))
	(`(var glo ,g)
	(cond ((assoc g globals) => (lambda (entry) (cdr entry)))
	(else (error "exec: missing global" g))))

	(`(datum ,d) d)

	((closure arity caps body) (closure arity (mapply exec caps stk) body))

	(`(if ,t ,c ,a)
	(if (exec t stk)
	(exec c stk)
	(exec a stk)))

	(`(begin . ,exps)
	(let loop ((exps exps) (res #f))
	(if (null? exps)
	res
	(loop (cdr exps) (exec (car exps) stk)))))

	(`(app . ,exps)
	(let ((exps^ (mapply exec exps stk)))
	(exec/apply (car exps^) (cdr exps^) stk)))

	(else (error "exec: unknown" exp))))

	(define (exec/apply f xs stk)
	(cond ((closure? f)
	(unless (= (closure-arity f) (length xs))
	(error "exec/apply: closure applied with wrong arity" (list (closure-arity f) (length xs))))
	(exec (closure-body f)
	(cons (stack-frame xs (closure-env f)) stk)))
	((procedure? f)
	(apply f xs))
	(else (error "exec/apply: not a closure or procedure" f))))

	;;;; TESTING, EXAMPLES

	(define (print x) (display x) (newline))

	(define (go exp)
	(let ((res
	(cc exp (scope '()
	'()
	(make-queue)
	globals))))
	; (print res)
	(let ((res^
	(exec res '())))
	(print exp)
	(display "==> ")
	(print res^)
	(newline))))

	(define (test)
	(go '3)
	(go '((lambda (x) x) 3))
	(go '((lambda (x y) x) 3 5))
	(go '((lambda (x y) y) 3 5))
	(go '((lambda (k x y) (car (k y x))) cons 7 5))
	(go '((lambda (k x y) (cdr (k y x))) cons 7 5))
	(go '(((lambda (x) (lambda (y) y)) 1) 2))
	(go '(((lambda (x) (lambda (y) x)) 1) 2))
	(go '((((lambda (x) (lambda (y) (lambda (z) z))) 1) 2) 3))
	(go '((((lambda (x) (lambda (y) (lambda (z) y))) 1) 2) 3))
	(go '((((lambda (x) (lambda (y) (lambda (z) x))) 1) 2) 3))
	(go '((lambda (f) ((f 'a) 'b)) (lambda (x) (lambda (y) y))))
	(go '((lambda (f) ((f 'a) 'b)) (lambda (x) (lambda (y) x))))
	(go '((lambda (kons kar kdr)
	(cons (kar (kons 'a 'b))
	(kdr (kons 'a 'b))))
	(lambda (p q)
	(lambda (c)
	(c p q)))
	(lambda (c) (c (lambda (p q) p)))
	(lambda (c) (c (lambda (p q) q)))))
	(go '(if #t 'true 'false))
	(go '(if #f 'true 'false))
	(go `(((lambda (y l2)
	(y (lambda (append)
	(lambda (l1)
	(if (null? l1)
	l2
	(cons (car l1) (append (cdr l1))))))))
	,y-comb
	(cons 'a (cons 'b (cons 'c '()))))
	(cons 'x (cons 'y (cons 'z '())))))
	(go `(((,y-comb (lambda (append)
	(lambda (l1)
	(if (null? l1)
	(lambda (l2) l2)
	((lambda (ev1 ev2)
	(lambda (l2)
	(cons ev1 (ev2 l2))))
	(car l1)
	(append (cdr l1)))))))
	(cons 'a (cons 'b (cons 'c '()))))
	(cons 'x (cons 'y (cons 'z '())))))
	(go `(write ((,y-comb (lambda (append)
	(lambda (l1)
	(if (null? l1)
	(lambda (l2) l2)
	((lambda (ev1 ev2)
	(lambda (l2)
	(cons ev1 (ev2 l2))))
	(car l1)
	(append (cdr l1)))))))
	(cons 'a (cons 'b (cons 'c '()))))))
	(go `((read) (cons 'x (cons 'y (cons 'z '())))))
	)

	;; pasted the above into the READ prompt
	;;
	;; #s(closure 1 (a #s(closure 1 (b #s(closure 1 (c #s(closure 1 () (var loc 0))) (app (var glo cons) (var env 0) (app (var env 1) (var loc 0))))) (app (var glo cons) (var env 0) (app (var env 1) (var loc 0))))) (app (var glo cons) (var env 0) (app (var env 1) (var loc 0))))
	;
	;; ((read) (cons 'x (cons 'y (cons 'z '()))))
	;; ==> (a b c x y z)

	(test)