lambda calculus -> c compiler

lc->c.lisp

;; compiles untyped lambda calculus to portable C
;; syntax
;; (lambda x x) - lambda abstraction
;; (x y)        - lambda combination (assuming x and y are bound)



;; map of function names to declarations
;; kept separate from the rest of the C code because they need to be forward-declared
(defvar *lambda-map* nil)


(defun c-compile-lambda (expression outfile)
  (with-open-file (out outfile :direction :output
                       :if-does-not-exist :create :if-exists :supersede)
    (format out "~a" (lambda->c expression))))


;; c type definitions, includes, etc.
(defun prelude ()
  (cat-new
   (emit "#include \"stdlib.h\"")
   (emit "#include \"stdio.h\"")
   (emit "#include \"string.h\"")
   (emit "#define MULTI_LINE_STRING(a) #a")
   (emit "typedef struct closure * (*lambda_func)();")
   (emit "typedef struct closure { char* str; lambda_func func; struct env* environment;} closure;")
   (emit "typedef struct env { struct env* next; closure* dat;} env;~%")
   (emit "env** stack;")
   (emit "int sp = 0;")
   (emit "env* environment = NULL;")


   (emit "char* gc_pool;")
   (emit "int gc_ptr = 0;")
   (emit "int gc_pool_size;")
   (emit "int num_allocs = 0;")
   (emit "int num_bytes_allocd = 0;")
   
   (emit "void* gc_alloc(int size_in_bytes) {")
   (emit "int res = gc_ptr;")
   (emit "gc_ptr+=size_in_bytes;")
   (emit "num_bytes_allocd+=size_in_bytes;")
   (emit "num_allocs++;")
   ;; no gc yet, just keep allocating memory until we run out ;)
   (emit "if (gc_ptr > gc_pool_size) {")
   (emit "void* res = realloc(gc_pool, gc_pool_size*2);")
   (emit "if(res) {")
   (emit "gc_pool = res;")
   (emit "} else {")
   (emit "printf(\"Out of memory, gc not implemented\\n\");")
   (emit "exit(0);")
   (emit "}")
   (emit "}")
   (emit "return &(gc_pool[res]);")
   (emit "}")
   
   ;; environment extension
   (emit "env* push(closure* obj, env* old_env) {")
   (emit "env* link = gc_alloc(sizeof(closure));")
   (emit "link->next = old_env;")
   (emit "link->dat = obj;")
   (emit "return link;")
   (emit "}")
   
   ;; environment lookup
   (emit "closure* env_ref(env* environment, int idx) {")
   (emit "env* tmp_env = environment;")
   (emit "if(tmp_env == NULL) { goto error; }")
   (emit "while(idx > 0 && tmp_env->next) {")
   (emit "tmp_env = tmp_env->next;")
   (emit "idx--;")
   (emit "}")

   (emit "if (tmp_env == NULL || idx > 0) { goto error; }")

   (emit "return tmp_env->dat;")

   (emit "error:")
   (emit "printf(\"Error retrieving environment value: idx %i\\n\", idx);")
   (emit  "exit(0);")
   
   (emit "}")
   
   (emit "closure* make_closure(lambda_func func, char* str, env* environment) {")
   (emit "closure *clos = gc_alloc(sizeof(closure));")
   (emit "clos->func = func;")
   (emit "clos->str = str;")
   (emit "clos->environment = environment;")
   (emit "return clos;")
   (emit "}")))



