closure-examples.rkt

#lang racket

;; Closure Conversion
(define (map f l)
  (match l
    ['() '()]
    [`(,hd . ,tl) (cons
                   (let ([clo-f (vector-ref f 0)]) (clo-f f hd)) ;; (f hd)
                   (map f tl))]))

(define (is-even? x) (even? x))

;; we lifted this inner lambda, and in lifting it,
;; we take the parameters (in this case just y)
;; and add a special `clo` parameter (in this case,
;; the first parameter)
;;
;; My closures will be vectors.
;; If there are n free variables, then we put them
;; in some canonical order. Then, every time we
;; would *return* a lambda, we actually *allocate*
;; a closure. Closures will have the following structure:
;;   vector #(,fptr ,x0 ,x1 ...)
(define (inner-lambda clo y)
  ;; inside the lifted lambda, I need to know that free
  ;; variables from the lambda will be stored in
  ;; canonical order in the closure clo
  ;;
  ;; In other words, I can get x by doing (vector-ref clo 1)
  (let ([x (vector-ref clo 1)])
    (+ x y)))

(define (outer-lambda clo x)
  ;; if this lambda had free variables, we would bind them by
  ;; looking them up in clo
  (vector inner-lambda x))

;; A closure is code + data
;; in particular, it's a function pointer (to a C style function with params)
;; along with an assignment for all free variables.

(define (main)
  (map (let* ([clo (vector outer-lambda)]
              [f   (vector-ref clo 0)])
         (f clo 23))
       `(,(read) ,(read) ,(read))))

;; canonical freevars ordering a, b, c, d, x, y
(define (lam78 clo e f)
  (let* ([a (vector-ref clo 1)]  ;; first in the canonical order is a
         [b (vector-ref clo 2)]
         [c (vector-ref clo 3)]
         [d (vector-ref clo 4)]
         [x (vector-ref clo 5)]
         [y (vector-ref clo 6)])
    (+ a b c d e f x y)))

;; canonical freevars ordering a, b, x, y
(define (lam43 clo c d)
  (let* ([a (vector-ref clo 1)]
         [b (vector-ref clo 2)]
         [x (vector-ref clo 3)]
         [y (vector-ref clo 4)])
  (vector lam78 a b c d x y)))

;; canonical freevars ordering x, y
(define (lam57 clo a b)
  (let* ([x (vector-ref clo 1)]
         [y (vector-ref clo 2)])
  (vector lam43 a b x y)))

(define (f clo x y)
  (vector lam57 x y))

#;(define (f x y)
  (λ (a b) (λ (c d) (λ (e f) (+ a b c d e f x y)))))

(let* ([clo-f (f (vector f) 0 1)]
       [f-ptr (vector-ref clo-f 0)])
  (let* ([clo-f+ (f-ptr clo-f 2 3)]
         [f-ptr+ (vector-ref clo-f+ 0)])
    (let* ([clo-f++ (f-ptr+ clo-f+ 4 5)]
           [f-ptr++ (vector-ref clo-f++ 0)])
      (f-ptr++ clo-f++ 6 7))))

convert-closures.rkt

#lang racket

(define (freevars e)
  (match e
    [`(app ,e-f ,e-args ...)
     (apply set-union (map freevars (cons e-f e-args)))]
    [(? number? n) (set)]
    [(? symbol? x) (set x)]
    [`(let ([,x ,e]) ,e-b) (set-union (freevars e) (set-remove (freevars e-b) x))]
    [`(+ ,e0 ,e1) (set-union (freevars e0) (freevars e1))]
    [`(lambda (,xs ...) ,e-body)
     (foldl (lambda (x acc) (set-remove acc x)) (freevars e-body) xs)]))

;; (c-e e) -- closure-convert e
(define (closure-convert e)
  (define emitted-defines (set)) ;; initialize emitted-defines to the empty set...
  (define (emit-define! defn)
    (set! emitted-defines (set-add emitted-defines defn)))
  (define (c-e e)
    (match e
      [(? number? n) e]
      [(? symbol? x) x]
      [`(let ([,x ,e]) ,e-b) `(let ([,x ,(c-e e)]) ,(c-e e-b))]
      [`(+ ,e0 ,e1) `(+ ,(c-e e0) ,(c-e e1))]
      [`(lambda (,xs ...) ,e-body)
       ;; lift the lambda to a top-level expression
       ;; and return an allocation of that lambda
       ;; 1) Calculate free vars of e-body \ {xs ...}
       ;; 2) Put freevars in some canonical order
       ;; 3) Generate a (define (lam123 clo xs ...) e-body)
       ;; 4) in e-body, unpack the freevars (in canonical order)
       ;; 5) Emit the define
       ;; 6) Return (vector lam123 freevar0 ...) -- allocate the closure
       (define fv (freevars e))
       (define canonical-vars (set->list fv)) ;; put fv in some arbitrary order
       (define f (gensym 'lam))
       (define (unpack-freevars rest-canonical-vars n body)
         (match rest-canonical-vars
           ['() body]
           [`(,hd . ,tl)
            `(let ([,hd (vector-ref clo ,n)])
               ,(unpack-freevars (rest rest-canonical-vars) (+ n 1) body))]))
       (define new-toplevel-defn
         `(define (,f clo ,@xs)
            ,(unpack-freevars canonical-vars 1 (c-e e-body))))
       (emit-define! new-toplevel-defn)
       (define v (gensym 'vec))
       (define (pack-canonical-vars rest-canonical-vars n)
         (match rest-canonical-vars
           ['() v]
           [`(,hd . ,tl) `(let ([_ (vector-set! ,v ,n ,hd)])
                            ,(pack-canonical-vars tl (+ n 1)))]))
       `(let ([,v (make-vector ,(+ 1 (length canonical-vars)))])
          (let ([_ (vector-set! ,v 0 ,f)])
            ,(pack-canonical-vars canonical-vars 1)))]
      [`(app ,e-f ,e-args ...)
       ;; in application: assume e-f evaluates to a closure
       ;; now let-bind the function pointer and evaluate it on e-args...
       (define clo  (gensym 'clo))
       (define fptr (gensym 'fptr))
       `(let ([,clo ,(c-e e-f)])
          (let ([,fptr (vector-ref ,clo 0)])
            (app ,fptr ,clo ,@(map c-e e-args))))]))
  (cons (c-e e) emitted-defines))

;; (closure-convert '(app (app (lambda (x y) (lambda (a b) (+ (+ x y) (+ a b)))) 1 2) 3 4))