;; wrapper func
;; emits a main function
(defun lambda->c (expression)
  (let ((*lambda-map* (make-hash-table :test 'eq)))
    
    (declare (special *lambda-map*))

    (multiple-value-bind (decl value)
        (compile-lambda expression nil)

      (cat-new
       (prelude)       
       (apply #'cat-new
              (loop for v being the hash-value of *lambda-map* collecting
                   (emit v)))

       
       
       (emit "int main(int argc, char** argv) {")
       
       (emit "if (argc < 2) { gc_pool_size = 128; }")
       (emit "else { gc_pool_size = strtoul(argv[1], NULL, 10); }")
       ;; allocate memory
       (emit "gc_pool = malloc(sizeof(char*) * gc_pool_size);")
       
       ;; calculate result
       decl
       
       
       (emit "printf(\"result: %s\\n\", (~a->func)(environment)->str);" value)

       ;; free memory and output allocation statistics
       (emit "free(gc_pool);")
       (emit "printf(\"Number of bytes allocated: %i\\n\", num_bytes_allocd);")
       (emit "printf(\"Number of objects allocated: %i\\n\", num_allocs);")
       (emit "return 0;")
       (emit "}")))))


(defun emit (string &rest args)
  (apply #'format nil string args))


;; concatenate strings with newlines in between
(defun cat-new (&rest strings)
  (apply
   #'concatenate 'string
   (reduce (lambda (x y) (cons x (cons (format nil "~%") y)))
           strings
           :from-end :left
           :initial-value nil)))


;; compile a lambda expression into a closure
(defun compile-closure (expr env)
  (destructuring-bind (lambda arg body) expr
                 (let ((clos-name (gensym "closure"))
                       (func-name (gensym "lambda"))
                       (returnp (symbolp body)))
                   (let ((func-decl
                          
                          (cat-new
                           (emit "closure* ~a(env* environment) {" func-name)
                           
                           (multiple-value-bind (decl value)
                               (compile-lambda body (cons arg env))
                             (cat-new
                              decl                              
                              (emit "return ~a;" value)))
                               
                               (emit "}")))
                         (clos-decl
                          (emit "closure* ~a = make_closure(&~a, MULTI_LINE_STRING(~a), environment);~%"
                                clos-name func-name expr))
                         (clos-value (emit "~a" clos-name)))
                     
                     (setf (gethash func-name *lambda-map*) func-decl)
                     (values
                      clos-decl
                      clos-value)))))


(defun compile-print (expr env)
  (let ((null-closure (emit "make_closure(NULL, NULL, NULL)")))
    (values
     (if (stringp expr)
         (emit "printf(\"%s\\n\", ~s);" expr)
         (multiple-value-bind (decl value) (compile-lambda expr env)
           (cat-new
            decl
            (emit "printf(\"%s\\n\", (~a)->str);" value))))
     ;; null closure, because all values on the C side are closures
     null-closure
     
     )))


;; returns two values: (C declaration, C value) 
(defun compile-lambda (expr &optional env)
  (etypecase expr
    (symbol (let ((pos (position expr env)))

              ;; symbol reference: only a value, no declaration needed
              (values nil
                      (if pos
                          (emit "(env_ref(environment, ~a))" pos)
                          (if (null expr)
                              "NULL"
                              (error "Unbound symbol ~a." expr))))))
    (list (case (car expr)

            (lambda  (compile-closure expr env))
            
            (print (compile-print (cadr expr) env))
            
            (otherwise ;; application
             (destructuring-bind (operator operand) expr

               (multiple-value-bind (operand-decl operand-value)
                   (compile-lambda operand env)
                 (multiple-value-bind (operator-decl operator-value)
                     (compile-lambda operator env)

                   (values
                    
                    ;; declaration
                    (cat-new
                     operand-decl
                     operator-decl)

                    ;; value
                    (emit "~a->func(push(~a, ~a->environment))" operator-value operand-value operator-value))))))))))







;; doesn't work
(defun cps-transform (expr)
  (labels ((recur (expr)
             (etypecase expr
               (symbol `(lambda k (k ,expr)))
               (string `(lambda k (k ,expr)))
               (list
                (case (car expr)

                  (call/cc
                   `(,(recur (cadr expr)) k))

                  (lambda (destructuring-bind (lambda arg body) expr
                       `(lambda k
                          (lambda ,arg
                            (k ,(if (symbolp body) body body))))))
                  (otherwise
                   (destructuring-bind (operator operand) expr
                     `((,(recur operator)
                         (lambda val (k val)))
                       ,(recur operand)))))))))
    `((lambda k ,(recur expr))
      (lambda x x))))