diff --git a/Makefile b/Makefile index 941665dc..77d2ad67 100644 --- a/Makefile +++ b/Makefile @@ -145,7 +145,6 @@ uninstall: $(RMDIR) $(DESTDIR)$(DATADIR) trans: - sudo cp scheme/cyclone/transforms.scm /usr/local/share/cyclone/scheme/cyclone/ cyclone scheme/cyclone/transforms.sld sudo cp scheme/cyclone/transforms.* /usr/local/share/cyclone/scheme/cyclone/ cyclone cyclone.scm diff --git a/scheme/cyclone/cgen.scm b/scheme/cyclone/cgen.scm index f2789a19..7fd1ea8c 100644 --- a/scheme/cyclone/cgen.scm +++ b/scheme/cyclone/cgen.scm @@ -1,1329 +1 @@ -;; -;; Cyclone Scheme -;; Copyright (c) 2014, Justin Ethier -;; All rights reserved. -;; -;; This module compiles scheme code to a Cheney-on-the-MTA C runtime. -;; - -(define (emit line) - (display line) - (newline)) - -(define (emit* . strs) - (for-each emits strs) - (newline)) - -(define (emits str) - (display str)) - -(define (emits* . strs) - (for-each emits strs)) - -(define (emit-newline) - (newline)) - -(define (string-join lst delim) - (cond - ((null? lst) - "") - ((= (length lst) 1) - (car lst)) - (else - (string-append - (car lst) - delim - (string-join (cdr lst) delim))))) - -;; Escape chars in a C-string, so it can be safely written to a C file -(define (cstr:escape-chars str) - (letrec ((next (lambda (head tail) - (cond - ((null? head) (list->string (reverse tail))) - ((equal? (car head) #\") - (next (cdr head) (cons #\" (cons #\\ tail)))) - ((equal? (car head) #\\) - (next (cdr head) (cons #\\ (cons #\\ tail)))) - ((equal? (car head) #\newline) - (next (cdr head) - (cons #\n (cons #\\ tail)))) - (else - (next (cdr head) (cons (car head) tail))))))) - (next (string->list str) '()))) - -(define *c-main-function* -"main(int argc,char **argv) -{long stack_size = long_arg(argc,argv,\"-s\",STACK_SIZE); - long heap_size = long_arg(argc,argv,\"-h\",HEAP_SIZE); - global_stack_size = stack_size; - global_heap_size = heap_size; - _cyc_argc = argc; - _cyc_argv = argv; - main_main(stack_size,heap_size,(char *) &stack_size); - return 0;}") - -;;; Auto-generation of C macros -(define *c-call-max-args* 128) -(define *c-call-arity* (make-vector (+ 1 *c-call-max-args*) #f)) - -(define (set-c-call-arity! arity) - (cond - ((not (number? arity)) - (error `(Non-numeric number of arguments received ,arity))) - ((> arity *c-call-max-args*) - (error "Only support up to 128 arguments. Received: " arity)) - (else - (vector-set! *c-call-arity* arity #t)))) - -(define (emit-c-arity-macros arity) - (when (<= arity *c-call-max-args*) - (cond - ((or (= arity 1) (= arity 2) - (vector-ref *c-call-arity* arity)) - (emit (c-macro-funcall arity)) - (emit (c-macro-return-funcall arity)) - (emit (c-macro-return-check arity)))) - (emit-c-arity-macros (+ arity 1)))) - -(define (c-macro-return-funcall num-args) - (let ((args (c-macro-n-prefix num-args ",a")) - (n (number->string num-args)) - (arry-assign (c-macro-array-assign num-args "buf" "a"))) - (string-append - "/* Return to continuation after checking for stack overflow. */\n" - "#define return_funcall" n "(cfn" args ") \\\n" - "{char stack; \\\n" - " if (check_overflow(&stack,stack_limit1)) { \\\n" - " object buf[" n "]; " arry-assign "\\\n" - " GC(cfn,buf," n "); return; \\\n" - " } else {funcall" n "((closure) (cfn)" args "); return;}}\n"))) - -(define (c-macro-return-check num-args) - (let ((args (c-macro-n-prefix num-args ",a")) - (n (number->string num-args)) - (arry-assign (c-macro-array-assign num-args "buf" "a"))) - (string-append - "/* Evaluate an expression after checking for stack overflow. */\n" - "#define return_check" n "(_fn" args ") { \\\n" - " char stack; \\\n" - " if (check_overflow(&stack,stack_limit1)) { \\\n" - " object buf[" n "]; " arry-assign " \\\n" - " mclosure0(c1, _fn); \\\n" - " GC(&c1, buf, " n "); return; \\\n" - " } else { (_fn)(" n ",(closure)_fn" args "); }}\n"))) - -(define (c-macro-funcall num-args) - (let ((args (c-macro-n-prefix num-args ",a")) - (n (number->string num-args)) - (n-1 (number->string (if (> num-args 0) (- num-args 1) 0))) - (wrap (lambda (s) (if (> num-args 0) s "")))) - (string-append - "#define funcall" n "(cfn" args ") " - (wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(" n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }")) - (wrap " else { ") - "((cfn)->fn)(" n ",cfn" args ")" - (wrap ";}") - ))) - -(define (c-macro-n-prefix n prefix) - (if (> n 0) - (string-append - (c-macro-n-prefix (- n 1) prefix) - (string-append prefix (number->string n))) - "")) - -(define (c-macro-array-assign n prefix assign) - (if (> n 0) - (string-append - (c-macro-array-assign (- n 1) prefix assign) - prefix "[" (number->string (- n 1)) "] = " - assign (number->string n) ";") - "")) - -;;; Stack trace (call history) helpers - -;; Add function to trace, if not already set -(define (st:add-function! trace fnc) - (if (null? (cdr trace)) - (cons (car trace) fnc) - trace)) - -(define (st:->code trace) - (if (or (not (pair? trace)) - (null? (cdr trace))) - "" - (string-append - "Cyc_st_add(\"" - (car trace) - ":" - ;; TODO: escape backslashes - (symbol->string (cdr trace)) - "\");\n" - ))) - -;; END st helpers - -;;; Compilation routines. - -;; Return generated code that also requests allocation of C variables on stack -(define (c-code/vars str cvars) - (list str - cvars)) - -;; Return generated code with no C variables allocated on the stack -(define (c-code str) (c-code/vars str (list))) - -;; Append arg count to a C code pair -(define (c:tuple/args cp num-args) - (append cp (list num-args))) - -;; Functions to work with data structures that contain C code: -;; -;; body - The actual body of C code -;; allocs - Allocations made by C code, eg "int c" -;; num-args - Number of function arguments combined in the tuple (optional) -;; -(define (c:body c-pair) (car c-pair)) -(define (c:allocs c-pair) (cadr c-pair)) -(define (c:num-args c-tuple) (caddr c-tuple)) - -(define (c:allocs->str c-allocs . prefix) - (apply - string-append - (map - (lambda (c) - (string-append - (if (null? prefix) - "" - (car prefix)) - c - "\n")) - c-allocs))) - -(define (c:allocs->str2 c-allocs prefix suffix) - (apply - string-append - (map - (lambda (c) - (string-append prefix c suffix)) - c-allocs))) - -(define (c:append cp1 cp2) - (c-code/vars - (string-append (c:body cp1) (c:body cp2)) - (append (c:allocs cp1) (c:allocs cp2)))) - -(define (c:append/prefix prefix cp1 cp2) - (c-code/vars - (string-append prefix (c:body cp1) (c:body cp2)) - (append (c:allocs cp1) (c:allocs cp2)))) - -(define (c:serialize cp prefix) - (string-append - (c:allocs->str (c:allocs cp) prefix) - prefix - (c:body cp))) - -;; c-compile-program : exp -> string -(define (c-compile-program exp src-file) - (let* ((preamble "") - (append-preamble (lambda (s) - (set! preamble (string-append preamble " " s "\n")))) - (body (c-compile-exp exp append-preamble "cont" (list src-file)))) - ;(write `(DEBUG ,body)) - (string-append - preamble - (c:serialize body " ") ;" ;\n" -; "int main (int argc, char* argv[]) {\n" -; " return 0;\n" -; " }\n" -))) - -;; c-compile-exp : exp (string -> void) -> string -;; -;; exp - expression to compiler -;; append-preamble - ?? -;; cont - name of the next continuation -;; this is experimental and probably needs refinement -;; trace - trace information. presently a pair containing: -;; * source file -;; * function name (or nil if none) -(define (c-compile-exp exp append-preamble cont trace) - (cond - ; Core forms: - ((const? exp) (c-compile-const exp)) - ((prim? exp) - ;; TODO: this needs to be more refined, probably w/a lookup table - (c-code (string-append "primitive_" (mangle exp)))) - ((ref? exp) (c-compile-ref exp)) - ((quote? exp) (c-compile-quote exp)) - ((if? exp) (c-compile-if exp append-preamble cont trace)) - - ; IR (2): - ((tagged-list? '%closure exp) - (c-compile-closure exp append-preamble cont trace)) - ; Global definition - ((define? exp) - (c-compile-global exp append-preamble cont trace)) - ; Special case - global function w/out a closure. Create an empty closure - ((tagged-list? 'lambda exp) - (c-compile-exp - `(%closure ,exp) - append-preamble cont trace)) - - ; Application: - ((app? exp) (c-compile-app exp append-preamble cont trace)) - (else (error "unknown exp in c-compile-exp: " exp)))) - -(define (c-compile-quote qexp) - (let ((exp (cadr qexp))) - (c-compile-scalars exp))) - -(define (c-compile-scalars args) - (letrec ( - (num-args 0) - (create-cons - (lambda (cvar a b) - (c-code/vars - (string-append "make_cons(" cvar "," (c:body a) "," (c:body b) ");") - (append (c:allocs a) (c:allocs b)))) - ) - (_c-compile-scalars - (lambda (args) - (cond - ((null? args) - (c-code "nil")) - ((not (pair? args)) - (c-compile-const args)) - (else - (let* ((cvar-name (mangle (gensym 'c))) - (cell (create-cons - cvar-name - (c-compile-const (car args)) - (_c-compile-scalars (cdr args))))) - (set! num-args (+ 1 num-args)) - (c-code/vars - (string-append "&" cvar-name) - (append - (c:allocs cell) - (list (c:body cell)))))))))) - (c:tuple/args - (_c-compile-scalars args) - num-args))) - -(define (c-compile-vector exp) - (letrec ((cvar-name (mangle (gensym 'vec))) - (len (vector-length exp)) - ;; Generate code for each member of the vector - (loop - (lambda (i code) - (if (= i len) - code - (let ((idx-code (c-compile-const (vector-ref exp i)))) - (loop - (+ i 1) - (c-code/vars - ;; The vector's C variable - (c:body code) - ;; Allocations - (append - (c:allocs code) ;; Vector alloc - (c:allocs idx-code) ;; Member alloc at index i - (list ;; Assign this member to vector - (string-append - cvar-name ".elts[" (number->string i) "] = " - (c:body idx-code) - ";"))))))))) - ) - (cond - ((zero? len) - (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name - (list ; Allocate empty vector - (string-append - "make_empty_vector(" cvar-name ");")))) - (else - (let ((code - (c-code/vars - (string-append "&" cvar-name) ; Code body is just var name - (list ; Allocate the vector - (string-append - "make_empty_vector(" cvar-name ");" - cvar-name ".num_elt = " (number->string len) ";" - cvar-name ".elts = (object *)alloca(sizeof(object) * " - (number->string len) ");"))))) - (loop 0 code)))))) - -;; c-compile-const : const-exp -> c-pair -;; -;; Typically this function is used to compile constant values such as -;; a single number, boolean, etc. However, it can be passed a quoted -;; item such as a list, to compile as a literal. -(define (c-compile-const exp) - (cond - ((null? exp) - (c-code "nil")) - ((pair? exp) - (c-compile-scalars exp)) - ((vector? exp) - (c-compile-vector exp)) - ((integer? exp) - (let ((cvar-name (mangle (gensym 'c)))) - (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name - (list ; Allocate integer on the C stack - (string-append - "make_int(" cvar-name ", " (number->string exp) ");"))))) - ((real? exp) - (let ((cvar-name (mangle (gensym 'c)))) - (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name - (list ; Allocate on the C stack - (string-append - "make_double(" cvar-name ", " (number->string exp) ");"))))) - ((boolean? exp) - (c-code (string-append - (if exp "boolean_t" "boolean_f")))) - ((char? exp) - (c-code (string-append "obj_char2obj(" - (number->string (char->integer exp)) ")"))) - ((string? exp) - (let ((cvar-name (mangle (gensym 'c)))) - (c-code/vars - (string-append "&" cvar-name) ; Code is just the variable name - (list ; Allocate integer on the C stack - (string-append - "make_string(" cvar-name ", " (->cstr exp) ");"))))) -;TODO: not good enough, need to store new symbols in a table so they can -;be inserted into the C program - ((symbol? exp) - (allocate-symbol exp) - (c-code (string-append "quote_" (mangle exp)))) - (else - (error "unknown constant: " exp)))) - -;; Convert a "scheme" string to a corresponding representation in C. -;; Keep in mind scheme strings can span lines, contain chars that -;; might not be allowed in C, etc. -(define (->cstr str) - (string-append "\"" (cstr:escape-chars str) "\"")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Primitives - -(define (prim->c-func p) - (cond - ((eq? p 'Cyc-global-vars) "Cyc_get_global_variables") - ((eq? p 'Cyc-get-cvar) "Cyc_get_cvar") - ((eq? p 'Cyc-set-cvar!) "Cyc_set_cvar") - ((eq? p 'Cyc-cvar?) "Cyc_is_cvar") - ((eq? p 'Cyc-has-cycle?) "Cyc_has_cycle") - ((eq? p 'Cyc-stdout) "Cyc_stdout") - ((eq? p 'Cyc-stdin) "Cyc_stdin") - ((eq? p 'Cyc-stderr) "Cyc_stderr") - ((eq? p '+) "Cyc_sum") - ((eq? p '-) "Cyc_sub") - ((eq? p '*) "Cyc_mul") - ((eq? p '/) "Cyc_div") - ((eq? p '=) "__num_eq") - ((eq? p '>) "__num_gt") - ((eq? p '<) "__num_lt") - ((eq? p '>=) "__num_gte") - ((eq? p '<=) "__num_lte") - ((eq? p 'apply) "apply") - ((eq? p '%halt) "__halt") - ((eq? p 'exit) "__halt") - ((eq? p 'Cyc-default-exception-handler) "Cyc_default_exception_handler") - ((eq? p 'Cyc-current-exception-handler) "Cyc_current_exception_handler") - ((eq? p 'open-input-file) "Cyc_io_open_input_file") - ((eq? p 'open-output-file) "Cyc_io_open_output_file") - ((eq? p 'close-port) "Cyc_io_close_port") - ((eq? p 'close-input-port) "Cyc_io_close_input_port") - ((eq? p 'close-output-port) "Cyc_io_close_output_port") - ((eq? p 'Cyc-flush-output-port) "Cyc_io_flush_output_port") - ((eq? p 'file-exists?) "Cyc_io_file_exists") - ((eq? p 'delete-file) "Cyc_io_delete_file") - ((eq? p 'read-char) "Cyc_io_read_char") - ((eq? p 'peek-char) "Cyc_io_peek_char") - ((eq? p 'Cyc-read-line) "Cyc_io_read_line") - ((eq? p 'Cyc-display) "Cyc_display_va") - ((eq? p 'Cyc-write) "Cyc_write_va") - ((eq? p 'Cyc-write-char) "Cyc_write_char") - ((eq? p 'car) "car") - ((eq? p 'cdr) "cdr") - ((eq? p 'caar) "caar") - ((eq? p 'cadr) "cadr") - ((eq? p 'cdar) "cdar") - ((eq? p 'cddr) "cddr") - ((eq? p 'caaar) "caaar") - ((eq? p 'caadr) "caadr") - ((eq? p 'cadar) "cadar") - ((eq? p 'caddr) "caddr") - ((eq? p 'cdaar) "cdaar") - ((eq? p 'cdadr) "cdadr") - ((eq? p 'cddar) "cddar") - ((eq? p 'cdddr) "cdddr") - ((eq? p 'caaaar) "caaaar") - ((eq? p 'caaadr) "caaadr") - ((eq? p 'caadar) "caadar") - ((eq? p 'caaddr) "caaddr") - ((eq? p 'cadaar) "cadaar") - ((eq? p 'cadadr) "cadadr") - ((eq? p 'caddar) "caddar") - ((eq? p 'cadddr) "cadddr") - ((eq? p 'cdaaar) "cdaaar") - ((eq? p 'cdaadr) "cdaadr") - ((eq? p 'cdadar) "cdadar") - ((eq? p 'cdaddr) "cdaddr") - ((eq? p 'cddaar) "cddaar") - ((eq? p 'cddadr) "cddadr") - ((eq? p 'cdddar) "cdddar") - ((eq? p 'cddddr) "cddddr") - ((eq? p 'char->integer) "Cyc_char2integer") - ((eq? p 'integer->char) "Cyc_integer2char") - ((eq? p 'string->number)"Cyc_string2number") - ((eq? p 'list->string) "Cyc_list2string") - ((eq? p 'make-vector) "Cyc_make_vector") - ((eq? p 'list->vector) "Cyc_list2vector") - ((eq? p 'vector-length) "Cyc_vector_length") - ((eq? p 'vector-ref) "Cyc_vector_ref") - ((eq? p 'vector-set!) "Cyc_vector_set") - ((eq? p 'string-append) "Cyc_string_append") - ((eq? p 'string-cmp) "Cyc_string_cmp") - ((eq? p 'string->symbol) "Cyc_string2symbol") - ((eq? p 'symbol->string) "Cyc_symbol2string") - ((eq? p 'number->string) "Cyc_number2string") - ((eq? p 'string-length) "Cyc_string_length") - ((eq? p 'string-ref) "Cyc_string_ref") - ((eq? p 'string-set!) "Cyc_string_set") - ((eq? p 'substring) "Cyc_substring") - ((eq? p 'Cyc-installation-dir) "Cyc_installation_dir") - ((eq? p 'command-line-arguments) "Cyc_command_line_arguments") - ((eq? p 'system) "Cyc_system") - ((eq? p 'assq) "assq") - ((eq? p 'assv) "assq") - ((eq? p 'assoc) "assoc") - ((eq? p 'memq) "memqp") - ((eq? p 'memv) "memqp") - ((eq? p 'member) "memberp") - ((eq? p 'length) "Cyc_length") - ((eq? p 'set-car!) "Cyc_set_car") - ((eq? p 'set-cdr!) "Cyc_set_cdr") - ((eq? p 'eq?) "Cyc_eq") - ((eq? p 'eqv?) "Cyc_eq") - ((eq? p 'equal?) "equalp") - ((eq? p 'boolean?) "Cyc_is_boolean") - ((eq? p 'char?) "Cyc_is_char") - ((eq? p 'null?) "Cyc_is_null") - ((eq? p 'number?) "Cyc_is_number") - ((eq? p 'real?) "Cyc_is_real") - ((eq? p 'integer?) "Cyc_is_integer") - ((eq? p 'pair?) "Cyc_is_cons") - ((eq? p 'procedure?) "Cyc_is_procedure") - ((eq? p 'port?) "Cyc_is_port") - ((eq? p 'vector?) "Cyc_is_vector") - ((eq? p 'string?) "Cyc_is_string") - ((eq? p 'eof-object?) "Cyc_is_eof_object") - ((eq? p 'symbol?) "Cyc_is_symbol") - ((eq? p 'cons) "make_cons") - ((eq? p 'cell) "make_cell") - ((eq? p 'cell-get) "cell_get") - ((eq? p 'set-cell!) "Cyc_set_car") - ((eq? p 'set-global!) "global_set") - (else - (error "unhandled primitive: " p)))) - -;; Determine if primitive assigns (allocates) a C variable -;; EG: int v = prim(); -(define (prim/c-var-assign p) - (cond - ((eq? p 'Cyc-stdout) "port_type") - ((eq? p 'Cyc-stdin) "port_type") - ((eq? p 'Cyc-stderr) "port_type") - ((eq? p 'open-input-file) "port_type") - ((eq? p 'open-output-file) "port_type") - ((eq? p 'length) "integer_type") - ((eq? p 'vector-length) "integer_type") - ((eq? p 'char->integer) "integer_type") - ((eq? p 'Cyc-installation-dir) "string_type") - ((eq? p 'system) "integer_type") - ((eq? p '+) "common_type") - ((eq? p '-) "common_type") - ((eq? p '*) "common_type") - ((eq? p '/) "common_type") - ((eq? p 'string->number) "common_type") - ((eq? p 'list->string) "string_type") - ((eq? p 'string-cmp) "integer_type") - ((eq? p 'string-append) "string_type") - ((eq? p 'symbol->string) "string_type") - ((eq? p 'number->string) "string_type") - ((eq? p 'string-length) "integer_type") - ((eq? p 'substring) "string_type") - ((eq? p 'apply) "object") - ((eq? p 'Cyc-read-line) "object") - ((eq? p 'command-line-arguments) "object") - ((eq? p 'make-vector) "object") - ((eq? p 'list->vector) "object") - (else #f))) - -;; Determine if primitive creates a C variable -(define (prim/cvar? exp) - (and (prim? exp) - (member exp '( - Cyc-stdout - Cyc-stdin - Cyc-stderr - open-input-file - open-output-file - char->integer - system - Cyc-installation-dir - string->number - string-append string-cmp list->string - make-vector list->vector - symbol->string number->string - string-length substring - + - * / apply - command-line-arguments - Cyc-read-line - cons length vector-length cell)))) - -;; Pass continuation as the function's first parameter? -(define (prim:cont? exp) - (and (prim? exp) - (member exp '(Cyc-read-line apply command-line-arguments make-vector list->vector)))) -;; TODO: this is a hack, right answer is to include information about -;; how many args each primitive is supposed to take -(define (prim:cont-has-args? exp) - (and (prim? exp) - (member exp '(Cyc-read-line apply make-vector list->vector)))) - -;; Pass an integer arg count as the function's first parameter? -(define (prim:arg-count? exp) - (and (prim? exp) - (member exp '(error Cyc-write Cyc-display string-append + - * /)))) - -;; Does primitive allocate an object? -;; TODO: these are the functions that are defined via macros. This method -;; is obsolete and should be replaced by prim:cont? functions over time. -(define (prim:allocates-object? exp) - (and (prim? exp) - (member exp '()))) - -;; c-compile-prim : prim-exp -> string -> string -(define (c-compile-prim p cont) - (let* ((c-func (prim->c-func p)) - ;; Following closure defs are only used for prim:cont? to - ;; create a new closure for the continuation, if needed. - ;; - ;; Each prim:cont? function is different in that it takes a continuation so that it can - ;; allocate arbitrary data as needed using alloca, and then call into - ;; the cont so allocations can remain on stack until GC. - (closure-sym (mangle (gensym 'c))) - (closure-def - (cond - ((and (prim:cont? p) - (> (string-length cont) (string-length "__lambda_")) - (equal? (substring cont 0 9) "__lambda_")) - (string-append - "mclosure0(" closure-sym - "," cont "); ")) - (else #f))) - ;; END apply defs - (c-var-assign - (lambda (type) - (let ((cv-name (mangle (gensym 'c)))) - (c-code/vars - (string-append (if (prim:cont? p) "" "&") cv-name) - (list - (string-append - ;; Define closure if necessary (apply only) - (cond - (closure-def closure-def) - (else "")) - - ;; Emit C variable - type " " cv-name " = " c-func "(" - - ;; Emit closure as first arg, if necessary (apply only) - (cond - (closure-def - (string-append "&" closure-sym - (if (prim:cont-has-args? p) ", " ""))) - ((prim:cont? p) - (string-append cont - (if (prim:cont-has-args? p) ", " ""))) - (else ""))))))))) - (cond - ((prim/c-var-assign p) - (c-var-assign (prim/c-var-assign p))) - ((prim/cvar? p) - ;; - ;; TODO: look at functions that would actually fall into this - ;; branch, I think they are just the macro's like list->vector??? - ;; may be able to remove this using prim:cont? and simplify - ;; the logic - ;; - (let ((cv-name (mangle (gensym 'c)))) - (c-code/vars - (if (prim:allocates-object? p) - cv-name ;; Already a pointer - (string-append "&" cv-name)) ;; Point to data - (list - (string-append c-func "(" cv-name))))) - (else - (c-code (string-append c-func "(")))))) - -;; END primitives -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; c-compile-ref : ref-exp -> string -(define (c-compile-ref exp) - (c-code - (if (member exp *global-syms*) - (mangle-global exp) - (mangle exp)))) - -; c-compile-args : list[exp] (string -> void) -> string -(define (c-compile-args args append-preamble prefix cont trace) - (letrec ((num-args 0) - (_c-compile-args - (lambda (args append-preamble prefix cont) - (if (not (pair? args)) - (c-code "") - (begin - ;(trace:debug `(c-compile-args ,(car args))) - (set! num-args (+ 1 num-args)) - (c:append/prefix - prefix - (c-compile-exp (car args) - append-preamble cont trace) - (_c-compile-args (cdr args) - append-preamble ", " cont))))))) - (c:tuple/args - (_c-compile-args args - append-preamble prefix cont) - num-args))) - -;; c-compile-app : app-exp (string -> void) -> string -(define (c-compile-app exp append-preamble cont trace) - ;(trace:debug `(c-compile-app: ,exp)) - (let (($tmp (mangle (gensym 'tmp)))) - (let* ((args (app->args exp)) - (fun (app->fun exp))) - (cond - ((lambda? fun) - (let* ((lid (allocate-lambda (c-compile-lambda fun trace))) ;; TODO: pass in free vars? may be needed to track closures - ;; properly, wait until this comes up in an example - (this-cont (string-append "__lambda_" (number->string lid))) - (cgen - (c-compile-args - args - append-preamble - "" - this-cont - trace)) - (num-cargs (c:num-args cgen))) - (set-c-call-arity! num-cargs) - (c-code - (string-append - (c:allocs->str (c:allocs cgen)) - "return_check" (number->string num-cargs) - "(" this-cont - (if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " " - (c:body cgen) ");")))) - - ((prim? fun) - (let* ((c-fun - (c-compile-prim fun cont)) - (c-args - (c-compile-args args append-preamble "" "" trace)) - (num-args (length args)) - (num-args-str - (string-append - (number->string num-args) - (if (> num-args 0) "," ""))) - (c-args* (if (prim:arg-count? fun) - (c:append (c-code num-args-str) c-args) - c-args))) - (if (prim/cvar? fun) - ;; Args need to go with alloc function - (c-code/vars - (c:body c-fun) - (append - (c:allocs c-args*) ;; fun alloc depends upon arg allocs - (list (string-append - (car (c:allocs c-fun)) - (if (prim/c-var-assign fun) "" ",") ; Allocating C var - (c:body c-args*) ");")))) - ;; Args stay with body - (c:append - (c:append c-fun c-args*) - (c-code ")"))))) - - ((equal? '%closure-ref fun) - (c-code (apply string-append (list - "(" - ;; TODO: probably not the ideal solution, but works for now - "(closureN)" - (mangle (car args)) - ")->elts[" - (number->string (- (cadr args) 1))"]")))) - - ;; TODO: may not be good enough, closure app could be from an elt - ((tagged-list? '%closure-ref fun) - (let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont trace)) - (this-cont (c:body cfun)) - (cargs (c-compile-args (cdr args) append-preamble " " this-cont trace))) - (set-c-call-arity! (c:num-args cargs)) - (c-code - (string-append - (c:allocs->str (c:allocs cfun) "\n") - (c:allocs->str (c:allocs cargs) "\n") - "return_funcall" (number->string (c:num-args cargs)) - "(" - this-cont - (if (> (c:num-args cargs) 0) "," "") - (c:body cargs) - ");")))) - - ((tagged-list? '%closure fun) - (let* ((cfun (c-compile-closure - fun append-preamble cont trace)) - (this-cont (string-append "(closure)" (c:body cfun))) - (cargs (c-compile-args - args append-preamble " " this-cont trace)) - (num-cargs (c:num-args cargs))) - (set-c-call-arity! num-cargs) - (c-code - (string-append - (c:allocs->str (c:allocs cfun) "\n") - (c:allocs->str (c:allocs cargs) "\n") - "return_funcall" (number->string num-cargs) - "(" - this-cont - (if (> num-cargs 0) "," "") - (c:body cargs) - ");")))) - - (else - (error `(Unsupported function application ,exp))))))) - -; c-compile-if : if-exp -> string -(define (c-compile-if exp append-preamble cont trace) - (let* ((compile (lambda (exp) - (c-compile-exp exp append-preamble cont trace))) - (test (compile (if->condition exp))) - (then (compile (if->then exp))) - (els (compile (if->else exp)))) - (c-code (string-append - (c:allocs->str (c:allocs test) " ") - "if( !eq(boolean_f, " - (c:body test) - ") ){ \n" - (c:serialize then " ") - "\n} else { \n" - (c:serialize els " ") - "}\n")))) - -;; Global compilation -(define *globals* '()) -(define *global-syms* '()) -(define (global-lambda? global) (cadr global)) -(define (global-not-lambda? global) (not (cadr global))) -(define (add-global var-sym lambda? code) - ;(write `(add-global ,var-sym ,code)) - (set! *globals* (cons (list var-sym lambda? code) *globals*))) -(define (c-compile-global exp append-preamble cont trace) - (let ((var (define->var exp)) - (body (if (equal? 4 (length exp)) ; Simple var assignment contains superfluous %closure-ref - (cadddr exp) - (car (define->exp exp))))) - (add-global - var - (lambda? body) - (c-compile-exp - body append-preamble cont - (st:add-function! trace var))) - (c-code/vars "" (list "")))) - -;; Symbol compilation - -(define *symbols* '()) - -(define (allocate-symbol sym) - (if (not (member sym *symbols*)) - ;(not (Cyc-reserved-symbol? sym))) - (set! *symbols* (cons sym *symbols*)))) - -;; Lambda compilation. - -;; Lambdas get compiled into procedures that, -;; once given a C name, produce a C function -;; definition with that name. - -;; These procedures are stored up an eventually -;; emitted. - -; type lambda-id = natural - -; num-lambdas : natural -(define num-lambdas 0) - -; lambdas : alist[lambda-id,string -> string] -(define lambdas '()) - -; allocate-lambda : (string -> string) -> lambda-id -(define (allocate-lambda lam) - (let ((id num-lambdas)) - (set! num-lambdas (+ 1 num-lambdas)) - (set! lambdas (cons (list id lam) lambdas)) - id)) - -; get-lambda : lambda-id -> (symbol -> string) -(define (get-lambda id) - (cdr (assv id lambdas))) - -(define (lambda->env exp) - (let ((formals (lambda-formals->list exp))) - (if (pair? formals) - (car formals) - 'unused))) - -; (tmp-ident (if (> (length (lambda-formals->list exp)) 0) -; (mangle (if (pair? (lambda->formals exp)) -; (car (lambda->formals exp)) -; (lambda->formals exp))) -; "")) -; (has-closure? -; (and -; (> (string-length tmp-ident) 3) -; (equal? "self" (substring tmp-ident 0 4)))) - -;; Compute the minimum number of arguments a function expects. -;; Note this must be the count before additional closure/CPS arguments -;; are added, so we need to detect those and not include them. -(define (compute-num-args lam) - (let ((count (lambda-num-args lam))) ;; Current arg count, may be too high - (cond - ((< count 0) -1) ;; Unlimited - (else - (let ((formals (lambda-formals->list lam))) - (- count - (if (fl/closure? formals) 1 0) - (if (fl/cont? formals) 1 0))))))) - -;; Formal list with a closure? -(define (fl/closure? lis) - (cond - ((null? lis) #f) - (else - (let ((arg (symbol->string (car lis)))) - (and - (> (string-length arg) 4) - (equal? "self$" (substring arg 0 5))))))) - -;; Formal list with a continuation (k)? -(define (fl/cont? lis) - (let ((check (lambda (lis) - (cond - ((null? lis) #f) - (else - (let ((arg (symbol->string (car lis)))) - (and - (> (string-length arg) 1) - (equal? "k$" (substring arg 0 2))))))))) - ;; Find the cont arg; if there is a closure it is always first - (if (fl/closure? lis) - (check (cdr lis)) - (check lis)))) - -;; c-compile-closure : closure-exp (string -> void) -> string -;; -;; This function compiles closures generated earlier in the -;; compilation process. Each closure is of the form: -;; -;; (%closure lambda arg ...) -;; -;; Where: -;; - `%closure` is the identifying tag -;; - `lambda` is the function to execute -;; - Each `arg` is a free variable that must be stored within -;; the closure. The closure conversion phase tags each access -;; to one with the corresponding index so `lambda` can use them. -;; -(define (c-compile-closure exp append-preamble cont trace) - (let* ((lam (closure->lam exp)) - (free-vars - (map - (lambda (free-var) - (if (tagged-list? '%closure-ref free-var) - (let ((var (cadr free-var)) - (idx (number->string (- (caddr free-var) 1)))) - (string-append - "((closureN)" (mangle var) ")->elts[" idx "]")) - (mangle free-var))) - (closure->fv exp))) ; Note these are not necessarily symbols, but in cc form - (cv-name (mangle (gensym 'c))) - (lid (allocate-lambda (c-compile-lambda lam trace))) - (create-nclosure (lambda () - (string-append - "closureN_type " cv-name ";\n" - cv-name ".tag = closureN_tag;\n " - cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n" - cv-name ".num_args = " (number->string (compute-num-args lam)) ";\n" - cv-name ".num_elt = " (number->string (length free-vars)) ";\n" - cv-name ".elts = (object *)alloca(sizeof(object) * " - (number->string (length free-vars)) ");\n" - (let loop ((i 0) - (vars free-vars)) - (if (null? vars) - "" - (string-append - cv-name ".elts[" (number->string i) "] = " - (car vars) ";\n" - (loop (+ i 1) (cdr vars)))))))) - (create-mclosure (lambda () - (string-append - "mclosure" (number->string (length free-vars)) "(" cv-name ", " - ;; NOTE: - ;; Hopefully will not cause issues with varargs when casting to - ;; generic function type below. Works fine in gcc, not sure if - ;; this is portable to other compilers though - "(function_type)__lambda_" (number->string lid) - (if (> (length free-vars) 0) "," "") - (string-join free-vars ", ") - ");" - cv-name ".num_args = " (number->string (compute-num-args lam)) ";" - )))) - (c-code/vars - (string-append "&" cv-name) - (list - (if (> (length free-vars) 0) - (create-nclosure) - (create-mclosure)))))) - -; c-compile-formals : list[symbol] -> string -(define (c-compile-formals formals type) - (if (not (pair? formals)) - "" - (string-append - "object " - (mangle (car formals)) - (cond - ((pair? (cdr formals)) - (string-append ", " (c-compile-formals (cdr formals) type))) - ((not (equal? 'args:fixed type)) - (string-append ", object " (mangle (cdr formals)) "_raw, ...")) - (else - ""))))) - -; c-compile-lambda : lamda-exp (string -> void) -> (string -> string) -(define (c-compile-lambda exp trace) - (let* ((preamble "") - (append-preamble (lambda (s) - (set! preamble (string-append preamble " " s "\n"))))) - (let* ((formals (c-compile-formals - (lambda->formals exp) - (lambda-formals-type exp))) - (tmp-ident (if (> (length (lambda-formals->list exp)) 0) - (mangle (if (pair? (lambda->formals exp)) - (car (lambda->formals exp)) - (lambda->formals exp))) - "")) - (has-closure? - (and - (> (string-length tmp-ident) 3) - (equal? "self" (substring tmp-ident 0 4)))) - (formals* - (string-append - (if has-closure? - "" - (if (equal? "" formals) - "closure _" ;; TODO: seems wrong, will GC be too aggressive - "closure _,")) ;; due to missing refs, with ignored closure? - formals)) - (env-closure (lambda->env exp)) - (body (c-compile-exp - (car (lambda->exp exp)) ;; car ==> assume single expr in lambda body after CPS - append-preamble - (mangle env-closure) - trace))) - (cons - (lambda (name) - (string-append "static void " name - "(int argc, " - formals* - ") {\n" - preamble - (if (lambda-varargs? exp) - ;; Load varargs from C stack into Scheme list - (string-append - ; DEBUGGING: - ;"printf(\"%d %d\\n\", argc, " - ; (number->string (length (lambda-formals->list exp))) ");" - "load_varargs(" - (mangle (lambda-varargs-var exp)) - ", " - (mangle (lambda-varargs-var exp)) - "_raw, argc - " (number->string - (- (length (lambda-formals->list exp)) - 1 - (if has-closure? 1 0))) - ");\n"); - "") ; No varargs, skip - (c:serialize - (c:append - (c-code (st:->code trace)) - body) - " ") - "; \n" - "}\n")) - formals*)))) - -(define (mta:code-gen input-program - program? - lib-name - lib-exports - imported-globals - globals - required-libs - src-file) - (set! *global-syms* (append globals imported-globals)) - (let ((compiled-program-lst '()) - (compiled-program #f)) - ;; Compile program, using for-each to guarantee execution order, - ;; since c-compile-program has side-effects. - (for-each - (lambda (expr) - (set! compiled-program-lst - (cons (c-compile-program expr src-file) compiled-program-lst))) - input-program) - - ;; Get top-level string - (set! compiled-program - (apply string-append (reverse compiled-program-lst))) - - (emit-c-arity-macros 0) - (emit "#include \"cyclone/types.h\"") - - ;; Globals defined in this module - (for-each - (lambda (global) - (emits "object ") - (emits (mangle-global (car global))) - (emits " = nil;\n")) - *globals*) - ;; Globals defined by another module - (for-each - (lambda (global) - (emits "extern object ") - (emits (mangle-global global)) - (emits ";\n")) - imported-globals) - (emit "#include \"cyclone/runtime.h\"") - - (if program? - (emit "#include \"cyclone/runtime-main.h\"")) - - ;; Emit symbol definitions - (for-each - (lambda (sym) - (emit* "defsymbol(" (mangle sym) ");")) - *symbols*) - - ;; Emit lambdas: - ; Print the prototypes: - (for-each - (lambda (l) - (emit* - "static void __lambda_" - (number->string (car l)) "(int argc, " - (cdadr l) - ") ;")) - lambdas) - - (emit "") - - ; Print the definitions: - (for-each - (lambda (l) - (emit ((caadr l) (string-append "__lambda_" (number->string (car l)))))) - lambdas) - - ; Emit entry point - (cond - (program? - (emit "static void c_entry_pt_first_lambda();") - (for-each - (lambda (lib-name) - (emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(int argc, closure cont, object value);")) - required-libs) - (emit "static void c_entry_pt(argc, env,cont) int argc; closure env,cont; { ")) - (else - (emit* "void c_" (lib:name->string lib-name) "_entry_pt(argc, cont,value) int argc; closure cont; object value;{ ") - ; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");")) - )) - - ;; Initialize symbols - (for-each - (lambda (sym) - (emit* - " quote_" (mangle sym) " = find_or_add_symbol(\"" - (symbol->string sym) "\");")) - *symbols*) - - ;; Initialize global table - (for-each - (lambda (global) - (emits "\n add_global((object *) &") - (emits (mangle-global (car global))) - (emits ");")) - *globals*) - (emit "") - - ;; Initialize symbol table - (for-each - (lambda (sym) - (emit* " add_symbol(quote_" (mangle sym) ");")) - *symbols*) - - ;; Initialize globals - (let* ((prefix " ") - (emit-global - (lambda (global) - (emits (c:allocs->str2 (c:allocs (caddr global)) prefix " \n")) - (emits prefix) - (emits (mangle-global (car global))) - (emits " = ") - (emits (c:body (caddr global))) - (emit "; ")))) - (for-each emit-global (filter global-lambda? *globals*)) - (for-each emit-global (filter global-not-lambda? *globals*)) - (emit "")) - - ;; Initialize Cyc_global_variables - ;; TODO: only need to do this if 'eval' was also compiled - (let ((pairs '()) - (head-pair #f)) - (for-each - (lambda (g) - (let ((cvar-sym (mangle (gensym 'cvar))) - (pair-sym (mangle (gensym 'pair)))) - (emits* - " make_cvar(" cvar-sym - ", (object *)&" (mangle-global (car g)) ");") - (emits* - "make_cons(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g)) - "\"), &" cvar-sym ");\n") - (set! pairs (cons pair-sym pairs)) - )) - *globals*) - (let loop ((code '()) - (ps pairs) - (cs (map (lambda (_) (mangle (gensym 'c))) pairs))) - (cond - ((null? ps) - (for-each - (lambda (str) - (emits str)) - code)) - ((null? (cdr ps)) - (if (not head-pair) - (set! head-pair (car cs))) - (loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ",Cyc_global_variables);\n") code) - (cdr ps) - (cdr cs))) - (else - (if (not head-pair) - (set! head-pair (car cs))) - (loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code) - (cdr ps) - (cdr cs))))) - (if head-pair - (emit* - "Cyc_global_variables = &" head-pair ";"))) - - (cond - (program? - ;; Emit code to initialize each module (compiled Scheme library) - (let ((this-clo "c_done") - (prev-clo "c_done")) - (emit* - "mclosure1(" this-clo - ", c_entry_pt_first_lambda, &" prev-clo ");") - (for-each - (lambda (lib-name) - (set! prev-clo this-clo) - (set! this-clo (mangle (gensym "c"))) - (emit* - "mclosure1(" this-clo - ", c_" (lib:name->string lib-name) "_entry_pt" - ", &" prev-clo ");") - ) - (reverse required-libs)) ;; Init each lib's dependencies 1st - (emit* - ;; Start cont chain, but do not assume funcall1 macro was defined - "(" this-clo ".fn)(0, &" this-clo ", &" this-clo ");") - (emit "}") - (emit "static void c_entry_pt_first_lambda(int argc, closure cont, object value) {") - ; DEBUG (emit (string-append "printf(\"init first lambda\\n\");")) - (emit compiled-program))) - (else - ;; Do not use funcall1 macro as it might not have been defined - (emit "cont = ((closure1_type *)cont)->elt1;") - ;(emit "((cont)->fn)(1, cont, cont);") - (emit* - "(((closure)" - (mangle-global (lib:name->symbol lib-name)) - ")->fn)(1, cont, cont);") - )) - - (emit "}") - (if program? - (emit *c-main-function*)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Automatically generate blocks of code for the compiler -(define (autogen filename) - (let ((fp (open-output-file filename))) - (autogen:defprimitives fp) - (autogen:primitive-procedures fp) - (close-output-port fp))) - -(define (autogen:defprimitives fp) - (display "/* This section is auto-generated via --autogen */\n" fp) - (for-each - (lambda (p) - (display - (string-append - "defprimitive(" - (mangle p) - ", " - (symbol->string p) - ", &_" - (mangle p) - "); /* " - (symbol->string p) - " */\n") - fp)) - *primitives*) - (display "/* -------------------------------------------- */\n" fp)) - -;; List of primitive procedures -(define (autogen:primitive-procedures fp) - (let ((code - (cons - 'list - (map - (lambda (p) - `(list (quote ,p) ,p)) - *primitives*)))) - (cond-expand - (chicken - (pp code fp)) ;; CHICKEN pretty-print - (else - (write code fp))))) - - +#f diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index 63eaef88..44dc922c 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -1,3 +1,10 @@ +;; +;; Cyclone Scheme +;; Copyright (c) 2014, Justin Ethier +;; All rights reserved. +;; +;; This module compiles scheme code to a Cheney-on-the-MTA C runtime. +;; (define-library (scheme cyclone cgen) (import (scheme base) (scheme char) @@ -17,61 +24,1327 @@ emits* emit-newline string-join - ;(cstr:escape-chars str) - ;*c-main-function* - ;*c-call-max-args* 128) - ;*c-call-arity* (make-vector (+ 1 *c-call-max-args*) #f)) - ;(set-c-call-arity! arity) - ;(emit-c-arity-macros arity) - ;(c-macro-return-funcall num-args) - ;(c-macro-return-check num-args) - ;(c-macro-funcall num-args) - ;(c-macro-n-prefix n prefix) - ;(c-macro-array-assign n prefix assign) - ;(c-code/vars str cvars) - ;(c-code str) (c-code/vars str (list))) - ;(c:tuple/args cp num-args) - ;(c:body c-pair) (car c-pair)) - ;(c:allocs c-pair) (cadr c-pair)) - ;(c:num-args c-tuple) (caddr c-tuple)) - ;(c:allocs->str c-allocs . prefix) - ;(c:allocs->str2 c-allocs prefix suffix) - ;(c:append cp1 cp2) - ;(c:append/prefix prefix cp1 cp2) - ;(c:serialize cp prefix) - ;(c-compile-program exp) - ;(c-compile-exp exp append-preamble cont) - ;(c-compile-quote qexp) - ;(c-compile-scalars args) - ;(c-compile-vector exp) - ;(c-compile-const exp) - ;(->cstr str) - ;(prim->c-func p) - ;(prim/c-var-assign p) - ;(prim/cvar? exp) - ;(prim:arg-count? exp) - ;(prim:allocates-object? exp) - ;(c-compile-prim p cont) - ;(c-compile-ref exp) - ;(c-compile-args args append-preamble prefix cont) - ;(c-compile-app exp append-preamble cont) - ;(c-compile-if exp append-preamble cont) - ;*globals* '()) - ;*global-syms* '()) - ;(global-lambda? global) (cadr global)) - ;(global-not-lambda? global) (not (cadr global))) - ;(add-global var-sym lambda? code) - ;(c-compile-global exp append-preamble cont) - ;*symbols* '()) - ;*reserved-symbols* '(Cyc_procedure)) - ;(allocate-symbol sym) - ;num-lambdas 0) - ;lambdas '()) - ;(allocate-lambda lam) - ;(get-lambda id) - ;(lambda->env exp) - ;(c-compile-closure exp append-preamble cont) - ;(c-compile-formals formals type) - ;(c-compile-lambda exp) ) - (include "cgen.scm")) + (begin + +(define (emit line) + (display line) + (newline)) + +(define (emit* . strs) + (for-each emits strs) + (newline)) + +(define (emits str) + (display str)) + +(define (emits* . strs) + (for-each emits strs)) + +(define (emit-newline) + (newline)) + +(define (string-join lst delim) + (cond + ((null? lst) + "") + ((= (length lst) 1) + (car lst)) + (else + (string-append + (car lst) + delim + (string-join (cdr lst) delim))))) + +;; Escape chars in a C-string, so it can be safely written to a C file +(define (cstr:escape-chars str) + (letrec ((next (lambda (head tail) + (cond + ((null? head) (list->string (reverse tail))) + ((equal? (car head) #\") + (next (cdr head) (cons #\" (cons #\\ tail)))) + ((equal? (car head) #\\) + (next (cdr head) (cons #\\ (cons #\\ tail)))) + ((equal? (car head) #\newline) + (next (cdr head) + (cons #\n (cons #\\ tail)))) + (else + (next (cdr head) (cons (car head) tail))))))) + (next (string->list str) '()))) + +(define *c-main-function* +"main(int argc,char **argv) +{long stack_size = long_arg(argc,argv,\"-s\",STACK_SIZE); + long heap_size = long_arg(argc,argv,\"-h\",HEAP_SIZE); + global_stack_size = stack_size; + global_heap_size = heap_size; + _cyc_argc = argc; + _cyc_argv = argv; + main_main(stack_size,heap_size,(char *) &stack_size); + return 0;}") + +;;; Auto-generation of C macros +(define *c-call-max-args* 128) +(define *c-call-arity* (make-vector (+ 1 *c-call-max-args*) #f)) + +(define (set-c-call-arity! arity) + (cond + ((not (number? arity)) + (error `(Non-numeric number of arguments received ,arity))) + ((> arity *c-call-max-args*) + (error "Only support up to 128 arguments. Received: " arity)) + (else + (vector-set! *c-call-arity* arity #t)))) + +(define (emit-c-arity-macros arity) + (when (<= arity *c-call-max-args*) + (cond + ((or (= arity 1) (= arity 2) + (vector-ref *c-call-arity* arity)) + (emit (c-macro-funcall arity)) + (emit (c-macro-return-funcall arity)) + (emit (c-macro-return-check arity)))) + (emit-c-arity-macros (+ arity 1)))) + +(define (c-macro-return-funcall num-args) + (let ((args (c-macro-n-prefix num-args ",a")) + (n (number->string num-args)) + (arry-assign (c-macro-array-assign num-args "buf" "a"))) + (string-append + "/* Return to continuation after checking for stack overflow. */\n" + "#define return_funcall" n "(cfn" args ") \\\n" + "{char stack; \\\n" + " if (check_overflow(&stack,stack_limit1)) { \\\n" + " object buf[" n "]; " arry-assign "\\\n" + " GC(cfn,buf," n "); return; \\\n" + " } else {funcall" n "((closure) (cfn)" args "); return;}}\n"))) + +(define (c-macro-return-check num-args) + (let ((args (c-macro-n-prefix num-args ",a")) + (n (number->string num-args)) + (arry-assign (c-macro-array-assign num-args "buf" "a"))) + (string-append + "/* Evaluate an expression after checking for stack overflow. */\n" + "#define return_check" n "(_fn" args ") { \\\n" + " char stack; \\\n" + " if (check_overflow(&stack,stack_limit1)) { \\\n" + " object buf[" n "]; " arry-assign " \\\n" + " mclosure0(c1, _fn); \\\n" + " GC(&c1, buf, " n "); return; \\\n" + " } else { (_fn)(" n ",(closure)_fn" args "); }}\n"))) + +(define (c-macro-funcall num-args) + (let ((args (c-macro-n-prefix num-args ",a")) + (n (number->string num-args)) + (n-1 (number->string (if (> num-args 0) (- num-args 1) 0))) + (wrap (lambda (s) (if (> num-args 0) s "")))) + (string-append + "#define funcall" n "(cfn" args ") " + (wrap (string-append "if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(" n-1 ", (closure)a1, cfn" (if (> num-args 1) (substring args 3 (string-length args)) "") "); }")) + (wrap " else { ") + "((cfn)->fn)(" n ",cfn" args ")" + (wrap ";}") + ))) + +(define (c-macro-n-prefix n prefix) + (if (> n 0) + (string-append + (c-macro-n-prefix (- n 1) prefix) + (string-append prefix (number->string n))) + "")) + +(define (c-macro-array-assign n prefix assign) + (if (> n 0) + (string-append + (c-macro-array-assign (- n 1) prefix assign) + prefix "[" (number->string (- n 1)) "] = " + assign (number->string n) ";") + "")) + +;;; Stack trace (call history) helpers + +;; Add function to trace, if not already set +(define (st:add-function! trace fnc) + (if (null? (cdr trace)) + (cons (car trace) fnc) + trace)) + +(define (st:->code trace) + (if (or (not (pair? trace)) + (null? (cdr trace))) + "" + (string-append + "Cyc_st_add(\"" + (car trace) + ":" + ;; TODO: escape backslashes + (symbol->string (cdr trace)) + "\");\n" + ))) + +;; END st helpers + +;;; Compilation routines. + +;; Return generated code that also requests allocation of C variables on stack +(define (c-code/vars str cvars) + (list str + cvars)) + +;; Return generated code with no C variables allocated on the stack +(define (c-code str) (c-code/vars str (list))) + +;; Append arg count to a C code pair +(define (c:tuple/args cp num-args) + (append cp (list num-args))) + +;; Functions to work with data structures that contain C code: +;; +;; body - The actual body of C code +;; allocs - Allocations made by C code, eg "int c" +;; num-args - Number of function arguments combined in the tuple (optional) +;; +(define (c:body c-pair) (car c-pair)) +(define (c:allocs c-pair) (cadr c-pair)) +(define (c:num-args c-tuple) (caddr c-tuple)) + +(define (c:allocs->str c-allocs . prefix) + (apply + string-append + (map + (lambda (c) + (string-append + (if (null? prefix) + "" + (car prefix)) + c + "\n")) + c-allocs))) + +(define (c:allocs->str2 c-allocs prefix suffix) + (apply + string-append + (map + (lambda (c) + (string-append prefix c suffix)) + c-allocs))) + +(define (c:append cp1 cp2) + (c-code/vars + (string-append (c:body cp1) (c:body cp2)) + (append (c:allocs cp1) (c:allocs cp2)))) + +(define (c:append/prefix prefix cp1 cp2) + (c-code/vars + (string-append prefix (c:body cp1) (c:body cp2)) + (append (c:allocs cp1) (c:allocs cp2)))) + +(define (c:serialize cp prefix) + (string-append + (c:allocs->str (c:allocs cp) prefix) + prefix + (c:body cp))) + +;; c-compile-program : exp -> string +(define (c-compile-program exp src-file) + (let* ((preamble "") + (append-preamble (lambda (s) + (set! preamble (string-append preamble " " s "\n")))) + (body (c-compile-exp exp append-preamble "cont" (list src-file)))) + ;(write `(DEBUG ,body)) + (string-append + preamble + (c:serialize body " ") ;" ;\n" +; "int main (int argc, char* argv[]) {\n" +; " return 0;\n" +; " }\n" +))) + +;; c-compile-exp : exp (string -> void) -> string +;; +;; exp - expression to compiler +;; append-preamble - ?? +;; cont - name of the next continuation +;; this is experimental and probably needs refinement +;; trace - trace information. presently a pair containing: +;; * source file +;; * function name (or nil if none) +(define (c-compile-exp exp append-preamble cont trace) + (cond + ; Core forms: + ((const? exp) (c-compile-const exp)) + ((prim? exp) + ;; TODO: this needs to be more refined, probably w/a lookup table + (c-code (string-append "primitive_" (mangle exp)))) + ((ref? exp) (c-compile-ref exp)) + ((quote? exp) (c-compile-quote exp)) + ((if? exp) (c-compile-if exp append-preamble cont trace)) + + ; IR (2): + ((tagged-list? '%closure exp) + (c-compile-closure exp append-preamble cont trace)) + ; Global definition + ((define? exp) + (c-compile-global exp append-preamble cont trace)) + ; Special case - global function w/out a closure. Create an empty closure + ((tagged-list? 'lambda exp) + (c-compile-exp + `(%closure ,exp) + append-preamble cont trace)) + + ; Application: + ((app? exp) (c-compile-app exp append-preamble cont trace)) + (else (error "unknown exp in c-compile-exp: " exp)))) + +(define (c-compile-quote qexp) + (let ((exp (cadr qexp))) + (c-compile-scalars exp))) + +(define (c-compile-scalars args) + (letrec ( + (num-args 0) + (create-cons + (lambda (cvar a b) + (c-code/vars + (string-append "make_cons(" cvar "," (c:body a) "," (c:body b) ");") + (append (c:allocs a) (c:allocs b)))) + ) + (_c-compile-scalars + (lambda (args) + (cond + ((null? args) + (c-code "nil")) + ((not (pair? args)) + (c-compile-const args)) + (else + (let* ((cvar-name (mangle (gensym 'c))) + (cell (create-cons + cvar-name + (c-compile-const (car args)) + (_c-compile-scalars (cdr args))))) + (set! num-args (+ 1 num-args)) + (c-code/vars + (string-append "&" cvar-name) + (append + (c:allocs cell) + (list (c:body cell)))))))))) + (c:tuple/args + (_c-compile-scalars args) + num-args))) + +(define (c-compile-vector exp) + (letrec ((cvar-name (mangle (gensym 'vec))) + (len (vector-length exp)) + ;; Generate code for each member of the vector + (loop + (lambda (i code) + (if (= i len) + code + (let ((idx-code (c-compile-const (vector-ref exp i)))) + (loop + (+ i 1) + (c-code/vars + ;; The vector's C variable + (c:body code) + ;; Allocations + (append + (c:allocs code) ;; Vector alloc + (c:allocs idx-code) ;; Member alloc at index i + (list ;; Assign this member to vector + (string-append + cvar-name ".elts[" (number->string i) "] = " + (c:body idx-code) + ";"))))))))) + ) + (cond + ((zero? len) + (c-code/vars + (string-append "&" cvar-name) ; Code is just the variable name + (list ; Allocate empty vector + (string-append + "make_empty_vector(" cvar-name ");")))) + (else + (let ((code + (c-code/vars + (string-append "&" cvar-name) ; Code body is just var name + (list ; Allocate the vector + (string-append + "make_empty_vector(" cvar-name ");" + cvar-name ".num_elt = " (number->string len) ";" + cvar-name ".elts = (object *)alloca(sizeof(object) * " + (number->string len) ");"))))) + (loop 0 code)))))) + +;; c-compile-const : const-exp -> c-pair +;; +;; Typically this function is used to compile constant values such as +;; a single number, boolean, etc. However, it can be passed a quoted +;; item such as a list, to compile as a literal. +(define (c-compile-const exp) + (cond + ((null? exp) + (c-code "nil")) + ((pair? exp) + (c-compile-scalars exp)) + ((vector? exp) + (c-compile-vector exp)) + ((integer? exp) + (let ((cvar-name (mangle (gensym 'c)))) + (c-code/vars + (string-append "&" cvar-name) ; Code is just the variable name + (list ; Allocate integer on the C stack + (string-append + "make_int(" cvar-name ", " (number->string exp) ");"))))) + ((real? exp) + (let ((cvar-name (mangle (gensym 'c)))) + (c-code/vars + (string-append "&" cvar-name) ; Code is just the variable name + (list ; Allocate on the C stack + (string-append + "make_double(" cvar-name ", " (number->string exp) ");"))))) + ((boolean? exp) + (c-code (string-append + (if exp "boolean_t" "boolean_f")))) + ((char? exp) + (c-code (string-append "obj_char2obj(" + (number->string (char->integer exp)) ")"))) + ((string? exp) + (let ((cvar-name (mangle (gensym 'c)))) + (c-code/vars + (string-append "&" cvar-name) ; Code is just the variable name + (list ; Allocate integer on the C stack + (string-append + "make_string(" cvar-name ", " (->cstr exp) ");"))))) +;TODO: not good enough, need to store new symbols in a table so they can +;be inserted into the C program + ((symbol? exp) + (allocate-symbol exp) + (c-code (string-append "quote_" (mangle exp)))) + (else + (error "unknown constant: " exp)))) + +;; Convert a "scheme" string to a corresponding representation in C. +;; Keep in mind scheme strings can span lines, contain chars that +;; might not be allowed in C, etc. +(define (->cstr str) + (string-append "\"" (cstr:escape-chars str) "\"")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Primitives + +(define (prim->c-func p) + (cond + ((eq? p 'Cyc-global-vars) "Cyc_get_global_variables") + ((eq? p 'Cyc-get-cvar) "Cyc_get_cvar") + ((eq? p 'Cyc-set-cvar!) "Cyc_set_cvar") + ((eq? p 'Cyc-cvar?) "Cyc_is_cvar") + ((eq? p 'Cyc-has-cycle?) "Cyc_has_cycle") + ((eq? p 'Cyc-stdout) "Cyc_stdout") + ((eq? p 'Cyc-stdin) "Cyc_stdin") + ((eq? p 'Cyc-stderr) "Cyc_stderr") + ((eq? p '+) "Cyc_sum") + ((eq? p '-) "Cyc_sub") + ((eq? p '*) "Cyc_mul") + ((eq? p '/) "Cyc_div") + ((eq? p '=) "__num_eq") + ((eq? p '>) "__num_gt") + ((eq? p '<) "__num_lt") + ((eq? p '>=) "__num_gte") + ((eq? p '<=) "__num_lte") + ((eq? p 'apply) "apply") + ((eq? p '%halt) "__halt") + ((eq? p 'exit) "__halt") + ((eq? p 'Cyc-default-exception-handler) "Cyc_default_exception_handler") + ((eq? p 'Cyc-current-exception-handler) "Cyc_current_exception_handler") + ((eq? p 'open-input-file) "Cyc_io_open_input_file") + ((eq? p 'open-output-file) "Cyc_io_open_output_file") + ((eq? p 'close-port) "Cyc_io_close_port") + ((eq? p 'close-input-port) "Cyc_io_close_input_port") + ((eq? p 'close-output-port) "Cyc_io_close_output_port") + ((eq? p 'Cyc-flush-output-port) "Cyc_io_flush_output_port") + ((eq? p 'file-exists?) "Cyc_io_file_exists") + ((eq? p 'delete-file) "Cyc_io_delete_file") + ((eq? p 'read-char) "Cyc_io_read_char") + ((eq? p 'peek-char) "Cyc_io_peek_char") + ((eq? p 'Cyc-read-line) "Cyc_io_read_line") + ((eq? p 'Cyc-display) "Cyc_display_va") + ((eq? p 'Cyc-write) "Cyc_write_va") + ((eq? p 'Cyc-write-char) "Cyc_write_char") + ((eq? p 'car) "car") + ((eq? p 'cdr) "cdr") + ((eq? p 'caar) "caar") + ((eq? p 'cadr) "cadr") + ((eq? p 'cdar) "cdar") + ((eq? p 'cddr) "cddr") + ((eq? p 'caaar) "caaar") + ((eq? p 'caadr) "caadr") + ((eq? p 'cadar) "cadar") + ((eq? p 'caddr) "caddr") + ((eq? p 'cdaar) "cdaar") + ((eq? p 'cdadr) "cdadr") + ((eq? p 'cddar) "cddar") + ((eq? p 'cdddr) "cdddr") + ((eq? p 'caaaar) "caaaar") + ((eq? p 'caaadr) "caaadr") + ((eq? p 'caadar) "caadar") + ((eq? p 'caaddr) "caaddr") + ((eq? p 'cadaar) "cadaar") + ((eq? p 'cadadr) "cadadr") + ((eq? p 'caddar) "caddar") + ((eq? p 'cadddr) "cadddr") + ((eq? p 'cdaaar) "cdaaar") + ((eq? p 'cdaadr) "cdaadr") + ((eq? p 'cdadar) "cdadar") + ((eq? p 'cdaddr) "cdaddr") + ((eq? p 'cddaar) "cddaar") + ((eq? p 'cddadr) "cddadr") + ((eq? p 'cdddar) "cdddar") + ((eq? p 'cddddr) "cddddr") + ((eq? p 'char->integer) "Cyc_char2integer") + ((eq? p 'integer->char) "Cyc_integer2char") + ((eq? p 'string->number)"Cyc_string2number") + ((eq? p 'list->string) "Cyc_list2string") + ((eq? p 'make-vector) "Cyc_make_vector") + ((eq? p 'list->vector) "Cyc_list2vector") + ((eq? p 'vector-length) "Cyc_vector_length") + ((eq? p 'vector-ref) "Cyc_vector_ref") + ((eq? p 'vector-set!) "Cyc_vector_set") + ((eq? p 'string-append) "Cyc_string_append") + ((eq? p 'string-cmp) "Cyc_string_cmp") + ((eq? p 'string->symbol) "Cyc_string2symbol") + ((eq? p 'symbol->string) "Cyc_symbol2string") + ((eq? p 'number->string) "Cyc_number2string") + ((eq? p 'string-length) "Cyc_string_length") + ((eq? p 'string-ref) "Cyc_string_ref") + ((eq? p 'string-set!) "Cyc_string_set") + ((eq? p 'substring) "Cyc_substring") + ((eq? p 'Cyc-installation-dir) "Cyc_installation_dir") + ((eq? p 'command-line-arguments) "Cyc_command_line_arguments") + ((eq? p 'system) "Cyc_system") + ((eq? p 'assq) "assq") + ((eq? p 'assv) "assq") + ((eq? p 'assoc) "assoc") + ((eq? p 'memq) "memqp") + ((eq? p 'memv) "memqp") + ((eq? p 'member) "memberp") + ((eq? p 'length) "Cyc_length") + ((eq? p 'set-car!) "Cyc_set_car") + ((eq? p 'set-cdr!) "Cyc_set_cdr") + ((eq? p 'eq?) "Cyc_eq") + ((eq? p 'eqv?) "Cyc_eq") + ((eq? p 'equal?) "equalp") + ((eq? p 'boolean?) "Cyc_is_boolean") + ((eq? p 'char?) "Cyc_is_char") + ((eq? p 'null?) "Cyc_is_null") + ((eq? p 'number?) "Cyc_is_number") + ((eq? p 'real?) "Cyc_is_real") + ((eq? p 'integer?) "Cyc_is_integer") + ((eq? p 'pair?) "Cyc_is_cons") + ((eq? p 'procedure?) "Cyc_is_procedure") + ((eq? p 'port?) "Cyc_is_port") + ((eq? p 'vector?) "Cyc_is_vector") + ((eq? p 'string?) "Cyc_is_string") + ((eq? p 'eof-object?) "Cyc_is_eof_object") + ((eq? p 'symbol?) "Cyc_is_symbol") + ((eq? p 'cons) "make_cons") + ((eq? p 'cell) "make_cell") + ((eq? p 'cell-get) "cell_get") + ((eq? p 'set-cell!) "Cyc_set_car") + ((eq? p 'set-global!) "global_set") + (else + (error "unhandled primitive: " p)))) + +;; Determine if primitive assigns (allocates) a C variable +;; EG: int v = prim(); +(define (prim/c-var-assign p) + (cond + ((eq? p 'Cyc-stdout) "port_type") + ((eq? p 'Cyc-stdin) "port_type") + ((eq? p 'Cyc-stderr) "port_type") + ((eq? p 'open-input-file) "port_type") + ((eq? p 'open-output-file) "port_type") + ((eq? p 'length) "integer_type") + ((eq? p 'vector-length) "integer_type") + ((eq? p 'char->integer) "integer_type") + ((eq? p 'Cyc-installation-dir) "string_type") + ((eq? p 'system) "integer_type") + ((eq? p '+) "common_type") + ((eq? p '-) "common_type") + ((eq? p '*) "common_type") + ((eq? p '/) "common_type") + ((eq? p 'string->number) "common_type") + ((eq? p 'list->string) "string_type") + ((eq? p 'string-cmp) "integer_type") + ((eq? p 'string-append) "string_type") + ((eq? p 'symbol->string) "string_type") + ((eq? p 'number->string) "string_type") + ((eq? p 'string-length) "integer_type") + ((eq? p 'substring) "string_type") + ((eq? p 'apply) "object") + ((eq? p 'Cyc-read-line) "object") + ((eq? p 'command-line-arguments) "object") + ((eq? p 'make-vector) "object") + ((eq? p 'list->vector) "object") + (else #f))) + +;; Determine if primitive creates a C variable +(define (prim/cvar? exp) + (and (prim? exp) + (member exp '( + Cyc-stdout + Cyc-stdin + Cyc-stderr + open-input-file + open-output-file + char->integer + system + Cyc-installation-dir + string->number + string-append string-cmp list->string + make-vector list->vector + symbol->string number->string + string-length substring + + - * / apply + command-line-arguments + Cyc-read-line + cons length vector-length cell)))) + +;; Pass continuation as the function's first parameter? +(define (prim:cont? exp) + (and (prim? exp) + (member exp '(Cyc-read-line apply command-line-arguments make-vector list->vector)))) +;; TODO: this is a hack, right answer is to include information about +;; how many args each primitive is supposed to take +(define (prim:cont-has-args? exp) + (and (prim? exp) + (member exp '(Cyc-read-line apply make-vector list->vector)))) + +;; Pass an integer arg count as the function's first parameter? +(define (prim:arg-count? exp) + (and (prim? exp) + (member exp '(error Cyc-write Cyc-display string-append + - * /)))) + +;; Does primitive allocate an object? +;; TODO: these are the functions that are defined via macros. This method +;; is obsolete and should be replaced by prim:cont? functions over time. +(define (prim:allocates-object? exp) + (and (prim? exp) + (member exp '()))) + +;; c-compile-prim : prim-exp -> string -> string +(define (c-compile-prim p cont) + (let* ((c-func (prim->c-func p)) + ;; Following closure defs are only used for prim:cont? to + ;; create a new closure for the continuation, if needed. + ;; + ;; Each prim:cont? function is different in that it takes a continuation so that it can + ;; allocate arbitrary data as needed using alloca, and then call into + ;; the cont so allocations can remain on stack until GC. + (closure-sym (mangle (gensym 'c))) + (closure-def + (cond + ((and (prim:cont? p) + (> (string-length cont) (string-length "__lambda_")) + (equal? (substring cont 0 9) "__lambda_")) + (string-append + "mclosure0(" closure-sym + "," cont "); ")) + (else #f))) + ;; END apply defs + (c-var-assign + (lambda (type) + (let ((cv-name (mangle (gensym 'c)))) + (c-code/vars + (string-append (if (prim:cont? p) "" "&") cv-name) + (list + (string-append + ;; Define closure if necessary (apply only) + (cond + (closure-def closure-def) + (else "")) + + ;; Emit C variable + type " " cv-name " = " c-func "(" + + ;; Emit closure as first arg, if necessary (apply only) + (cond + (closure-def + (string-append "&" closure-sym + (if (prim:cont-has-args? p) ", " ""))) + ((prim:cont? p) + (string-append cont + (if (prim:cont-has-args? p) ", " ""))) + (else ""))))))))) + (cond + ((prim/c-var-assign p) + (c-var-assign (prim/c-var-assign p))) + ((prim/cvar? p) + ;; + ;; TODO: look at functions that would actually fall into this + ;; branch, I think they are just the macro's like list->vector??? + ;; may be able to remove this using prim:cont? and simplify + ;; the logic + ;; + (let ((cv-name (mangle (gensym 'c)))) + (c-code/vars + (if (prim:allocates-object? p) + cv-name ;; Already a pointer + (string-append "&" cv-name)) ;; Point to data + (list + (string-append c-func "(" cv-name))))) + (else + (c-code (string-append c-func "(")))))) + +;; END primitives +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; c-compile-ref : ref-exp -> string +(define (c-compile-ref exp) + (c-code + (if (member exp *global-syms*) + (mangle-global exp) + (mangle exp)))) + +; c-compile-args : list[exp] (string -> void) -> string +(define (c-compile-args args append-preamble prefix cont trace) + (letrec ((num-args 0) + (_c-compile-args + (lambda (args append-preamble prefix cont) + (if (not (pair? args)) + (c-code "") + (begin + ;(trace:debug `(c-compile-args ,(car args))) + (set! num-args (+ 1 num-args)) + (c:append/prefix + prefix + (c-compile-exp (car args) + append-preamble cont trace) + (_c-compile-args (cdr args) + append-preamble ", " cont))))))) + (c:tuple/args + (_c-compile-args args + append-preamble prefix cont) + num-args))) + +;; c-compile-app : app-exp (string -> void) -> string +(define (c-compile-app exp append-preamble cont trace) + ;(trace:debug `(c-compile-app: ,exp)) + (let (($tmp (mangle (gensym 'tmp)))) + (let* ((args (app->args exp)) + (fun (app->fun exp))) + (cond + ((lambda? fun) + (let* ((lid (allocate-lambda (c-compile-lambda fun trace))) ;; TODO: pass in free vars? may be needed to track closures + ;; properly, wait until this comes up in an example + (this-cont (string-append "__lambda_" (number->string lid))) + (cgen + (c-compile-args + args + append-preamble + "" + this-cont + trace)) + (num-cargs (c:num-args cgen))) + (set-c-call-arity! num-cargs) + (c-code + (string-append + (c:allocs->str (c:allocs cgen)) + "return_check" (number->string num-cargs) + "(" this-cont + (if (> num-cargs 0) "," "") ; TODO: how to propagate continuation - cont " " + (c:body cgen) ");")))) + + ((prim? fun) + (let* ((c-fun + (c-compile-prim fun cont)) + (c-args + (c-compile-args args append-preamble "" "" trace)) + (num-args (length args)) + (num-args-str + (string-append + (number->string num-args) + (if (> num-args 0) "," ""))) + (c-args* (if (prim:arg-count? fun) + (c:append (c-code num-args-str) c-args) + c-args))) + (if (prim/cvar? fun) + ;; Args need to go with alloc function + (c-code/vars + (c:body c-fun) + (append + (c:allocs c-args*) ;; fun alloc depends upon arg allocs + (list (string-append + (car (c:allocs c-fun)) + (if (prim/c-var-assign fun) "" ",") ; Allocating C var + (c:body c-args*) ");")))) + ;; Args stay with body + (c:append + (c:append c-fun c-args*) + (c-code ")"))))) + + ((equal? '%closure-ref fun) + (c-code (apply string-append (list + "(" + ;; TODO: probably not the ideal solution, but works for now + "(closureN)" + (mangle (car args)) + ")->elts[" + (number->string (- (cadr args) 1))"]")))) + + ;; TODO: may not be good enough, closure app could be from an elt + ((tagged-list? '%closure-ref fun) + (let* ((cfun (c-compile-args (list (car args)) append-preamble " " cont trace)) + (this-cont (c:body cfun)) + (cargs (c-compile-args (cdr args) append-preamble " " this-cont trace))) + (set-c-call-arity! (c:num-args cargs)) + (c-code + (string-append + (c:allocs->str (c:allocs cfun) "\n") + (c:allocs->str (c:allocs cargs) "\n") + "return_funcall" (number->string (c:num-args cargs)) + "(" + this-cont + (if (> (c:num-args cargs) 0) "," "") + (c:body cargs) + ");")))) + + ((tagged-list? '%closure fun) + (let* ((cfun (c-compile-closure + fun append-preamble cont trace)) + (this-cont (string-append "(closure)" (c:body cfun))) + (cargs (c-compile-args + args append-preamble " " this-cont trace)) + (num-cargs (c:num-args cargs))) + (set-c-call-arity! num-cargs) + (c-code + (string-append + (c:allocs->str (c:allocs cfun) "\n") + (c:allocs->str (c:allocs cargs) "\n") + "return_funcall" (number->string num-cargs) + "(" + this-cont + (if (> num-cargs 0) "," "") + (c:body cargs) + ");")))) + + (else + (error `(Unsupported function application ,exp))))))) + +; c-compile-if : if-exp -> string +(define (c-compile-if exp append-preamble cont trace) + (let* ((compile (lambda (exp) + (c-compile-exp exp append-preamble cont trace))) + (test (compile (if->condition exp))) + (then (compile (if->then exp))) + (els (compile (if->else exp)))) + (c-code (string-append + (c:allocs->str (c:allocs test) " ") + "if( !eq(boolean_f, " + (c:body test) + ") ){ \n" + (c:serialize then " ") + "\n} else { \n" + (c:serialize els " ") + "}\n")))) + +;; Global compilation +(define *globals* '()) +(define *global-syms* '()) +(define (global-lambda? global) (cadr global)) +(define (global-not-lambda? global) (not (cadr global))) +(define (add-global var-sym lambda? code) + ;(write `(add-global ,var-sym ,code)) + (set! *globals* (cons (list var-sym lambda? code) *globals*))) +(define (c-compile-global exp append-preamble cont trace) + (let ((var (define->var exp)) + (body (if (equal? 4 (length exp)) ; Simple var assignment contains superfluous %closure-ref + (cadddr exp) + (car (define->exp exp))))) + (add-global + var + (lambda? body) + (c-compile-exp + body append-preamble cont + (st:add-function! trace var))) + (c-code/vars "" (list "")))) + +;; Symbol compilation + +(define *symbols* '()) + +(define (allocate-symbol sym) + (if (not (member sym *symbols*)) + ;(not (Cyc-reserved-symbol? sym))) + (set! *symbols* (cons sym *symbols*)))) + +;; Lambda compilation. + +;; Lambdas get compiled into procedures that, +;; once given a C name, produce a C function +;; definition with that name. + +;; These procedures are stored up an eventually +;; emitted. + +; type lambda-id = natural + +; num-lambdas : natural +(define num-lambdas 0) + +; lambdas : alist[lambda-id,string -> string] +(define lambdas '()) + +; allocate-lambda : (string -> string) -> lambda-id +(define (allocate-lambda lam) + (let ((id num-lambdas)) + (set! num-lambdas (+ 1 num-lambdas)) + (set! lambdas (cons (list id lam) lambdas)) + id)) + +; get-lambda : lambda-id -> (symbol -> string) +(define (get-lambda id) + (cdr (assv id lambdas))) + +(define (lambda->env exp) + (let ((formals (lambda-formals->list exp))) + (if (pair? formals) + (car formals) + 'unused))) + +; (tmp-ident (if (> (length (lambda-formals->list exp)) 0) +; (mangle (if (pair? (lambda->formals exp)) +; (car (lambda->formals exp)) +; (lambda->formals exp))) +; "")) +; (has-closure? +; (and +; (> (string-length tmp-ident) 3) +; (equal? "self" (substring tmp-ident 0 4)))) + +;; Compute the minimum number of arguments a function expects. +;; Note this must be the count before additional closure/CPS arguments +;; are added, so we need to detect those and not include them. +(define (compute-num-args lam) + (let ((count (lambda-num-args lam))) ;; Current arg count, may be too high + (cond + ((< count 0) -1) ;; Unlimited + (else + (let ((formals (lambda-formals->list lam))) + (- count + (if (fl/closure? formals) 1 0) + (if (fl/cont? formals) 1 0))))))) + +;; Formal list with a closure? +(define (fl/closure? lis) + (cond + ((null? lis) #f) + (else + (let ((arg (symbol->string (car lis)))) + (and + (> (string-length arg) 4) + (equal? "self$" (substring arg 0 5))))))) + +;; Formal list with a continuation (k)? +(define (fl/cont? lis) + (let ((check (lambda (lis) + (cond + ((null? lis) #f) + (else + (let ((arg (symbol->string (car lis)))) + (and + (> (string-length arg) 1) + (equal? "k$" (substring arg 0 2))))))))) + ;; Find the cont arg; if there is a closure it is always first + (if (fl/closure? lis) + (check (cdr lis)) + (check lis)))) + +;; c-compile-closure : closure-exp (string -> void) -> string +;; +;; This function compiles closures generated earlier in the +;; compilation process. Each closure is of the form: +;; +;; (%closure lambda arg ...) +;; +;; Where: +;; - `%closure` is the identifying tag +;; - `lambda` is the function to execute +;; - Each `arg` is a free variable that must be stored within +;; the closure. The closure conversion phase tags each access +;; to one with the corresponding index so `lambda` can use them. +;; +(define (c-compile-closure exp append-preamble cont trace) + (let* ((lam (closure->lam exp)) + (free-vars + (map + (lambda (free-var) + (if (tagged-list? '%closure-ref free-var) + (let ((var (cadr free-var)) + (idx (number->string (- (caddr free-var) 1)))) + (string-append + "((closureN)" (mangle var) ")->elts[" idx "]")) + (mangle free-var))) + (closure->fv exp))) ; Note these are not necessarily symbols, but in cc form + (cv-name (mangle (gensym 'c))) + (lid (allocate-lambda (c-compile-lambda lam trace))) + (create-nclosure (lambda () + (string-append + "closureN_type " cv-name ";\n" + cv-name ".tag = closureN_tag;\n " + cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n" + cv-name ".num_args = " (number->string (compute-num-args lam)) ";\n" + cv-name ".num_elt = " (number->string (length free-vars)) ";\n" + cv-name ".elts = (object *)alloca(sizeof(object) * " + (number->string (length free-vars)) ");\n" + (let loop ((i 0) + (vars free-vars)) + (if (null? vars) + "" + (string-append + cv-name ".elts[" (number->string i) "] = " + (car vars) ";\n" + (loop (+ i 1) (cdr vars)))))))) + (create-mclosure (lambda () + (string-append + "mclosure" (number->string (length free-vars)) "(" cv-name ", " + ;; NOTE: + ;; Hopefully will not cause issues with varargs when casting to + ;; generic function type below. Works fine in gcc, not sure if + ;; this is portable to other compilers though + "(function_type)__lambda_" (number->string lid) + (if (> (length free-vars) 0) "," "") + (string-join free-vars ", ") + ");" + cv-name ".num_args = " (number->string (compute-num-args lam)) ";" + )))) + (c-code/vars + (string-append "&" cv-name) + (list + (if (> (length free-vars) 0) + (create-nclosure) + (create-mclosure)))))) + +; c-compile-formals : list[symbol] -> string +(define (c-compile-formals formals type) + (if (not (pair? formals)) + "" + (string-append + "object " + (mangle (car formals)) + (cond + ((pair? (cdr formals)) + (string-append ", " (c-compile-formals (cdr formals) type))) + ((not (equal? 'args:fixed type)) + (string-append ", object " (mangle (cdr formals)) "_raw, ...")) + (else + ""))))) + +; c-compile-lambda : lamda-exp (string -> void) -> (string -> string) +(define (c-compile-lambda exp trace) + (let* ((preamble "") + (append-preamble (lambda (s) + (set! preamble (string-append preamble " " s "\n"))))) + (let* ((formals (c-compile-formals + (lambda->formals exp) + (lambda-formals-type exp))) + (tmp-ident (if (> (length (lambda-formals->list exp)) 0) + (mangle (if (pair? (lambda->formals exp)) + (car (lambda->formals exp)) + (lambda->formals exp))) + "")) + (has-closure? + (and + (> (string-length tmp-ident) 3) + (equal? "self" (substring tmp-ident 0 4)))) + (formals* + (string-append + (if has-closure? + "" + (if (equal? "" formals) + "closure _" ;; TODO: seems wrong, will GC be too aggressive + "closure _,")) ;; due to missing refs, with ignored closure? + formals)) + (env-closure (lambda->env exp)) + (body (c-compile-exp + (car (lambda->exp exp)) ;; car ==> assume single expr in lambda body after CPS + append-preamble + (mangle env-closure) + trace))) + (cons + (lambda (name) + (string-append "static void " name + "(int argc, " + formals* + ") {\n" + preamble + (if (lambda-varargs? exp) + ;; Load varargs from C stack into Scheme list + (string-append + ; DEBUGGING: + ;"printf(\"%d %d\\n\", argc, " + ; (number->string (length (lambda-formals->list exp))) ");" + "load_varargs(" + (mangle (lambda-varargs-var exp)) + ", " + (mangle (lambda-varargs-var exp)) + "_raw, argc - " (number->string + (- (length (lambda-formals->list exp)) + 1 + (if has-closure? 1 0))) + ");\n"); + "") ; No varargs, skip + (c:serialize + (c:append + (c-code (st:->code trace)) + body) + " ") + "; \n" + "}\n")) + formals*)))) + +(define (mta:code-gen input-program + program? + lib-name + lib-exports + imported-globals + globals + required-libs + src-file) + (set! *global-syms* (append globals imported-globals)) + (let ((compiled-program-lst '()) + (compiled-program #f)) + ;; Compile program, using for-each to guarantee execution order, + ;; since c-compile-program has side-effects. + (for-each + (lambda (expr) + (set! compiled-program-lst + (cons (c-compile-program expr src-file) compiled-program-lst))) + input-program) + + ;; Get top-level string + (set! compiled-program + (apply string-append (reverse compiled-program-lst))) + + (emit-c-arity-macros 0) + (emit "#include \"cyclone/types.h\"") + + ;; Globals defined in this module + (for-each + (lambda (global) + (emits "object ") + (emits (mangle-global (car global))) + (emits " = nil;\n")) + *globals*) + ;; Globals defined by another module + (for-each + (lambda (global) + (emits "extern object ") + (emits (mangle-global global)) + (emits ";\n")) + imported-globals) + (emit "#include \"cyclone/runtime.h\"") + + (if program? + (emit "#include \"cyclone/runtime-main.h\"")) + + ;; Emit symbol definitions + (for-each + (lambda (sym) + (emit* "defsymbol(" (mangle sym) ");")) + *symbols*) + + ;; Emit lambdas: + ; Print the prototypes: + (for-each + (lambda (l) + (emit* + "static void __lambda_" + (number->string (car l)) "(int argc, " + (cdadr l) + ") ;")) + lambdas) + + (emit "") + + ; Print the definitions: + (for-each + (lambda (l) + (emit ((caadr l) (string-append "__lambda_" (number->string (car l)))))) + lambdas) + + ; Emit entry point + (cond + (program? + (emit "static void c_entry_pt_first_lambda();") + (for-each + (lambda (lib-name) + (emit* "extern void c_" (lib:name->string lib-name) "_entry_pt(int argc, closure cont, object value);")) + required-libs) + (emit "static void c_entry_pt(argc, env,cont) int argc; closure env,cont; { ")) + (else + (emit* "void c_" (lib:name->string lib-name) "_entry_pt(argc, cont,value) int argc; closure cont; object value;{ ") + ; DEBUG (emit (string-append "printf(\"init " (lib:name->string lib-name) "\\n\");")) + )) + + ;; Initialize symbols + (for-each + (lambda (sym) + (emit* + " quote_" (mangle sym) " = find_or_add_symbol(\"" + (symbol->string sym) "\");")) + *symbols*) + + ;; Initialize global table + (for-each + (lambda (global) + (emits "\n add_global((object *) &") + (emits (mangle-global (car global))) + (emits ");")) + *globals*) + (emit "") + + ;; Initialize symbol table + (for-each + (lambda (sym) + (emit* " add_symbol(quote_" (mangle sym) ");")) + *symbols*) + + ;; Initialize globals + (let* ((prefix " ") + (emit-global + (lambda (global) + (emits (c:allocs->str2 (c:allocs (caddr global)) prefix " \n")) + (emits prefix) + (emits (mangle-global (car global))) + (emits " = ") + (emits (c:body (caddr global))) + (emit "; ")))) + (for-each emit-global (filter global-lambda? *globals*)) + (for-each emit-global (filter global-not-lambda? *globals*)) + (emit "")) + + ;; Initialize Cyc_global_variables + ;; TODO: only need to do this if 'eval' was also compiled + (let ((pairs '()) + (head-pair #f)) + (for-each + (lambda (g) + (let ((cvar-sym (mangle (gensym 'cvar))) + (pair-sym (mangle (gensym 'pair)))) + (emits* + " make_cvar(" cvar-sym + ", (object *)&" (mangle-global (car g)) ");") + (emits* + "make_cons(" pair-sym ", find_or_add_symbol(\"" (symbol->string (car g)) + "\"), &" cvar-sym ");\n") + (set! pairs (cons pair-sym pairs)) + )) + *globals*) + (let loop ((code '()) + (ps pairs) + (cs (map (lambda (_) (mangle (gensym 'c))) pairs))) + (cond + ((null? ps) + (for-each + (lambda (str) + (emits str)) + code)) + ((null? (cdr ps)) + (if (not head-pair) + (set! head-pair (car cs))) + (loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ",Cyc_global_variables);\n") code) + (cdr ps) + (cdr cs))) + (else + (if (not head-pair) + (set! head-pair (car cs))) + (loop (cons (string-append "make_cons(" (car cs) ", &" (car ps) ", &" (cadr cs) ");\n") code) + (cdr ps) + (cdr cs))))) + (if head-pair + (emit* + "Cyc_global_variables = &" head-pair ";"))) + + (cond + (program? + ;; Emit code to initialize each module (compiled Scheme library) + (let ((this-clo "c_done") + (prev-clo "c_done")) + (emit* + "mclosure1(" this-clo + ", c_entry_pt_first_lambda, &" prev-clo ");") + (for-each + (lambda (lib-name) + (set! prev-clo this-clo) + (set! this-clo (mangle (gensym "c"))) + (emit* + "mclosure1(" this-clo + ", c_" (lib:name->string lib-name) "_entry_pt" + ", &" prev-clo ");") + ) + (reverse required-libs)) ;; Init each lib's dependencies 1st + (emit* + ;; Start cont chain, but do not assume funcall1 macro was defined + "(" this-clo ".fn)(0, &" this-clo ", &" this-clo ");") + (emit "}") + (emit "static void c_entry_pt_first_lambda(int argc, closure cont, object value) {") + ; DEBUG (emit (string-append "printf(\"init first lambda\\n\");")) + (emit compiled-program))) + (else + ;; Do not use funcall1 macro as it might not have been defined + (emit "cont = ((closure1_type *)cont)->elt1;") + ;(emit "((cont)->fn)(1, cont, cont);") + (emit* + "(((closure)" + (mangle-global (lib:name->symbol lib-name)) + ")->fn)(1, cont, cont);") + )) + + (emit "}") + (if program? + (emit *c-main-function*)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Automatically generate blocks of code for the compiler +(define (autogen filename) + (let ((fp (open-output-file filename))) + (autogen:defprimitives fp) + (autogen:primitive-procedures fp) + (close-output-port fp))) + +(define (autogen:defprimitives fp) + (display "/* This section is auto-generated via --autogen */\n" fp) + (for-each + (lambda (p) + (display + (string-append + "defprimitive(" + (mangle p) + ", " + (symbol->string p) + ", &_" + (mangle p) + "); /* " + (symbol->string p) + " */\n") + fp)) + *primitives*) + (display "/* -------------------------------------------- */\n" fp)) + +;; List of primitive procedures +(define (autogen:primitive-procedures fp) + (let ((code + (cons + 'list + (map + (lambda (p) + `(list (quote ,p) ,p)) + *primitives*)))) + (cond-expand + (chicken + (pp code fp)) ;; CHICKEN pretty-print + (else + (write code fp))))) + +)) diff --git a/scheme/cyclone/common.scm b/scheme/cyclone/common.scm index cc68bcc0..7fd1ea8c 100644 --- a/scheme/cyclone/common.scm +++ b/scheme/cyclone/common.scm @@ -1,31 +1 @@ -(define *version* "0.0.2 (Pre-release)") - -(define *version-banner* - (string-append " - :@ - @@@ - @@@@: - `@@@@@+ - .@@@+@@@ Cyclone - @@ @@ Scheme-to-C compiler - ,@ https://github.com/justinethier/cyclone - '@ - .@ - @@ #@ (c) 2014 Justin Ethier - `@@@#@@@. Version " *version* " - #@@@@@ - +@@@+ - @@# - `@. - -")) - -(define *c-file-header-comment* - (string-append "/** - ** This file was automatically generated by the Cyclone scheme compiler - ** - ** (c) 2014 Justin Ethier - ** Version " *version* " - ** - **/ -")) +#f diff --git a/scheme/cyclone/common.sld b/scheme/cyclone/common.sld index 973ed018..ef934b82 100644 --- a/scheme/cyclone/common.sld +++ b/scheme/cyclone/common.sld @@ -6,4 +6,38 @@ *c-file-header-comment*) (include "common.scm") (begin - (define *Cyc-version-banner* *version-banner*))) + (define *Cyc-version-banner* *version-banner*) + +(define *version* "0.0.2 (Pre-release)") + +(define *version-banner* + (string-append " + :@ + @@@ + @@@@: + `@@@@@+ + .@@@+@@@ Cyclone + @@ @@ Scheme-to-C compiler + ,@ https://github.com/justinethier/cyclone + '@ + .@ + @@ #@ (c) 2014 Justin Ethier + `@@@#@@@. Version " *version* " + #@@@@@ + +@@@+ + @@# + `@. + +")) + +(define *c-file-header-comment* + (string-append "/** + ** This file was automatically generated by the Cyclone scheme compiler + ** + ** (c) 2014 Justin Ethier + ** Version " *version* " + ** + **/ +")) + +)) diff --git a/scheme/cyclone/libraries.scm b/scheme/cyclone/libraries.scm index 47d473c2..7fd1ea8c 100644 --- a/scheme/cyclone/libraries.scm +++ b/scheme/cyclone/libraries.scm @@ -1,220 +1 @@ -;; -;; Cyclone Scheme -;; Copyright (c) 2014, Justin Ethier -;; All rights reserved. -;; -;; This module implements r7rs libraries. In our compiler, these are used to -;; encapsulate C modules. -;; -;; Initially, this a quicky-and-dirty (for now) implementation of r7rs libraries. -;; -;; TODO: go through functions and ensure consistent naming conventions. -;; probably should also clean up some of the function names, this is -;; not a very clean or nice API at the moment. -;; - -(define (library? ast) - (tagged-list? 'define-library ast)) - -(define (lib:name ast) (cadr ast)) - -;; Convert name (as list of symbols) to a mangled string -(define (lib:name->string name) - (apply string-append (map mangle name))) - -;; Convert library name to a unique symbol -(define (lib:name->symbol name) - (string->symbol - (string-append - "lib-init:" ;; Maybe make this an optional param? Trying to ensure uniqueness - (lib:name->string name)))) - -;; Helper function that returns an empty list as a default value -(define (lib:result result) - (if result result '())) - -;; TODO: most of these below assume 0 or 1 instances of the directive. -;; may need to replace some of these later with filter operations to -;; support more than 1 instance. -(define (lib:exports ast) - (lib:result - (let ((code (assoc 'export (cddr ast)))) - (if code (cdr code) #f)))) -(define (lib:imports ast) - (lib:result - (let ((code (assoc 'import (cddr ast)))) - (if code (cdr code) #f)))) -(define (lib:body ast) - (lib:result - (let ((code (assoc 'begin (cddr ast)))) - (if code (cdr code) #f)))) -(define (lib:includes ast) - (map - (lambda (inc-lst) - (cadr inc-lst)) - (filter - (lambda (code) - (tagged-list? 'include code)) - (cddr ast)))) - -;; TODO: include-ci, cond-expand - -;; Resolve library filename given an import. -;; Assumes ".sld" file extension if one is not specified. -(define (lib:import->filename import . ext) - (let* ((file-ext - (if (null? ext) - ".sld" - (car ext))) - (filename* - (string-append - (apply - string-append - (map - (lambda (i) - (string-append "/" (symbol->string i))) - import)) - file-ext)) - (filename - (substring filename* 1 (string-length filename*)))) - (if (tagged-list? 'scheme import) - (string-append (Cyc-installation-dir 'sld) "/" filename) ;; Built-in library - filename))) - -;; Get path to directory that contains the library -(define (lib:import->path import) - (let* ((import-path (reverse (cdr (reverse import)))) - (path - (apply - string-append - (map - (lambda (i) - (string-append (symbol->string i) "/")) - import-path)))) - (if (tagged-list? 'scheme import) - (string-append (Cyc-installation-dir 'sld) "/" path) ;; Built-in library - path))) - -;; Given a program's import set, resolve each import to its .o file, then -;; process each import recursively to get the .o files that each one of those -;; libs requires. will probably need to prune duplicates from completed list. -;; Longer-term, do we want to look at file timestamps to see if files need to -;; be recompiled? -;(define (lib:imports->objs imports) -; (apply -; append -; (map -; (lambda (i) -; (cons -; (lib:import->filename i ".o") -; (lib:imports->objs (lib:read-imports i)) -; )) -; imports))) - -;; Given a single import from an import-set, open the corresponding -;; library file and retrieve the library's import-set. -(define (lib:read-imports import) - (let* ((dir (lib:import->filename import)) - (fp (open-input-file dir)) - (lib (read-all fp)) - (imports (lib:imports (car lib)))) - (close-input-port fp) - imports)) - -;; Read export list for a given import -(define (lib:import->export-list import) - (let* ((dir (string-append (lib:import->filename import))) - (fp (open-input-file dir)) - (lib (read-all fp)) - (exports (lib:exports (car lib)))) - (close-input-port fp) - exports)) - -;; Take a list of imports and resolve it to the imported vars -(define (lib:resolve-imports imports) - (apply - append - (map - (lambda (import) - (lib:import->export-list import)) - imports))) - -;; Given an import set, get all dependant import names that are required -;; The list of deps is intended to be returned in order, such that the -;; libraries can be initialized properly in sequence. -(define (lib:get-all-import-deps imports) - (letrec ((libraries/deps '()) - (find-deps! - (lambda (import-set) - (for-each - (lambda (i) - (cond - ;; Prevent cycles by only processing new libraries - ((not (assoc i libraries/deps)) - ;; Find all dependencies of i (IE, libraries it imports) - (let ((deps (lib:read-imports i))) - (set! libraries/deps (cons (cons i deps) libraries/deps)) - (find-deps! deps) - )))) - import-set)))) - (find-deps! imports) - ;`((deps ,libraries/deps) ; DEBUG - ; (result ,(lib:get-dep-list libraries/deps))) - (lib:get-dep-list libraries/deps) - )) - -;; Given a list of alists (library-name . imports), return an ordered -;; list of library names such that each lib is encounted after the -;; libraries it imports (it's dependencies). -(define (lib:get-dep-list libs/deps) - ; Overall strategy is: - ; for each library - ; compute index of result that is after any libs that lib imports - ; compute index of result that is before any libs that import lib - ; if there is a 'hole' then insert lib into result in that space - ; otherwise, throw an error (unfortunate but will identify problems) - ; - ; To test, run this from hello directory: - ; (pp (lib:get-all-import-deps '((scheme base) (scheme eval) (scheme base) - ; (scheme read) (scheme eval) (libs lib1) (libs lib2)))) - ; - (let ((result '())) - (for-each - (lambda (lib/dep) - (cond - ((null? result) - (set! result (cons lib/dep '()))) - (else - (let ((idx-my-imports 0) ; lib must be placed after this - (idx-imports-me (length result))) ; lib must be before any libs that import it - (define (loop i) - (cond - ((= i (length result)) - 'done) - (else - ;; Does lib import this one? - (if (and - (> i idx-my-imports) - (member (car (list-ref result i)) (cdr lib/dep))) - (set! idx-my-imports i)) - - ;; Does this one import lib? - (if (and - (< i idx-imports-me) - (member (car lib/dep) (cdr (list-ref result i)))) - (set! idx-imports-me i)) - - (loop (+ i 1))))) - (loop 0) - ;(pp `(JAE DEBUG ,result ,lib/dep ,idx-imports-me ,idx-my-imports)) - (if (<= idx-my-imports idx-imports-me) - (list-insert-at! result lib/dep - (if (= idx-my-imports idx-imports-me) - idx-my-imports - (+ 1 idx-my-imports))) - (error "Internal error: unable to import library")))) - )) - libs/deps) - (map car result))) - - +#f diff --git a/scheme/cyclone/libraries.sld b/scheme/cyclone/libraries.sld index cfbbfd8d..16206fb3 100644 --- a/scheme/cyclone/libraries.sld +++ b/scheme/cyclone/libraries.sld @@ -1,3 +1,17 @@ +;; +;; Cyclone Scheme +;; Copyright (c) 2014, Justin Ethier +;; All rights reserved. +;; +;; This module implements r7rs libraries. In our compiler, these are used to +;; encapsulate C modules. +;; +;; Initially, this a quicky-and-dirty (for now) implementation of r7rs libraries. +;; +;; TODO: go through functions and ensure consistent naming conventions. +;; probably should also clean up some of the function names, this is +;; not a very clean or nice API at the moment. +;; (define-library (scheme cyclone libraries) (import (scheme base) (scheme read) @@ -21,7 +35,211 @@ lib:get-all-import-deps lib:get-dep-list ) - (include "libraries.scm") - ;(begin - ; (define read cyc-read)) -) + (begin + ; (define read cyc-read) + +(define (library? ast) + (tagged-list? 'define-library ast)) + +(define (lib:name ast) (cadr ast)) + +;; Convert name (as list of symbols) to a mangled string +(define (lib:name->string name) + (apply string-append (map mangle name))) + +;; Convert library name to a unique symbol +(define (lib:name->symbol name) + (string->symbol + (string-append + "lib-init:" ;; Maybe make this an optional param? Trying to ensure uniqueness + (lib:name->string name)))) + +;; Helper function that returns an empty list as a default value +(define (lib:result result) + (if result result '())) + +;; TODO: most of these below assume 0 or 1 instances of the directive. +;; may need to replace some of these later with filter operations to +;; support more than 1 instance. +(define (lib:exports ast) + (lib:result + (let ((code (assoc 'export (cddr ast)))) + (if code (cdr code) #f)))) +(define (lib:imports ast) + (lib:result + (let ((code (assoc 'import (cddr ast)))) + (if code (cdr code) #f)))) +(define (lib:body ast) + (lib:result + (let ((code (assoc 'begin (cddr ast)))) + (if code (cdr code) #f)))) +(define (lib:includes ast) + (map + (lambda (inc-lst) + (cadr inc-lst)) + (filter + (lambda (code) + (tagged-list? 'include code)) + (cddr ast)))) + +;; TODO: include-ci, cond-expand + +;; Resolve library filename given an import. +;; Assumes ".sld" file extension if one is not specified. +(define (lib:import->filename import . ext) + (let* ((file-ext + (if (null? ext) + ".sld" + (car ext))) + (filename* + (string-append + (apply + string-append + (map + (lambda (i) + (string-append "/" (symbol->string i))) + import)) + file-ext)) + (filename + (substring filename* 1 (string-length filename*)))) + (if (tagged-list? 'scheme import) + (string-append (Cyc-installation-dir 'sld) "/" filename) ;; Built-in library + filename))) + +;; Get path to directory that contains the library +(define (lib:import->path import) + (let* ((import-path (reverse (cdr (reverse import)))) + (path + (apply + string-append + (map + (lambda (i) + (string-append (symbol->string i) "/")) + import-path)))) + (if (tagged-list? 'scheme import) + (string-append (Cyc-installation-dir 'sld) "/" path) ;; Built-in library + path))) + +;; Given a program's import set, resolve each import to its .o file, then +;; process each import recursively to get the .o files that each one of those +;; libs requires. will probably need to prune duplicates from completed list. +;; Longer-term, do we want to look at file timestamps to see if files need to +;; be recompiled? +;(define (lib:imports->objs imports) +; (apply +; append +; (map +; (lambda (i) +; (cons +; (lib:import->filename i ".o") +; (lib:imports->objs (lib:read-imports i)) +; )) +; imports))) + +;; Given a single import from an import-set, open the corresponding +;; library file and retrieve the library's import-set. +(define (lib:read-imports import) + (let* ((dir (lib:import->filename import)) + (fp (open-input-file dir)) + (lib (read-all fp)) + (imports (lib:imports (car lib)))) + (close-input-port fp) + imports)) + +;; Read export list for a given import +(define (lib:import->export-list import) + (let* ((dir (string-append (lib:import->filename import))) + (fp (open-input-file dir)) + (lib (read-all fp)) + (exports (lib:exports (car lib)))) + (close-input-port fp) + exports)) + +;; Take a list of imports and resolve it to the imported vars +(define (lib:resolve-imports imports) + (apply + append + (map + (lambda (import) + (lib:import->export-list import)) + imports))) + +;; Given an import set, get all dependant import names that are required +;; The list of deps is intended to be returned in order, such that the +;; libraries can be initialized properly in sequence. +(define (lib:get-all-import-deps imports) + (letrec ((libraries/deps '()) + (find-deps! + (lambda (import-set) + (for-each + (lambda (i) + (cond + ;; Prevent cycles by only processing new libraries + ((not (assoc i libraries/deps)) + ;; Find all dependencies of i (IE, libraries it imports) + (let ((deps (lib:read-imports i))) + (set! libraries/deps (cons (cons i deps) libraries/deps)) + (find-deps! deps) + )))) + import-set)))) + (find-deps! imports) + ;`((deps ,libraries/deps) ; DEBUG + ; (result ,(lib:get-dep-list libraries/deps))) + (lib:get-dep-list libraries/deps) + )) + +;; Given a list of alists (library-name . imports), return an ordered +;; list of library names such that each lib is encounted after the +;; libraries it imports (it's dependencies). +(define (lib:get-dep-list libs/deps) + ; Overall strategy is: + ; for each library + ; compute index of result that is after any libs that lib imports + ; compute index of result that is before any libs that import lib + ; if there is a 'hole' then insert lib into result in that space + ; otherwise, throw an error (unfortunate but will identify problems) + ; + ; To test, run this from hello directory: + ; (pp (lib:get-all-import-deps '((scheme base) (scheme eval) (scheme base) + ; (scheme read) (scheme eval) (libs lib1) (libs lib2)))) + ; + (let ((result '())) + (for-each + (lambda (lib/dep) + (cond + ((null? result) + (set! result (cons lib/dep '()))) + (else + (let ((idx-my-imports 0) ; lib must be placed after this + (idx-imports-me (length result))) ; lib must be before any libs that import it + (define (loop i) + (cond + ((= i (length result)) + 'done) + (else + ;; Does lib import this one? + (if (and + (> i idx-my-imports) + (member (car (list-ref result i)) (cdr lib/dep))) + (set! idx-my-imports i)) + + ;; Does this one import lib? + (if (and + (< i idx-imports-me) + (member (car lib/dep) (cdr (list-ref result i)))) + (set! idx-imports-me i)) + + (loop (+ i 1))))) + (loop 0) + ;(pp `(JAE DEBUG ,result ,lib/dep ,idx-imports-me ,idx-my-imports)) + (if (<= idx-my-imports idx-imports-me) + (list-insert-at! result lib/dep + (if (= idx-my-imports idx-imports-me) + idx-my-imports + (+ 1 idx-my-imports))) + (error "Internal error: unable to import library")))) + )) + libs/deps) + (map car result))) + +)) diff --git a/scheme/cyclone/transforms.scm b/scheme/cyclone/transforms.scm index 111e5db3..330766ec 100644 --- a/scheme/cyclone/transforms.scm +++ b/scheme/cyclone/transforms.scm @@ -1,1653 +1,2 @@ -;; -;; Cyclone Scheme -;; Copyright (c) 2014, Justin Ethier -;; All rights reserved. -;; -;; This module performs Scheme-to-Scheme transformations, and also contains -;; various utility functions used by the compiler. -;; - -(cond-expand - (cyclone - ;; Temporary work-around for pp not being implemented yet - (define pretty-print write)) - (else - #f)) - -;; Built-in macros -;; TODO: just a stub, real code would read (define-syntax) -;; from a lib file or such -(define *defined-macros* - (list - (cons 'and - (lambda (expr rename compare) - (cond ((null? (cdr expr))) ;; TODO (?): #t) - ((null? (cddr expr)) (cadr expr)) - (else (list (rename 'if) (cadr expr) - (cons (rename 'and) (cddr expr)) - #f))))) - (cons 'or - (lambda (expr rename compare) - (cond ((null? (cdr expr)) #f) - ((null? (cddr expr)) (cadr expr)) - (else - (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) - (list (rename 'if) (rename 'tmp) - (rename 'tmp) - (cons (rename 'or) (cddr expr)))))))) -; (cons 'let (lambda (exp rename compare) (let=>lambda exp))) - (cons 'let - (lambda (expr rename compare) - (if (null? (cdr expr)) (error "empty let" expr)) - (if (null? (cddr expr)) (error "no let body" expr)) - ((lambda (bindings) - (if (list? bindings) #f (error "bad let bindings")) - (if (every (lambda (x) - (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) - bindings) - ((lambda (vars vals) - (if (symbol? (cadr expr)) - `((,(rename 'lambda) ,vars - (,(rename 'letrec) ((,(cadr expr) - (,(rename 'lambda) ,vars - ,@(cdr (cddr expr))))) - (,(cadr expr) ,@vars))) - ,@vals) - `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) - (map car bindings) - (map cadr bindings)) - (error "bad let syntax" expr))) - (if (symbol? (cadr expr)) (car (cddr expr)) (cadr expr))))) - (cons 'let* - (lambda (expr rename compare) - (if (null? (cdr expr)) (error "empty let*" expr)) - (if (null? (cddr expr)) (error "no let* body" expr)) - (if (null? (cadr expr)) - `(,(rename 'let) () ,@(cddr expr)) - (if (if (list? (cadr expr)) - (every - (lambda (x) - (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) - (cadr expr)) - #f) - `(,(rename 'let) (,(caar (cdr expr))) - (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr))) - (error "bad let* syntax"))))) - (cons 'begin (lambda (exp rename compare) (begin=>let exp))) - (cons 'letrec (lambda (exp rename compare) (letrec=>lets+sets exp))) - (cons 'when (lambda (exp rename compare) - (if (null? (cdr exp)) (error "empty when" exp)) - (if (null? (cddr exp)) (error "no when body" exp)) - `(if ,(cadr exp) - ((lambda () ,@(cddr exp))) - #f))) - (cons 'cond - (lambda (expr rename compare) - (if (null? (cdr expr)) - #f ;(if #f #f) - ((lambda (cl) - (if (compare (rename 'else) (car cl)) - (if (pair? (cddr expr)) - (error "non-final else in cond" expr) - (cons (rename 'begin) (cdr cl))) - (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl))) - (list (list (rename 'lambda) (list (rename 'tmp)) - (list (rename 'if) (rename 'tmp) - (if (null? (cdr cl)) - (rename 'tmp) - (list (car (cddr cl)) (rename 'tmp))) - (cons (rename 'cond) (cddr expr)))) - (car cl)) - (list (rename 'if) - (car cl) - (cons (rename 'begin) (cdr cl)) - (cons (rename 'cond) (cddr expr)))))) - (cadr expr))))) - (cons 'case - (lambda (expr rename compare) - (define (body exprs) - (cond - ((null? exprs) - (rename 'tmp)) - ((compare (rename '=>) (car exprs)) - `(,(cadr exprs) ,(rename 'tmp))) - (else - `(,(rename 'begin) ,@exprs)))) - (define (clause ls) - (cond - ((null? ls) #f) - ((compare (rename 'else) (caar ls)) - (body (cdar ls))) - ((and (pair? (car (car ls))) (null? (cdr (car (car ls))))) - `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) - (,(rename 'quote) ,(car (caar ls)))) - ,(body (cdar ls)) - ,(clause (cdr ls)))) - (else - `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) - (,(rename 'quote) ,(caar ls))) - ,(body (cdar ls)) - ,(clause (cdr ls)))))) - `(let ((,(rename 'tmp) ,(cadr expr))) - ,(clause (cddr expr))))) - (cons 'cond-expand - ;; Based on the cond-expand macro from Chibi scheme - (lambda (expr rename compare) - (define (check x) - (if (pair? x) - (case (car x) - ((and) (every check (cdr x))) - ((or) (any check (cdr x))) - ((not) (not (check (cadr x)))) - ;((library) (eval `(find-module ',(cadr x)) (%meta-env))) - (else (error "cond-expand: bad feature" x))) - (memq x (features)))) - (let expand ((ls (cdr expr))) - (cond ((null? ls)) ; (error "cond-expand: no expansions" expr) - ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) - ((eq? 'else (caar ls)) ;(identifier->symbol (caar ls))) - (if (pair? (cdr ls)) - (error "cond-expand: else in non-final position") - `(,(rename 'begin) ,@(cdar ls)))) - ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) - (else (expand (cdr ls))))))) - (cons 'quasiquote - ;; Based on the quasiquote macro from Chibi scheme - (lambda (expr rename compare) - (define (qq x d) - (cond - ((pair? x) - (cond - ((compare (rename 'unquote) (car x)) - (if (<= d 0) - (cadr x) - (list (rename 'list) (list (rename 'quote) 'unquote) - (qq (cadr x) (- d 1))))) - ((compare (rename 'unquote-splicing) (car x)) - (if (<= d 0) - (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) - (list (rename 'list) (list (rename 'quote) 'unquote-splicing) - (qq (cadr x) (- d 1))))) - ((compare (rename 'quasiquote) (car x)) - (list (rename 'list) (list (rename 'quote) 'quasiquote) - (qq (cadr x) (+ d 1)))) - ((and (<= d 0) (pair? (car x)) - (compare (rename 'unquote-splicing) (caar x))) - (if (null? (cdr x)) - (cadr (car x)) - (list (rename 'append) (cadr (car x)) (qq (cdr x) d)))) - (else - (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) - ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) - ((if (symbol? x) #t (null? x)) (list (rename 'quote) x)) - (else x))) - (qq (cadr expr) 0))) - )) - - -(define (built-in-syms) - '(call-with-values call/cc define)) - -;; Tuning -(define *do-code-gen* #t) ; Generate C code? - -;; Trace -(define *trace-level* 2) -(define (trace level msg pp prefix) - (if (>= *trace-level* level) - (begin - (display "/* ") - (newline) - (display prefix) - (pp msg) - (display " */") - (newline)))) -(define (trace:error msg) (trace 1 msg pretty-print "")) -(define (trace:warn msg) (trace 2 msg pretty-print "")) -(define (trace:info msg) (trace 3 msg pretty-print "")) -(define (trace:debug msg) (trace 4 msg display "DEBUG: ")) - -(define (cyc:error msg) - (error msg) - (exit 1)) - -;; File Utilities - -;; Get the basename of a file, without the extension. -;; EG: "file.scm" ==> "file" -(define (basename filename) - (let ((pos (list-index #\. (reverse (string->list filename))))) - (if (= pos -1) - filename - (substring filename 0 (- (string-length filename) pos 1))))) - -;; Find the first occurence of e within the given list. -;; Returns -1 if e is not found. -(define list-index - (lambda (e lst) - (if (null? lst) - -1 - (if (eq? (car lst) e) - 0 - (if (= (list-index e (cdr lst)) -1) - -1 - (+ 1 (list-index e (cdr lst)))))))) - - -;; Utilities. - -(cond-expand - (cyclone - ; member : symbol sorted-set[symbol] -> boolean - (define (member sym S) - (if (not (pair? S)) - #f - (if (eq? sym (car S)) - #t - (member sym (cdr S)))))) - (else #f)) - -(cond-expand - (cyclone - ; void : -> void - (define (void) (if #f #t))) - (else #f)) - -; gensym-count : integer -(define gensym-count 0) - -; gensym : symbol -> symbol -(define gensym (lambda params - (if (null? params) - (begin - (set! gensym-count (+ gensym-count 1)) - (string->symbol (string-append - "$" - (number->string gensym-count)))) - (begin - (set! gensym-count (+ gensym-count 1)) - (string->symbol (string-append - (if (symbol? (car params)) - (symbol->string (car params)) - (car params)) - "$" - (number->string gensym-count))))))) - -; symbol boolean -(define (symbolstring sym1) - (symbol->string sym2))) - -; insert : symbol sorted-set[symbol] -> sorted-set[symbol] -(define (insert sym S) - (if (not (pair? S)) - (list sym) - (cond - ((eq? sym (car S)) S) - ((symbol sorted-set[symbol] -(define (remove sym S) - (if (not (pair? S)) - '() - (if (eq? (car S) sym) - (cdr S) - (cons (car S) (remove sym (cdr S)))))) - -; union : sorted-set[symbol] sorted-set[symbol] -> sorted-set[symbol] -(define (union set1 set2) - ; NOTE: This should be implemented as merge for efficiency. - (if (not (pair? set1)) - set2 - (insert (car set1) (union (cdr set1) set2)))) - -; difference : sorted-set[symbol] sorted-set[symbol] -> sorted-set[symbol] -(define (difference set1 set2) - ; NOTE: This can be similarly optimized. - (if (not (pair? set2)) - set1 - (difference (remove (car set2) set1) (cdr set2)))) - -; reduce : (A A -> A) list[A] A -> A -(define (reduce f lst init) - (if (not (pair? lst)) - init - (reduce f (cdr lst) (f (car lst) init)))) - -; azip : list[A] list[B] -> alist[A,B] -(define (azip list1 list2) - (if (and (pair? list1) (pair? list2)) - (cons (list (car list1) (car list2)) - (azip (cdr list1) (cdr list2))) - '())) - -; assq-remove-key : alist[A,B] A -> alist[A,B] -(define (assq-remove-key env key) - (if (not (pair? env)) - '() - (if (eq? (car (car env)) key) - (assq-remove-key (cdr env) key) - (cons (car env) (assq-remove-key (cdr env) key))))) - -; assq-remove-keys : alist[A,B] list[A] -> alist[A,B] -(define (assq-remove-keys env keys) - (if (not (pair? keys)) - env - (assq-remove-keys (assq-remove-key env (car keys)) (cdr keys)))) - - -;; Data type predicates and accessors. - -; const? : exp -> boolean -(define (const? exp) - (or (integer? exp) - (real? exp) - (string? exp) - (vector? exp) - (char? exp) - (boolean? exp))) - -; ref? : exp -> boolean -(define (ref? exp) - (symbol? exp)) - -; quote? : exp -> boolean -(define (quote? exp) - (tagged-list? 'quote exp)) - -; let? : exp -> boolean -(define (let? exp) - (tagged-list? 'let exp)) - -; let->bindings : let-exp -> alist[symbol,exp] -(define (let->bindings exp) - (cadr exp)) - -; let->exp : let-exp -> exp -(define (let->exp exp) - (cddr exp)) - -; let->bound-vars : let-exp -> list[symbol] -(define (let->bound-vars exp) - (map car (cadr exp))) - -; let->args : let-exp -> list[exp] -(define (let->args exp) - (map cadr (cadr exp))) - -; letrec? : exp -> boolean -(define (letrec? exp) - (tagged-list? 'letrec exp)) - -; letrec->bindings : letrec-exp -> alist[symbol,exp] -(define (letrec->bindings exp) - (cadr exp)) - -; letrec->exp : letrec-exp -> exp -(define (letrec->exp exp) - (cddr exp)) - -; letrec->exp : letrec-exp -> list[symbol] -(define (letrec->bound-vars exp) - (map car (cadr exp))) - -; letrec->exp : letrec-exp -> list[exp] -(define (letrec->args exp) - (map cadr (cadr exp))) - -(define (lambda-varargs? exp) - (and (lambda? exp) - (or (symbol? (lambda->formals exp)) - (and (pair? (lambda->formals exp)) - (not (list? (lambda->formals exp))))))) - -; lambda->formals : lambda-exp -> list[symbol] -(define (lambda->formals exp) - (cadr exp)) - -(define (lambda-varargs? exp) - (let ((type (lambda-formals-type exp))) - (or (equal? type 'args:varargs) - (equal? type 'args:fixed-with-varargs)))) - -(define (lambda-varargs-var exp) - (if (lambda-varargs? exp) - (if (equal? (lambda-formals-type exp) 'args:varargs) - (lambda->formals exp) ; take symbol directly - (car (reverse (lambda-formals->list exp)))) ; Last arg is varargs - #f)) - -(define (lambda-formals-type exp) - (let ((args (lambda->formals exp))) - (cond - ((symbol? args) 'args:varargs) - ((list? args) 'args:fixed) - ((pair? args) 'args:fixed-with-varargs) - (else - (error `(Unexpected formals list in lambda-formals-type: ,args)))))) - -(define (lambda-formals->list exp) - (if (lambda-varargs? exp) - (let ((args (lambda->formals exp))) - (if (symbol? args) - (list args) - (pair->list args))) - (lambda->formals exp))) - -;; Minimum number of required arguments for a lambda -(define (lambda-num-args exp) - (let ((type (lambda-formals-type exp)) - (num (length (lambda-formals->list exp)))) - (cond - ((equal? type 'args:varargs) - -1) ;; Unlimited - ((equal? type 'args:fixed-with-varargs) - (- num 1)) ;; Last arg is optional - (else - num)))) - -;; Repack a list of args (symbols) into lambda formals, by type -;; assumes args is a proper list -(define (list->lambda-formals args type) - (cond - ((eq? type 'args:fixed) args) - ((eq? type 'args:fixed-with-varargs) (list->pair args)) - ((eq? type 'args:varargs) - (if (> (length args) 1) - (error `(Too many args for varargs ,args)) - (car args))) - (else (error `(Unexpected type ,type))))) - -;; Create a proper copy of an improper list -;; EG: (1 2 . 3) ==> (1 2 3) -(define (pair->list p) - (let loop ((lst p)) - (if (not (pair? lst)) - (cons lst '()) - (cons (car lst) (loop (cdr lst)))))) - -;; Create an improper copy of a proper list -(define (list->pair l) - (let loop ((lst l)) - (cond - ((not (pair? lst)) - lst) - ((null? (cdr lst)) - (car lst)) - (else - (cons (car lst) (loop (cdr lst))))))) - -; lambda->exp : lambda-exp -> exp -(define (lambda->exp exp) - (cddr exp)) ;; JAE - changed from caddr, so we can handle multiple expressions - -; if->condition : if-exp -> exp -(define (if->condition exp) - (cadr exp)) - -; if->then : if-exp -> exp -(define (if->then exp) - (caddr exp)) - -;; if-else? : if-exp -> bool -;; Determines whether an if expression has an else clause -(define (if-else? exp) - (and (tagged-list? 'if exp) - (> (length exp) 3))) - -; if->else : if-exp -> exp -(define (if->else exp) - (cadddr exp)) - -; app? : exp -> boolean -(define (app? exp) - (pair? exp)) - -; app->fun : app-exp -> exp -(define (app->fun exp) - (car exp)) - -; app->args : app-exp -> list[exp] -(define (app->args exp) - (cdr exp)) - -; prim? : exp -> boolean -(define (prim? exp) - (member exp *primitives*)) - -(define *primitives* '( - Cyc-global-vars - Cyc-get-cvar - Cyc-set-cvar! - Cyc-cvar? ;; Cyclone-specific - Cyc-has-cycle? - Cyc-stdout - Cyc-stdin - Cyc-stderr - + - - - * - / - = - > - < - >= - <= - apply - %halt - exit - system - command-line-arguments - Cyc-installation-dir - Cyc-default-exception-handler - Cyc-current-exception-handler - cons - cell-get - set-global! - set-cell! - cell - eq? - eqv? - equal? - assoc - assq - assv - memq - memv - member - length - set-car! - set-cdr! - car - cdr - caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr - caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - char->integer - integer->char - string->number - string-append - string-cmp - list->string - string->symbol - symbol->string - number->string - string-length - string-ref - string-set! - substring - make-vector - list->vector - vector-length - vector-ref - vector-set! - boolean? - char? - eof-object? - null? - number? - real? - integer? - pair? - port? - procedure? - vector? - string? - symbol? - open-input-file - open-output-file - close-port - close-input-port - close-output-port - Cyc-flush-output-port - file-exists? - delete-file - read-char - peek-char - Cyc-read-line - Cyc-write-char - Cyc-write - Cyc-display)) - -;; Constant Folding -;; Is a primitive being applied in such a way that it can be -;; evaluated at compile time? -(define (precompute-prim-app? ast) - (and - (pair? ast) - (prim? (car ast)) - ;; Does not make sense to precompute these - (not (member (car ast) - '(Cyc-global-vars - Cyc-get-cvar - Cyc-set-cvar! - Cyc-cvar? - apply - %halt - exit - system - command-line-arguments - Cyc-installation-dir - Cyc-default-exception-handler - Cyc-current-exception-handler - cell-get - set-global! - set-cell! - cell - set-car! - set-cdr! - string-set! - string->symbol ;; Could be mistaken for an identifier - make-vector - ;; I/O must be done at runtime for side effects: - Cyc-stdout - Cyc-stdin - Cyc-stderr - open-input-file - open-output-file - close-port - close-input-port - close-output-port - Cyc-flush-output-port - file-exists? - delete-file - read-char - peek-char - Cyc-read-line - Cyc-write-char - Cyc-write - Cyc-display))) - (call/cc - (lambda (return) - (for-each - (lambda (expr) - (if (or (vector? expr) - (not (const? expr))) - (return #f))) - (cdr ast)) - #t)))) - -(define (prim-call? exp) - (and (list? exp) (prim? (car exp)))) - -; begin->exps : begin-exp -> list[exp] -(define (begin->exps exp) - (cdr exp)) - -; define : exp -> boolean -(define (define? exp) - (tagged-list? 'define exp)) - -(define (define-lambda? exp) - (let ((var (cadr exp))) - (or - ;; Standard function - (and (list? var) - (> (length var) 0) - (symbol? (car var))) - ;; Varargs function - (and (pair? var) - (symbol? (car var)))))) - -(define (define->lambda exp) - (cond - ((define-lambda? exp) - (let ((var (caadr exp)) - (args (cdadr exp)) - (body (cddr exp))) - `(define ,var (lambda ,args ,@body)))) - (else exp))) - -; define->var : define-exp -> var -(define (define->var exp) - (cond - ((define-lambda? exp) - (caadr exp)) - (else - (cadr exp)))) - -; define->exp : define-exp -> exp -(define (define->exp exp) - (cddr exp)) - -; set! : exp -> boolean -(define (set!? exp) - (tagged-list? 'set! exp)) - -; set!->var : set!-exp -> var -(define (set!->var exp) - (cadr exp)) - -; set!->exp : set!-exp -> exp -(define (set!->exp exp) - (caddr exp)) - -; closure? : exp -> boolean -(define (closure? exp) - (tagged-list? 'closure exp)) - -; closure->lam : closure-exp -> exp -(define (closure->lam exp) - (cadr exp)) - -; closure->env : closure-exp -> exp -(define (closure->env exp) - (caddr exp)) - -(define (closure->fv exp) - (cddr exp)) - -; env-make? : exp -> boolean -(define (env-make? exp) - (tagged-list? 'env-make exp)) - -; env-make->id : env-make-exp -> env-id -(define (env-make->id exp) - (cadr exp)) - -; env-make->fields : env-make-exp -> list[symbol] -(define (env-make->fields exp) - (map car (cddr exp))) - -; env-make->values : env-make-exp -> list[exp] -(define (env-make->values exp) - (map cadr (cddr exp))) - -; env-get? : exp -> boolen -(define (env-get? exp) - (tagged-list? 'env-get exp)) - -; env-get->id : env-get-exp -> env-id -(define (env-get->id exp) - (cadr exp)) - -; env-get->field : env-get-exp -> symbol -(define (env-get->field exp) - (caddr exp)) - -; env-get->env : env-get-exp -> exp -(define (env-get->env exp) - (cadddr exp)) - -; set-cell!? : set-cell!-exp -> boolean -(define (set-cell!? exp) - (tagged-list? 'set-cell! exp)) - -; set-cell!->cell : set-cell!-exp -> exp -(define (set-cell!->cell exp) - (cadr exp)) - -; set-cell!->value : set-cell!-exp -> exp -(define (set-cell!->value exp) - (caddr exp)) - -; cell? : exp -> boolean -(define (cell? exp) - (tagged-list? 'cell exp)) - -; cell->value : cell-exp -> exp -(define (cell->value exp) - (cadr exp)) - -; cell-get? : exp -> boolean -(define (cell-get? exp) - (tagged-list? 'cell-get exp)) - -; cell-get->cell : cell-exp -> exp -(define (cell-get->cell exp) - (cadr exp)) - - - -;; Syntax manipulation. - -;; ; substitute-var : alist[var,exp] ref-exp -> exp -;; (define (substitute-var env var) -;; (let ((sub (assq var env))) -;; (if sub -;; (cadr sub) -;; var))) -;; -;; ; substitute : alist[var,exp] exp -> exp -;; (define (substitute env exp) -;; -;; (define (substitute-with env) -;; (lambda (exp) -;; (substitute env exp))) -;; -;; (cond -;; ; Core forms: -;; ((null? env) exp) -;; ((const? exp) exp) -;; ((prim? exp) exp) -;; ((ref? exp) (substitute-var env exp)) -;; ((lambda? exp) `(lambda ,(lambda->formals exp) -;; ,@(map (lambda (body-exp) -;; ;; TODO: could be more efficient -;; (substitute -;; (assq-remove-keys env (lambda->formals exp)) -;; body-exp)) -;; (lambda->exp exp)))) -;; ((set!? exp) `(set! ,(substitute-var env (set!->var exp)) -;; ,(substitute env (set!->exp exp)))) -;; ((if? exp) `(if ,(substitute env (if->condition exp)) -;; ,(substitute env (if->then exp)) -;; ,(substitute env (if->else exp)))) -;; -;; ; Sugar: -;; ((let? exp) `(let ,(azip (let->bound-vars exp) -;; (map (substitute-with env) (let->args exp))) -;; ,(substitute (assq-remove-keys env (let->bound-vars exp)) -;; (car (let->exp exp))))) -;; ((letrec? exp) (let ((new-env (assq-remove-keys env (letrec->bound-vars exp)))) -;; `(letrec ,(azip (letrec->bound-vars exp) -;; (map (substitute-with new-env) -;; (letrec->args exp))) -;; ,(substitute new-env (car (letrec->exp exp)))))) -;; ((begin? exp) (cons 'begin (map (substitute-with env) (begin->exps exp)))) -;; -;; ; IR (1): -;; ((cell? exp) `(cell ,(substitute env (cell->value exp)))) -;; ((cell-get? exp) `(cell-get ,(substitute env (cell-get->cell exp)))) -;; ((set-cell!? exp) `(set-cell! ,(substitute env (set-cell!->cell exp)) -;; ,(substitute env (set-cell!->value exp)))) -;; -;; ; IR (2): -;; ((closure? exp) `(closure ,(substitute env (closure->lam exp)) -;; ,(substitute env (closure->env exp)))) -;; ((env-make? exp) `(env-make ,(env-make->id exp) -;; ,@(azip (env-make->fields exp) -;; (map (substitute-with env) -;; (env-make->values exp))))) -;; ((env-get? exp) `(env-get ,(env-get->id exp) -;; ,(env-get->field exp) -;; ,(substitute env (env-get->env exp)))) -;; -;; ; Application: -;; ((app? exp) (map (substitute-with env) exp)) -;; (else (error "unhandled expression type in substitution: " exp)))) -;; - -;; Macro expansion - -; expand : exp -> exp -(define (expand exp) - (cond - ((const? exp) exp) - ((prim? exp) exp) - ((ref? exp) exp) - ((quote? exp) exp) - ((lambda? exp) `(lambda ,(lambda->formals exp) - ,@(map expand (lambda->exp exp)))) - ((define? exp) (if (define-lambda? exp) - (expand (define->lambda exp)) - `(define ,(expand (define->var exp)) - ,@(expand (define->exp exp))))) - ((set!? exp) `(set! ,(expand (set!->var exp)) - ,(expand (set!->exp exp)))) - ((if? exp) `(if ,(expand (if->condition exp)) - ,(expand (if->then exp)) - ,(if (if-else? exp) - (expand (if->else exp)) - ;; Insert default value for missing else clause - ;; FUTURE: append the empty (unprinted) value - ;; instead of #f - #f))) - ((app? exp) - (cond -;; TODO: could check for a define-syntax here and load into memory -;; if found. would then want to continue expanding. may need to -;; return some value such as #t or nil as a placeholder, since the -;; define-syntax form would not be carried forward in the compiled code - ((define-syntax? exp) ;; TODO: not good enough, should do error checking, and make sure list is big enough for cadr - ;(trace:info `(define-syntax ,exp)) - (let* ((name (cadr exp)) - (trans (caddr exp)) - (body (cadr trans))) - (set! *defined-macros* (cons (cons name body) *defined-macros*)) - #t)) - ((macro? exp *defined-macros*) - (expand ;; Could expand into another macro - (macro-expand exp *defined-macros*))) - (else - (map expand exp)))) - (else - (error "unknown exp: " exp)))) - -; TODO: eventually, merge below functions with above *defined-macros* defs and -;; replace both with a lib of (define-syntax) constructs - -;; let=>lambda : let-exp -> app-exp -;(define (let=>lambda exp) -; (if (let? exp) -; (let ((vars (map car (let->bindings exp))) -; (args (map cadr (let->bindings exp)))) -; `((lambda (,@vars) ,@(let->exp exp)) ,@args)) -; exp)) - -; letrec=>lets+sets : letrec-exp -> exp -(define (letrec=>lets+sets exp) - (if (letrec? exp) - (let* ((bindings (letrec->bindings exp)) - (namings (map (lambda (b) (list (car b) #f)) bindings)) - (names (letrec->bound-vars exp)) - (sets (map (lambda (binding) - (cons 'set! binding)) - bindings)) - (args (letrec->args exp))) - `(let ,namings - (begin ,@(append sets (letrec->exp exp))))))) -;; NOTE: chibi uses the following macro. turns vars into defines? -;;(define-syntax letrec -;; (er-macro-transformer -;; (lambda (expr rename compare) -;; ((lambda (defs) -;; `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) -;; (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) -;; - -; begin=>let : begin-exp -> let-exp -(define (begin=>let exp) - (define (singlet? l) - (and (list? l) - (= (length l) 1))) - - (define (dummy-bind exps) - (cond - ((singlet? exps) (car exps)) - - ; JAE - should be fine until CPS phase - ((pair? exps) - `((lambda () - ,@exps))))) - ;((pair? exps) `(let (($_ ,(car exps))) - ; ,(dummy-bind (cdr exps)))))) - (dummy-bind (begin->exps exp))) - - -;; Top-level analysis - -; Separate top-level defines (globals) from other expressions -; -; This function extracts out non-define statements, and adds them to -; a "main" after the defines. -; -(define (isolate-globals exp program? lib-name) - (let loop ((top-lvl exp) - (globals '()) - (exprs '())) - (cond - ((null? top-lvl) - (append - (reverse globals) - (expand - (cond - (program? - ;; This is the main program, keep top level. - ;; Use 0 here (and below) to ensure a meaningful top-level - `((begin 0 ,@(reverse exprs))) - ) - (else - ;; This is a library, keep inits in their own function - `((define ,(lib:name->symbol lib-name) - (lambda () 0 ,@(reverse exprs)))))) - ))) - (else - (cond - ((define? (car top-lvl)) - (cond - ;; Global is redefined, convert it to a (set!) at top-level - ((has-global? globals (define->var (car top-lvl))) - (loop (cdr top-lvl) - globals - (cons - `(set! ,(define->var (car top-lvl)) - ,@(define->exp (car top-lvl))) - exprs))) - ;; Form cannot be properly converted to CPS later on, so split it up - ;; into two parts - use the define to initialize it to false (CPS is fine), - ;; and place the expression into a top-level (set!), which can be - ;; handled by the existing CPS conversion. - ((or - ;; TODO: the following line may not be good enough, a global assigned to another - ;; global may still be init'd to nil if the order is incorrect in the "top level" - ;; initialization code. - (symbol? (car (define->exp (car top-lvl)))) ;; TODO: put these at the end of top-lvl??? - (and (list? (car (define->exp (car top-lvl)))) - (not (lambda? (car (define->exp (car top-lvl))))))) - (loop (cdr top-lvl) - (cons - `(define ,(define->var (car top-lvl)) #f) - globals) - (cons - `(set! ,(define->var (car top-lvl)) - ,@(define->exp (car top-lvl))) - exprs))) - ;; First time we've seen this define, add it and keep going - (else - (loop (cdr top-lvl) - (cons (car top-lvl) globals) - exprs)))) - (else - (loop (cdr top-lvl) - globals - (cons (car top-lvl) exprs)))))))) - -; Has global already been found? -; -; NOTE: -; Linear search may get expensive (n^2), but with a modest set of -; define statements hopefully it will be acceptable. If not, will need -; to use a faster data structure (EG: map or hashtable) -(define (has-global? exp var) - (call/cc - (lambda (return) - (for-each - (lambda (e) - (if (and (define? e) - (equal? (define->var e) var)) - (return #t))) - exp) - #f))) - -; Compute list of global variables based on expression in top-level form -; EG: (def, def, expr, ...) -(define (global-vars exp) - (let ((globals '())) - (for-each - (lambda (e) - (if (define? e) - (set! globals (cons (define->var e) globals)))) - exp) - globals)) - -;; Remove global variables that are not used by the rest of the program. -;; Many improvements can be made, including: -;; -;; TODO: remove unused locals -(define (filter-unused-variables asts lib-exports) - (define (do-filter code) - (let ((all-fv (apply ;; More efficient way to do this? - append ;; Could use delete-duplicates - (map - (lambda (ast) - (if (define? ast) - (let ((var (define->var ast))) - ;; Do not keep global that refers to itself - (filter - (lambda (v) - (not (equal? v var))) - (free-vars (define->exp ast)))) - (free-vars ast))) - code)))) - (filter - (lambda (ast) - (or (not (define? ast)) - (member (define->var ast) all-fv) - (member (define->var ast) lib-exports))) - code))) - ;; Keep filtering until no more vars are removed - (define (loop code) - (let ((new-code (do-filter code))) - (if (> (length code) (length new-code)) - (loop new-code) - new-code))) - (loop asts)) - -;; Syntactic analysis. - -; free-vars : exp -> sorted-set[var] -(define (free-vars ast . opts) - (define bound-only? - (and (not (null? opts)) - (car opts))) - - (define (search exp) - (cond - ; Core forms: - ((const? exp) '()) - ((prim? exp) '()) - ((quote? exp) '()) - ((ref? exp) (if bound-only? '() (list exp))) - ((lambda? exp) - (difference (reduce union (map search (lambda->exp exp)) '()) - (lambda-formals->list exp))) - ((if? exp) (union (search (if->condition exp)) - (union (search (if->then exp)) - (search (if->else exp))))) - ((define? exp) (union (list (define->var exp)) - (search (define->exp exp)))) - ((set!? exp) (union (list (set!->var exp)) - (search (set!->exp exp)))) - ; Application: - ((app? exp) (reduce union (map search exp) '())) - (else (error "unknown expression: " exp)))) - (search ast)) - - - - - -;; Mutable variable analysis and elimination. - -;; Mutables variables analysis and elimination happens -;; on a desugared Intermediate Language (1). - -;; Mutable variable analysis turns mutable variables -;; into heap-allocated cells: - -;; For any mutable variable mvar: - -;; (lambda (... mvar ...) body) -;; => -;; (lambda (... $v ...) -;; (let ((mvar (cell $v))) -;; body)) - -;; (set! mvar value) => (set-cell! mvar value) - -;; mvar => (cell-get mvar) - -; mutable-variables : list[symbol] -(define mutable-variables '()) - -(define (clear-mutables) - (set! mutable-variables '())) - -; mark-mutable : symbol -> void -(define (mark-mutable symbol) - (set! mutable-variables (cons symbol mutable-variables))) - -; is-mutable? : symbol -> boolean -(define (is-mutable? symbol) - (define (is-in? S) - (if (not (pair? S)) - #f - (if (eq? (car S) symbol) - #t - (is-in? (cdr S))))) - (is-in? mutable-variables)) - -; analyze-mutable-variables : exp -> void -(define (analyze-mutable-variables exp) - (cond - ; Core forms: - ((const? exp) (void)) - ((prim? exp) (void)) - ((ref? exp) (void)) - ((quote? exp) (void)) - ((lambda? exp) (begin - (map analyze-mutable-variables (lambda->exp exp)) - (void))) - ((set!? exp) (begin (mark-mutable (set!->var exp)) - (analyze-mutable-variables (set!->exp exp)))) - ((if? exp) (begin - (analyze-mutable-variables (if->condition exp)) - (analyze-mutable-variables (if->then exp)) - (analyze-mutable-variables (if->else exp)))) - - ; Sugar: - ((let? exp) (begin - (map analyze-mutable-variables (map cadr (let->bindings exp))) - (map analyze-mutable-variables (let->exp exp)) - (void))) - ((letrec? exp) (begin - (map analyze-mutable-variables (map cadr (letrec->bindings exp))) - (map analyze-mutable-variables (letrec->exp exp)) - (void))) - ((begin? exp) (begin - (map analyze-mutable-variables (begin->exps exp)) - (void))) - - ; Application: - ((app? exp) (begin - (map analyze-mutable-variables exp) - (void))) - (else (error "unknown expression type: " exp)))) - - -; wrap-mutables : exp -> exp -(define (wrap-mutables exp globals) - - (define (wrap-mutable-formals formals body-exp) - (if (not (pair? formals)) - body-exp - (if (is-mutable? (car formals)) - `((lambda (,(car formals)) - ,(wrap-mutable-formals (cdr formals) body-exp)) - (cell ,(car formals))) - (wrap-mutable-formals (cdr formals) body-exp)))) - - (cond - ; Core forms: - ((const? exp) exp) - ((ref? exp) (if (and (not (member exp globals)) - (is-mutable? exp)) - `(cell-get ,exp) - exp)) - ((prim? exp) exp) - ((quote? exp) exp) - ((lambda? exp) `(lambda ,(lambda->formals exp) - ,(wrap-mutable-formals (lambda-formals->list exp) - (wrap-mutables (car (lambda->exp exp)) globals)))) ;; Assume single expr in lambda body, since after CPS phase - ((set!? exp) `(,(if (member (set!->var exp) globals) - 'set-global! - 'set-cell!) - ,(set!->var exp) - ,(wrap-mutables (set!->exp exp) globals))) - ((if? exp) `(if ,(wrap-mutables (if->condition exp) globals) - ,(wrap-mutables (if->then exp) globals) - ,(wrap-mutables (if->else exp) globals))) - - ; Application: - ((app? exp) (map (lambda (e) (wrap-mutables e globals)) exp)) - (else (error "unknown expression type: " exp)))) - -;; Alpha conversion -;; (aka alpha renaming) -;; -;; This phase is intended to rename identifiers to preserve lexical scoping -;; -;; TODO: does not properly handle renaming builtin functions, would probably need to -;; pass that renaming information downstream -(define (alpha-convert ast globals return-unbound) - ;; Initialize top-level variables - (define (initialize-top-level-vars ast fv) - (if (> (length fv) 0) - ;; Free variables found, set initial values - `((lambda ,fv ,ast) - ,@(map (lambda (_) #f) fv)) - ast)) - - ;; Find any defined variables in the given code block - (define (find-defined-vars ast) - (filter - (lambda (expr) - (not (null? expr))) - (map - (lambda (expr) - (if (define? expr) - (define->var expr) - '())) - ast))) - - ;; Take a list of identifiers and generate a list of - ;; renamed pairs, EG: (var . renamed-var) - (define (make-a-lookup vars) - (map - (lambda (a) (cons a (gensym a))) - vars)) - - ;; Wrap any defined variables in a lambda, so they can be initialized - (define (initialize-defined-vars ast vars) - (if (> (length vars) 0) - `(((lambda ,vars ,@ast) - ,@(map (lambda (_) #f) vars))) - ast)) - - ;; Perform actual alpha conversion - (define (convert ast renamed) -;(write `(DEBUG convert ,ast)) -;(write (newline)) - (cond - ((const? ast) ast) - ((quote? ast) ast) - ((ref? ast) - (let ((renamed (assoc ast renamed))) - (cond - (renamed - (cdr renamed)) - (else ast)))) - ((define? ast) - ;; Only internal defines at this point, of form: (define ident value) - `(set! ,@(map (lambda (a) (convert a renamed)) (cdr ast)))) - ((set!? ast) - ;; Without define, we have no way of knowing if this was a - ;; define or a set prior to this phase. But no big deal, since - ;; the set will still work in either case, so no need to check - `(set! ,@(map (lambda (a) (convert a renamed)) (cdr ast)))) - ((if? ast) - ;; Add a failsafe here in case macro expansion added more - ;; incomplete if expressions. - ;; FUTURE: append the empty (unprinted) value instead of #f - (if (if-else? ast) - `(if ,@(map (lambda (a) (convert a renamed)) (cdr ast))) - (convert (append ast '(#f)) renamed))) - ((prim-call? ast) - (let ((converted - (cons (car ast) - (map (lambda (a) (convert a renamed)) - (cdr ast))))) - (if (precompute-prim-app? converted) - (eval converted) ;; OK, evaluate at compile time - converted))) - ((lambda? ast) - (let* ((args (lambda-formals->list ast)) - (ltype (lambda-formals-type ast)) - (a-lookup (map (lambda (a) (cons a (gensym a))) args)) - (body (lambda->exp ast)) - (define-vars (find-defined-vars body)) - (defines-a-lookup (make-a-lookup define-vars)) - ) - `(lambda - ,(list->lambda-formals - (map (lambda (p) (cdr p)) a-lookup) - ltype) - ,@(initialize-defined-vars - (convert - body - (append a-lookup defines-a-lookup renamed)) - (map (lambda (p) (cdr p)) defines-a-lookup))))) - ((app? ast) - (map (lambda (a) (convert a renamed)) ast)) - (else - (error "unhandled expression: " ast)))) - - (let* ((fv (difference (free-vars ast) globals)) - ;; Only find set! and lambda vars - (bound-vars (union globals (free-vars ast #t))) - ;; vars never bound in prog, but could be built-in - (unbound-vars (difference fv bound-vars)) - ;; vars we know nothing about - error! - (unknown-vars (difference unbound-vars (built-in-syms))) - ) - (cond - ((> (length unknown-vars) 0) - (let ((unbound-to-return (list))) - (if (member 'eval unknown-vars) - (set! unbound-to-return (cons 'eval unbound-to-return))) - (if (or (member 'read unknown-vars) - (member 'read-all unknown-vars)) - (set! unbound-to-return (cons 'read unbound-to-return))) - (if (and (> (length unbound-to-return) 0) - (= (length unknown-vars) (length unbound-to-return))) - (return-unbound unbound-to-return) - ;; TODO: should not report above (eval read) as errors - (error "Unbound variable(s)" unknown-vars)))) - ((define? ast) - ;; Deconstruct define so underlying code can assume internal defines - (let ((body (car ;; Only one member by now - (define->exp ast)))) -;(write `(DEBUG body ,body)) - (cond - ((lambda? body) - (let* ((args (lambda-formals->list body)) - (ltype (lambda-formals-type body)) - (a-lookup (map (lambda (a) (cons a (gensym a))) args)) - (define-vars (find-defined-vars (lambda->exp body))) - (defines-a-lookup (make-a-lookup define-vars)) - ) - ;; Any internal defines need to be initialized within the lambda, - ;; so the lambda formals are preserved. So we need to deconstruct - ;; the defined lambda and then reconstruct it, with #f placeholders - ;; for any internal definitions. - ;; - ;; Also, initialize-top-level-vars cannot be used directly due to - ;; the required splicing. - `(define - ,(define->var ast) - (lambda - ,(list->lambda-formals - (map (lambda (p) (cdr p)) a-lookup) - ltype) - ,@(convert (let ((fv* (union - define-vars - (difference fv (built-in-syms)))) - (ast* (lambda->exp body))) - (if (> (length fv*) 0) - `(((lambda ,fv* ,@ast*) - ,@(map (lambda (_) #f) fv*))) - ast*)) - (append a-lookup defines-a-lookup)))))) - (else - `(define - ,(define->var ast) - ,@(convert (initialize-top-level-vars - (define->exp ast) - (difference fv (built-in-syms))) - (list))))))) - (else - (convert (initialize-top-level-vars - ast - (difference fv (built-in-syms))) - (list)))))) - -;; CPS conversion -;; -;; This is a port of code from the 90-minute Scheme->C Compiler by Marc Feeley -;; -;; Convert intermediate code to continuation-passing style, to allow for -;; first-class continuations and call/cc -;; - -(define (cps-convert ast) - - (define (cps ast cont-ast) - (cond - ((const? ast) - (list cont-ast ast)) - - ((ref? ast) - (list cont-ast ast)) - - ((quote? ast) - (list cont-ast ast)) - - ((set!? ast) - (cps-list (cddr ast) ;; expr passed to set - (lambda (val) - (list cont-ast - `(set! ,(cadr ast) ,@val))))) ;; cadr => variable - - ((if? ast) - (let ((xform - (lambda (cont-ast) - (cps-list (list (cadr ast)) - (lambda (test) - (list 'if - (car test) - (cps (caddr ast) - cont-ast) - (cps (cadddr ast) - cont-ast))))))) - (if (ref? cont-ast) ; prevent combinatorial explosion - (xform cont-ast) - (let ((k (gensym 'k))) - (list (list 'lambda - (list k) - (xform k)) - cont-ast))))) - - ((prim-call? ast) - (cps-list (cdr ast) ; args to primitive function - (lambda (args) - (list cont-ast - `(,(car ast) ; op - ,@args))))) - - ((lambda? ast) - (let ((k (gensym 'k)) - (ltype (lambda-formals-type ast))) - (list cont-ast - `(lambda - ,(list->lambda-formals - (cons k (cadr ast)) ; lam params - (if (equal? ltype 'args:varargs) - 'args:fixed-with-varargs ;; OK? promote due to k - ltype)) - ,(cps-seq (cddr ast) k))))) - -; -; TODO: begin is expanded already by desugar code... better to do it here? -; ((seq? ast) -; (cps-seq (ast-subx ast) cont-ast)) - - ((app? ast) - (let ((fn (app->fun ast))) - (cond - ((lambda? fn) - (cps-list (app->args ast) - (lambda (vals) - (cons (list - 'lambda - (lambda->formals fn) - (cps-seq (cddr fn) ;(ast-subx fn) - cont-ast)) - vals)))) - (else - (cps-list ast ;(ast-subx ast) - (lambda (args) - (cons (car args) - (cons cont-ast - (cdr args))))))))) - - (else - (error "unknown ast" ast)))) - - (define (cps-list asts inner) - (define (body x) - (cps-list (cdr asts) - (lambda (new-asts) - (inner (cons x new-asts))))) - - (cond ((null? asts) - (inner '())) - ((or (const? (car asts)) - (ref? (car asts))) - (body (car asts))) - (else - (let ((r (gensym 'r))) ;(new-var 'r))) - (cps (car asts) - `(lambda (,r) ,(body r))))))) - - (define (cps-seq asts cont-ast) - (cond ((null? asts) - (list cont-ast #f)) - ((null? (cdr asts)) - (cps (car asts) cont-ast)) - (else - (let ((r (gensym 'r))) - (cps (car asts) - `(lambda - (,r) - ,(cps-seq (cdr asts) cont-ast))))))) - - ;; Remove dummy symbol inserted into define forms converted to CPS - (define (remove-unused ast) - (list (car ast) (cadr ast) (cadddr ast))) - - (let* ((global-def? (define? ast)) ;; No internal defines by this phase - (ast-cps - (if global-def? - (remove-unused - `(define ,(define->var ast) - ,@(let ((k (gensym 'k)) - (r (gensym 'r))) - (cps (car (define->exp ast)) 'unused)))) - (cps ast '%halt)))) - ast-cps)) - - -;; Closure-conversion. -;; -;; Closure conversion eliminates all of the free variables from every -;; lambda term. -;; -;; The code below is based on a fusion of a port of the 90-min-scc code by -;; Marc Feeley and the closure conversion code in Matt Might's scheme->c -;; compiler. - -(define (pos-in-list x lst) - (let loop ((lst lst) (i 0)) - (cond ((not (pair? lst)) #f) - ((eq? (car lst) x) i) - (else - (loop (cdr lst) (+ i 1)))))) - -(define (closure-convert exp globals) - (define (convert exp self-var free-var-lst) - (define (cc exp) - (cond - ((const? exp) exp) - ((quote? exp) exp) - ((ref? exp) - (let ((i (pos-in-list exp free-var-lst))) - (if i - `(%closure-ref - ,self-var - ,(+ i 1)) - exp))) - ((or - (tagged-list? '%closure-ref exp) - (tagged-list? '%closure exp) - (prim-call? exp)) - `(,(car exp) - ,@(map cc (cdr exp)))) ;; TODO: need to splice? - ((set!? exp) `(set! ,(set!->var exp) - ,(cc (set!->exp exp)))) - ((lambda? exp) - (let* ((new-self-var (gensym 'self)) - (body (lambda->exp exp)) - (new-free-vars - (difference - (difference (free-vars body) (lambda-formals->list exp)) - globals))) - `(%closure - (lambda - ,(list->lambda-formals - (cons new-self-var (lambda-formals->list exp)) - (lambda-formals-type exp)) - ,(convert (car body) new-self-var new-free-vars)) ;; TODO: should this be a map??? was a list in 90-min-scc. - ,@(map (lambda (v) ;; TODO: splice here? - (cc v)) - new-free-vars)))) - ((if? exp) `(if ,@(map cc (cdr exp)))) - ((cell? exp) `(cell ,(cc (cell->value exp)))) - ((cell-get? exp) `(cell-get ,(cc (cell-get->cell exp)))) - ((set-cell!? exp) `(set-cell! ,(cc (set-cell!->cell exp)) - ,(cc (set-cell!->value exp)))) - ((app? exp) - (let ((fn (car exp)) - (args (map cc (cdr exp)))) - (if (lambda? fn) - (let* ((body (lambda->exp fn)) - (new-free-vars - (difference - (difference (free-vars body) (lambda-formals->list fn)) - globals)) - (new-free-vars? (> (length new-free-vars) 0))) - (if new-free-vars? - ; Free vars, create a closure for them - (let* ((new-self-var (gensym 'self))) - `((%closure - (lambda - ,(list->lambda-formals - (cons new-self-var (lambda-formals->list fn)) - (lambda-formals-type fn)) - ,(convert (car body) new-self-var new-free-vars)) - ,@(map (lambda (v) (cc v)) - new-free-vars)) - ,@args)) - ; No free vars, just create simple lambda - `((lambda ,(lambda->formals fn) - ,@(map cc body)) - ,@args))) - (let ((f (cc fn))) - `((%closure-ref ,f 0) - ,f - ,@args))))) - (else - (error "unhandled exp: " exp)))) - (cc exp)) - - `(lambda () - ,(convert exp #f '()))) - -; Suitable definitions for the cell functions: -;(define (cell value) (lambda (get? new-value) -; (if get? value (set! value new-value)))) -;(define (set-cell! c v) (c #f v)) -;(define (cell-get c) (c #t #t)) +#f diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 37bfac92..d2fae9b7 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -1,3 +1,12 @@ +;; +;; Cyclone Scheme +;; Copyright (c) 2014, Justin Ethier +;; All rights reserved. +;; +;; This module performs Scheme-to-Scheme transformations, and also contains +;; various utility functions used by the compiler. +;; + (define-library (scheme cyclone transforms) (import (scheme base) (scheme char) @@ -118,5 +127,1646 @@ pos-in-list closure-convert ) - (include "transforms.scm")) + (begin +;; Temporary work-around for pp not being implemented yet +(define pretty-print write) + +;; Built-in macros +;; TODO: just a stub, real code would read (define-syntax) +;; from a lib file or such +(define *defined-macros* + (list + (cons 'and + (lambda (expr rename compare) + (cond ((null? (cdr expr))) ;; TODO (?): #t) + ((null? (cddr expr)) (cadr expr)) + (else (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f))))) + (cons 'or + (lambda (expr rename compare) + (cond ((null? (cdr expr)) #f) + ((null? (cddr expr)) (cadr expr)) + (else + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr)))))))) +; (cons 'let (lambda (exp rename compare) (let=>lambda exp))) + (cons 'let + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let" expr)) + (if (null? (cddr expr)) (error "no let body" expr)) + ((lambda (bindings) + (if (list? bindings) #f (error "bad let bindings")) + (if (every (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + bindings) + ((lambda (vars vals) + (if (symbol? (cadr expr)) + `((,(rename 'lambda) ,vars + (,(rename 'letrec) ((,(cadr expr) + (,(rename 'lambda) ,vars + ,@(cdr (cddr expr))))) + (,(cadr expr) ,@vars))) + ,@vals) + `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals))) + (map car bindings) + (map cadr bindings)) + (error "bad let syntax" expr))) + (if (symbol? (cadr expr)) (car (cddr expr)) (cadr expr))))) + (cons 'let* + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caar (cdr expr))) + (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr))) + (error "bad let* syntax"))))) + (cons 'begin (lambda (exp rename compare) (begin=>let exp))) + (cons 'letrec (lambda (exp rename compare) (letrec=>lets+sets exp))) + (cons 'when (lambda (exp rename compare) + (if (null? (cdr exp)) (error "empty when" exp)) + (if (null? (cddr exp)) (error "no when body" exp)) + `(if ,(cadr exp) + ((lambda () ,@(cddr exp))) + #f))) + (cons 'cond + (lambda (expr rename compare) + (if (null? (cdr expr)) + #f ;(if #f #f) + ((lambda (cl) + (if (compare (rename 'else) (car cl)) + (if (pair? (cddr expr)) + (error "non-final else in cond" expr) + (cons (rename 'begin) (cdr cl))) + (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl))) + (list (list (rename 'lambda) (list (rename 'tmp)) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (car (cddr cl)) (rename 'tmp))) + (cons (rename 'cond) (cddr expr)))) + (car cl)) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr))))) + (cons 'case + (lambda (expr rename compare) + (define (body exprs) + (cond + ((null? exprs) + (rename 'tmp)) + ((compare (rename '=>) (car exprs)) + `(,(cadr exprs) ,(rename 'tmp))) + (else + `(,(rename 'begin) ,@exprs)))) + (define (clause ls) + (cond + ((null? ls) #f) + ((compare (rename 'else) (caar ls)) + (body (cdar ls))) + ((and (pair? (car (car ls))) (null? (cdr (car (car ls))))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) + (,(rename 'quote) ,(car (caar ls)))) + ,(body (cdar ls)) + ,(clause (cdr ls)))) + (else + `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) + (,(rename 'quote) ,(caar ls))) + ,(body (cdar ls)) + ,(clause (cdr ls)))))) + `(let ((,(rename 'tmp) ,(cadr expr))) + ,(clause (cddr expr))))) + (cons 'cond-expand + ;; Based on the cond-expand macro from Chibi scheme + (lambda (expr rename compare) + (define (check x) + (if (pair? x) + (case (car x) + ((and) (every check (cdr x))) + ((or) (any check (cdr x))) + ((not) (not (check (cadr x)))) + ;((library) (eval `(find-module ',(cadr x)) (%meta-env))) + (else (error "cond-expand: bad feature" x))) + (memq x (features)))) + (let expand ((ls (cdr expr))) + (cond ((null? ls)) ; (error "cond-expand: no expansions" expr) + ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls))) + ((eq? 'else (caar ls)) ;(identifier->symbol (caar ls))) + (if (pair? (cdr ls)) + (error "cond-expand: else in non-final position") + `(,(rename 'begin) ,@(cdar ls)))) + ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls))) + (else (expand (cdr ls))))))) + (cons 'quasiquote + ;; Based on the quasiquote macro from Chibi scheme + (lambda (expr rename compare) + (define (qq x d) + (cond + ((pair? x) + (cond + ((compare (rename 'unquote) (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'list) (list (rename 'quote) 'unquote) + (qq (cadr x) (- d 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= d 0) + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)) + (list (rename 'list) (list (rename 'quote) 'unquote-splicing) + (qq (cadr x) (- d 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) (list (rename 'quote) 'quasiquote) + (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) + (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadr (car x)) + (list (rename 'append) (cadr (car x)) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((if (symbol? x) #t (null? x)) (list (rename 'quote) x)) + (else x))) + (qq (cadr expr) 0))) + )) + + +(define (built-in-syms) + '(call-with-values call/cc define)) + +;; Tuning +(define *do-code-gen* #t) ; Generate C code? + +;; Trace +(define *trace-level* 2) +(define (trace level msg pp prefix) + (if (>= *trace-level* level) + (begin + (display "/* ") + (newline) + (display prefix) + (pp msg) + (display " */") + (newline)))) +(define (trace:error msg) (trace 1 msg pretty-print "")) +(define (trace:warn msg) (trace 2 msg pretty-print "")) +(define (trace:info msg) (trace 3 msg pretty-print "")) +(define (trace:debug msg) (trace 4 msg display "DEBUG: ")) + +(define (cyc:error msg) + (error msg) + (exit 1)) + +;; File Utilities + +;; Get the basename of a file, without the extension. +;; EG: "file.scm" ==> "file" +(define (basename filename) + (let ((pos (list-index #\. (reverse (string->list filename))))) + (if (= pos -1) + filename + (substring filename 0 (- (string-length filename) pos 1))))) + +;; Find the first occurence of e within the given list. +;; Returns -1 if e is not found. +(define list-index + (lambda (e lst) + (if (null? lst) + -1 + (if (eq? (car lst) e) + 0 + (if (= (list-index e (cdr lst)) -1) + -1 + (+ 1 (list-index e (cdr lst)))))))) + + +;; Utilities. + +(cond-expand + (cyclone + ; member : symbol sorted-set[symbol] -> boolean + (define (member sym S) + (if (not (pair? S)) + #f + (if (eq? sym (car S)) + #t + (member sym (cdr S)))))) + (else #f)) + +(cond-expand + (cyclone + ; void : -> void + (define (void) (if #f #t))) + (else #f)) + +; gensym-count : integer +(define gensym-count 0) + +; gensym : symbol -> symbol +(define gensym (lambda params + (if (null? params) + (begin + (set! gensym-count (+ gensym-count 1)) + (string->symbol (string-append + "$" + (number->string gensym-count)))) + (begin + (set! gensym-count (+ gensym-count 1)) + (string->symbol (string-append + (if (symbol? (car params)) + (symbol->string (car params)) + (car params)) + "$" + (number->string gensym-count))))))) + +; symbol boolean +(define (symbolstring sym1) + (symbol->string sym2))) + +; insert : symbol sorted-set[symbol] -> sorted-set[symbol] +(define (insert sym S) + (if (not (pair? S)) + (list sym) + (cond + ((eq? sym (car S)) S) + ((symbol sorted-set[symbol] +(define (remove sym S) + (if (not (pair? S)) + '() + (if (eq? (car S) sym) + (cdr S) + (cons (car S) (remove sym (cdr S)))))) + +; union : sorted-set[symbol] sorted-set[symbol] -> sorted-set[symbol] +(define (union set1 set2) + ; NOTE: This should be implemented as merge for efficiency. + (if (not (pair? set1)) + set2 + (insert (car set1) (union (cdr set1) set2)))) + +; difference : sorted-set[symbol] sorted-set[symbol] -> sorted-set[symbol] +(define (difference set1 set2) + ; NOTE: This can be similarly optimized. + (if (not (pair? set2)) + set1 + (difference (remove (car set2) set1) (cdr set2)))) + +; reduce : (A A -> A) list[A] A -> A +(define (reduce f lst init) + (if (not (pair? lst)) + init + (reduce f (cdr lst) (f (car lst) init)))) + +; azip : list[A] list[B] -> alist[A,B] +(define (azip list1 list2) + (if (and (pair? list1) (pair? list2)) + (cons (list (car list1) (car list2)) + (azip (cdr list1) (cdr list2))) + '())) + +; assq-remove-key : alist[A,B] A -> alist[A,B] +(define (assq-remove-key env key) + (if (not (pair? env)) + '() + (if (eq? (car (car env)) key) + (assq-remove-key (cdr env) key) + (cons (car env) (assq-remove-key (cdr env) key))))) + +; assq-remove-keys : alist[A,B] list[A] -> alist[A,B] +(define (assq-remove-keys env keys) + (if (not (pair? keys)) + env + (assq-remove-keys (assq-remove-key env (car keys)) (cdr keys)))) + + +;; Data type predicates and accessors. + +; const? : exp -> boolean +(define (const? exp) + (or (integer? exp) + (real? exp) + (string? exp) + (vector? exp) + (char? exp) + (boolean? exp))) + +; ref? : exp -> boolean +(define (ref? exp) + (symbol? exp)) + +; quote? : exp -> boolean +(define (quote? exp) + (tagged-list? 'quote exp)) + +; let? : exp -> boolean +(define (let? exp) + (tagged-list? 'let exp)) + +; let->bindings : let-exp -> alist[symbol,exp] +(define (let->bindings exp) + (cadr exp)) + +; let->exp : let-exp -> exp +(define (let->exp exp) + (cddr exp)) + +; let->bound-vars : let-exp -> list[symbol] +(define (let->bound-vars exp) + (map car (cadr exp))) + +; let->args : let-exp -> list[exp] +(define (let->args exp) + (map cadr (cadr exp))) + +; letrec? : exp -> boolean +(define (letrec? exp) + (tagged-list? 'letrec exp)) + +; letrec->bindings : letrec-exp -> alist[symbol,exp] +(define (letrec->bindings exp) + (cadr exp)) + +; letrec->exp : letrec-exp -> exp +(define (letrec->exp exp) + (cddr exp)) + +; letrec->exp : letrec-exp -> list[symbol] +(define (letrec->bound-vars exp) + (map car (cadr exp))) + +; letrec->exp : letrec-exp -> list[exp] +(define (letrec->args exp) + (map cadr (cadr exp))) + +(define (lambda-varargs? exp) + (and (lambda? exp) + (or (symbol? (lambda->formals exp)) + (and (pair? (lambda->formals exp)) + (not (list? (lambda->formals exp))))))) + +; lambda->formals : lambda-exp -> list[symbol] +(define (lambda->formals exp) + (cadr exp)) + +(define (lambda-varargs? exp) + (let ((type (lambda-formals-type exp))) + (or (equal? type 'args:varargs) + (equal? type 'args:fixed-with-varargs)))) + +(define (lambda-varargs-var exp) + (if (lambda-varargs? exp) + (if (equal? (lambda-formals-type exp) 'args:varargs) + (lambda->formals exp) ; take symbol directly + (car (reverse (lambda-formals->list exp)))) ; Last arg is varargs + #f)) + +(define (lambda-formals-type exp) + (let ((args (lambda->formals exp))) + (cond + ((symbol? args) 'args:varargs) + ((list? args) 'args:fixed) + ((pair? args) 'args:fixed-with-varargs) + (else + (error `(Unexpected formals list in lambda-formals-type: ,args)))))) + +(define (lambda-formals->list exp) + (if (lambda-varargs? exp) + (let ((args (lambda->formals exp))) + (if (symbol? args) + (list args) + (pair->list args))) + (lambda->formals exp))) + +;; Minimum number of required arguments for a lambda +(define (lambda-num-args exp) + (let ((type (lambda-formals-type exp)) + (num (length (lambda-formals->list exp)))) + (cond + ((equal? type 'args:varargs) + -1) ;; Unlimited + ((equal? type 'args:fixed-with-varargs) + (- num 1)) ;; Last arg is optional + (else + num)))) + +;; Repack a list of args (symbols) into lambda formals, by type +;; assumes args is a proper list +(define (list->lambda-formals args type) + (cond + ((eq? type 'args:fixed) args) + ((eq? type 'args:fixed-with-varargs) (list->pair args)) + ((eq? type 'args:varargs) + (if (> (length args) 1) + (error `(Too many args for varargs ,args)) + (car args))) + (else (error `(Unexpected type ,type))))) + +;; Create a proper copy of an improper list +;; EG: (1 2 . 3) ==> (1 2 3) +(define (pair->list p) + (let loop ((lst p)) + (if (not (pair? lst)) + (cons lst '()) + (cons (car lst) (loop (cdr lst)))))) + +;; Create an improper copy of a proper list +(define (list->pair l) + (let loop ((lst l)) + (cond + ((not (pair? lst)) + lst) + ((null? (cdr lst)) + (car lst)) + (else + (cons (car lst) (loop (cdr lst))))))) + +; lambda->exp : lambda-exp -> exp +(define (lambda->exp exp) + (cddr exp)) ;; JAE - changed from caddr, so we can handle multiple expressions + +; if->condition : if-exp -> exp +(define (if->condition exp) + (cadr exp)) + +; if->then : if-exp -> exp +(define (if->then exp) + (caddr exp)) + +;; if-else? : if-exp -> bool +;; Determines whether an if expression has an else clause +(define (if-else? exp) + (and (tagged-list? 'if exp) + (> (length exp) 3))) + +; if->else : if-exp -> exp +(define (if->else exp) + (cadddr exp)) + +; app? : exp -> boolean +(define (app? exp) + (pair? exp)) + +; app->fun : app-exp -> exp +(define (app->fun exp) + (car exp)) + +; app->args : app-exp -> list[exp] +(define (app->args exp) + (cdr exp)) + +; prim? : exp -> boolean +(define (prim? exp) + (member exp *primitives*)) + +(define *primitives* '( + Cyc-global-vars + Cyc-get-cvar + Cyc-set-cvar! + Cyc-cvar? ;; Cyclone-specific + Cyc-has-cycle? + Cyc-stdout + Cyc-stdin + Cyc-stderr + + + - + * + / + = + > + < + >= + <= + apply + %halt + exit + system + command-line-arguments + Cyc-installation-dir + Cyc-default-exception-handler + Cyc-current-exception-handler + cons + cell-get + set-global! + set-cell! + cell + eq? + eqv? + equal? + assoc + assq + assv + memq + memv + member + length + set-car! + set-cdr! + car + cdr + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + char->integer + integer->char + string->number + string-append + string-cmp + list->string + string->symbol + symbol->string + number->string + string-length + string-ref + string-set! + substring + make-vector + list->vector + vector-length + vector-ref + vector-set! + boolean? + char? + eof-object? + null? + number? + real? + integer? + pair? + port? + procedure? + vector? + string? + symbol? + open-input-file + open-output-file + close-port + close-input-port + close-output-port + Cyc-flush-output-port + file-exists? + delete-file + read-char + peek-char + Cyc-read-line + Cyc-write-char + Cyc-write + Cyc-display)) + +;; Constant Folding +;; Is a primitive being applied in such a way that it can be +;; evaluated at compile time? +(define (precompute-prim-app? ast) + (and + (pair? ast) + (prim? (car ast)) + ;; Does not make sense to precompute these + (not (member (car ast) + '(Cyc-global-vars + Cyc-get-cvar + Cyc-set-cvar! + Cyc-cvar? + apply + %halt + exit + system + command-line-arguments + Cyc-installation-dir + Cyc-default-exception-handler + Cyc-current-exception-handler + cell-get + set-global! + set-cell! + cell + set-car! + set-cdr! + string-set! + string->symbol ;; Could be mistaken for an identifier + make-vector + ;; I/O must be done at runtime for side effects: + Cyc-stdout + Cyc-stdin + Cyc-stderr + open-input-file + open-output-file + close-port + close-input-port + close-output-port + Cyc-flush-output-port + file-exists? + delete-file + read-char + peek-char + Cyc-read-line + Cyc-write-char + Cyc-write + Cyc-display))) + (call/cc + (lambda (return) + (for-each + (lambda (expr) + (if (or (vector? expr) + (not (const? expr))) + (return #f))) + (cdr ast)) + #t)))) + +(define (prim-call? exp) + (and (list? exp) (prim? (car exp)))) + +; begin->exps : begin-exp -> list[exp] +(define (begin->exps exp) + (cdr exp)) + +; define : exp -> boolean +(define (define? exp) + (tagged-list? 'define exp)) + +(define (define-lambda? exp) + (let ((var (cadr exp))) + (or + ;; Standard function + (and (list? var) + (> (length var) 0) + (symbol? (car var))) + ;; Varargs function + (and (pair? var) + (symbol? (car var)))))) + +(define (define->lambda exp) + (cond + ((define-lambda? exp) + (let ((var (caadr exp)) + (args (cdadr exp)) + (body (cddr exp))) + `(define ,var (lambda ,args ,@body)))) + (else exp))) + +; define->var : define-exp -> var +(define (define->var exp) + (cond + ((define-lambda? exp) + (caadr exp)) + (else + (cadr exp)))) + +; define->exp : define-exp -> exp +(define (define->exp exp) + (cddr exp)) + +; set! : exp -> boolean +(define (set!? exp) + (tagged-list? 'set! exp)) + +; set!->var : set!-exp -> var +(define (set!->var exp) + (cadr exp)) + +; set!->exp : set!-exp -> exp +(define (set!->exp exp) + (caddr exp)) + +; closure? : exp -> boolean +(define (closure? exp) + (tagged-list? 'closure exp)) + +; closure->lam : closure-exp -> exp +(define (closure->lam exp) + (cadr exp)) + +; closure->env : closure-exp -> exp +(define (closure->env exp) + (caddr exp)) + +(define (closure->fv exp) + (cddr exp)) + +; env-make? : exp -> boolean +(define (env-make? exp) + (tagged-list? 'env-make exp)) + +; env-make->id : env-make-exp -> env-id +(define (env-make->id exp) + (cadr exp)) + +; env-make->fields : env-make-exp -> list[symbol] +(define (env-make->fields exp) + (map car (cddr exp))) + +; env-make->values : env-make-exp -> list[exp] +(define (env-make->values exp) + (map cadr (cddr exp))) + +; env-get? : exp -> boolen +(define (env-get? exp) + (tagged-list? 'env-get exp)) + +; env-get->id : env-get-exp -> env-id +(define (env-get->id exp) + (cadr exp)) + +; env-get->field : env-get-exp -> symbol +(define (env-get->field exp) + (caddr exp)) + +; env-get->env : env-get-exp -> exp +(define (env-get->env exp) + (cadddr exp)) + +; set-cell!? : set-cell!-exp -> boolean +(define (set-cell!? exp) + (tagged-list? 'set-cell! exp)) + +; set-cell!->cell : set-cell!-exp -> exp +(define (set-cell!->cell exp) + (cadr exp)) + +; set-cell!->value : set-cell!-exp -> exp +(define (set-cell!->value exp) + (caddr exp)) + +; cell? : exp -> boolean +(define (cell? exp) + (tagged-list? 'cell exp)) + +; cell->value : cell-exp -> exp +(define (cell->value exp) + (cadr exp)) + +; cell-get? : exp -> boolean +(define (cell-get? exp) + (tagged-list? 'cell-get exp)) + +; cell-get->cell : cell-exp -> exp +(define (cell-get->cell exp) + (cadr exp)) + + + +;; Syntax manipulation. + +;; ; substitute-var : alist[var,exp] ref-exp -> exp +;; (define (substitute-var env var) +;; (let ((sub (assq var env))) +;; (if sub +;; (cadr sub) +;; var))) +;; +;; ; substitute : alist[var,exp] exp -> exp +;; (define (substitute env exp) +;; +;; (define (substitute-with env) +;; (lambda (exp) +;; (substitute env exp))) +;; +;; (cond +;; ; Core forms: +;; ((null? env) exp) +;; ((const? exp) exp) +;; ((prim? exp) exp) +;; ((ref? exp) (substitute-var env exp)) +;; ((lambda? exp) `(lambda ,(lambda->formals exp) +;; ,@(map (lambda (body-exp) +;; ;; TODO: could be more efficient +;; (substitute +;; (assq-remove-keys env (lambda->formals exp)) +;; body-exp)) +;; (lambda->exp exp)))) +;; ((set!? exp) `(set! ,(substitute-var env (set!->var exp)) +;; ,(substitute env (set!->exp exp)))) +;; ((if? exp) `(if ,(substitute env (if->condition exp)) +;; ,(substitute env (if->then exp)) +;; ,(substitute env (if->else exp)))) +;; +;; ; Sugar: +;; ((let? exp) `(let ,(azip (let->bound-vars exp) +;; (map (substitute-with env) (let->args exp))) +;; ,(substitute (assq-remove-keys env (let->bound-vars exp)) +;; (car (let->exp exp))))) +;; ((letrec? exp) (let ((new-env (assq-remove-keys env (letrec->bound-vars exp)))) +;; `(letrec ,(azip (letrec->bound-vars exp) +;; (map (substitute-with new-env) +;; (letrec->args exp))) +;; ,(substitute new-env (car (letrec->exp exp)))))) +;; ((begin? exp) (cons 'begin (map (substitute-with env) (begin->exps exp)))) +;; +;; ; IR (1): +;; ((cell? exp) `(cell ,(substitute env (cell->value exp)))) +;; ((cell-get? exp) `(cell-get ,(substitute env (cell-get->cell exp)))) +;; ((set-cell!? exp) `(set-cell! ,(substitute env (set-cell!->cell exp)) +;; ,(substitute env (set-cell!->value exp)))) +;; +;; ; IR (2): +;; ((closure? exp) `(closure ,(substitute env (closure->lam exp)) +;; ,(substitute env (closure->env exp)))) +;; ((env-make? exp) `(env-make ,(env-make->id exp) +;; ,@(azip (env-make->fields exp) +;; (map (substitute-with env) +;; (env-make->values exp))))) +;; ((env-get? exp) `(env-get ,(env-get->id exp) +;; ,(env-get->field exp) +;; ,(substitute env (env-get->env exp)))) +;; +;; ; Application: +;; ((app? exp) (map (substitute-with env) exp)) +;; (else (error "unhandled expression type in substitution: " exp)))) +;; + +;; Macro expansion + +; expand : exp -> exp +(define (expand exp) + (cond + ((const? exp) exp) + ((prim? exp) exp) + ((ref? exp) exp) + ((quote? exp) exp) + ((lambda? exp) `(lambda ,(lambda->formals exp) + ,@(map expand (lambda->exp exp)))) + ((define? exp) (if (define-lambda? exp) + (expand (define->lambda exp)) + `(define ,(expand (define->var exp)) + ,@(expand (define->exp exp))))) + ((set!? exp) `(set! ,(expand (set!->var exp)) + ,(expand (set!->exp exp)))) + ((if? exp) `(if ,(expand (if->condition exp)) + ,(expand (if->then exp)) + ,(if (if-else? exp) + (expand (if->else exp)) + ;; Insert default value for missing else clause + ;; FUTURE: append the empty (unprinted) value + ;; instead of #f + #f))) + ((app? exp) + (cond +;; TODO: could check for a define-syntax here and load into memory +;; if found. would then want to continue expanding. may need to +;; return some value such as #t or nil as a placeholder, since the +;; define-syntax form would not be carried forward in the compiled code + ((define-syntax? exp) ;; TODO: not good enough, should do error checking, and make sure list is big enough for cadr + ;(trace:info `(define-syntax ,exp)) + (let* ((name (cadr exp)) + (trans (caddr exp)) + (body (cadr trans))) + (set! *defined-macros* (cons (cons name body) *defined-macros*)) + #t)) + ((macro? exp *defined-macros*) + (expand ;; Could expand into another macro + (macro-expand exp *defined-macros*))) + (else + (map expand exp)))) + (else + (error "unknown exp: " exp)))) + +; TODO: eventually, merge below functions with above *defined-macros* defs and +;; replace both with a lib of (define-syntax) constructs + +;; let=>lambda : let-exp -> app-exp +;(define (let=>lambda exp) +; (if (let? exp) +; (let ((vars (map car (let->bindings exp))) +; (args (map cadr (let->bindings exp)))) +; `((lambda (,@vars) ,@(let->exp exp)) ,@args)) +; exp)) + +; letrec=>lets+sets : letrec-exp -> exp +(define (letrec=>lets+sets exp) + (if (letrec? exp) + (let* ((bindings (letrec->bindings exp)) + (namings (map (lambda (b) (list (car b) #f)) bindings)) + (names (letrec->bound-vars exp)) + (sets (map (lambda (binding) + (cons 'set! binding)) + bindings)) + (args (letrec->args exp))) + `(let ,namings + (begin ,@(append sets (letrec->exp exp))))))) +;; NOTE: chibi uses the following macro. turns vars into defines? +;;(define-syntax letrec +;; (er-macro-transformer +;; (lambda (expr rename compare) +;; ((lambda (defs) +;; `((,(rename 'lambda) () ,@defs ,@(cddr expr)))) +;; (map (lambda (x) (cons (rename 'define) x)) (cadr expr)))))) +;; + +; begin=>let : begin-exp -> let-exp +(define (begin=>let exp) + (define (singlet? l) + (and (list? l) + (= (length l) 1))) + + (define (dummy-bind exps) + (cond + ((singlet? exps) (car exps)) + + ; JAE - should be fine until CPS phase + ((pair? exps) + `((lambda () + ,@exps))))) + ;((pair? exps) `(let (($_ ,(car exps))) + ; ,(dummy-bind (cdr exps)))))) + (dummy-bind (begin->exps exp))) + + +;; Top-level analysis + +; Separate top-level defines (globals) from other expressions +; +; This function extracts out non-define statements, and adds them to +; a "main" after the defines. +; +(define (isolate-globals exp program? lib-name) + (let loop ((top-lvl exp) + (globals '()) + (exprs '())) + (cond + ((null? top-lvl) + (append + (reverse globals) + (expand + (cond + (program? + ;; This is the main program, keep top level. + ;; Use 0 here (and below) to ensure a meaningful top-level + `((begin 0 ,@(reverse exprs))) + ) + (else + ;; This is a library, keep inits in their own function + `((define ,(lib:name->symbol lib-name) + (lambda () 0 ,@(reverse exprs)))))) + ))) + (else + (cond + ((define? (car top-lvl)) + (cond + ;; Global is redefined, convert it to a (set!) at top-level + ((has-global? globals (define->var (car top-lvl))) + (loop (cdr top-lvl) + globals + (cons + `(set! ,(define->var (car top-lvl)) + ,@(define->exp (car top-lvl))) + exprs))) + ;; Form cannot be properly converted to CPS later on, so split it up + ;; into two parts - use the define to initialize it to false (CPS is fine), + ;; and place the expression into a top-level (set!), which can be + ;; handled by the existing CPS conversion. + ((or + ;; TODO: the following line may not be good enough, a global assigned to another + ;; global may still be init'd to nil if the order is incorrect in the "top level" + ;; initialization code. + (symbol? (car (define->exp (car top-lvl)))) ;; TODO: put these at the end of top-lvl??? + (and (list? (car (define->exp (car top-lvl)))) + (not (lambda? (car (define->exp (car top-lvl))))))) + (loop (cdr top-lvl) + (cons + `(define ,(define->var (car top-lvl)) #f) + globals) + (cons + `(set! ,(define->var (car top-lvl)) + ,@(define->exp (car top-lvl))) + exprs))) + ;; First time we've seen this define, add it and keep going + (else + (loop (cdr top-lvl) + (cons (car top-lvl) globals) + exprs)))) + (else + (loop (cdr top-lvl) + globals + (cons (car top-lvl) exprs)))))))) + +; Has global already been found? +; +; NOTE: +; Linear search may get expensive (n^2), but with a modest set of +; define statements hopefully it will be acceptable. If not, will need +; to use a faster data structure (EG: map or hashtable) +(define (has-global? exp var) + (call/cc + (lambda (return) + (for-each + (lambda (e) + (if (and (define? e) + (equal? (define->var e) var)) + (return #t))) + exp) + #f))) + +; Compute list of global variables based on expression in top-level form +; EG: (def, def, expr, ...) +(define (global-vars exp) + (let ((globals '())) + (for-each + (lambda (e) + (if (define? e) + (set! globals (cons (define->var e) globals)))) + exp) + globals)) + +;; Remove global variables that are not used by the rest of the program. +;; Many improvements can be made, including: +;; +;; TODO: remove unused locals +(define (filter-unused-variables asts lib-exports) + (define (do-filter code) + (let ((all-fv (apply ;; More efficient way to do this? + append ;; Could use delete-duplicates + (map + (lambda (ast) + (if (define? ast) + (let ((var (define->var ast))) + ;; Do not keep global that refers to itself + (filter + (lambda (v) + (not (equal? v var))) + (free-vars (define->exp ast)))) + (free-vars ast))) + code)))) + (filter + (lambda (ast) + (or (not (define? ast)) + (member (define->var ast) all-fv) + (member (define->var ast) lib-exports))) + code))) + ;; Keep filtering until no more vars are removed + (define (loop code) + (let ((new-code (do-filter code))) + (if (> (length code) (length new-code)) + (loop new-code) + new-code))) + (loop asts)) + +;; Syntactic analysis. + +; free-vars : exp -> sorted-set[var] +(define (free-vars ast . opts) + (define bound-only? + (and (not (null? opts)) + (car opts))) + + (define (search exp) + (cond + ; Core forms: + ((const? exp) '()) + ((prim? exp) '()) + ((quote? exp) '()) + ((ref? exp) (if bound-only? '() (list exp))) + ((lambda? exp) + (difference (reduce union (map search (lambda->exp exp)) '()) + (lambda-formals->list exp))) + ((if? exp) (union (search (if->condition exp)) + (union (search (if->then exp)) + (search (if->else exp))))) + ((define? exp) (union (list (define->var exp)) + (search (define->exp exp)))) + ((set!? exp) (union (list (set!->var exp)) + (search (set!->exp exp)))) + ; Application: + ((app? exp) (reduce union (map search exp) '())) + (else (error "unknown expression: " exp)))) + (search ast)) + + + + + +;; Mutable variable analysis and elimination. + +;; Mutables variables analysis and elimination happens +;; on a desugared Intermediate Language (1). + +;; Mutable variable analysis turns mutable variables +;; into heap-allocated cells: + +;; For any mutable variable mvar: + +;; (lambda (... mvar ...) body) +;; => +;; (lambda (... $v ...) +;; (let ((mvar (cell $v))) +;; body)) + +;; (set! mvar value) => (set-cell! mvar value) + +;; mvar => (cell-get mvar) + +; mutable-variables : list[symbol] +(define mutable-variables '()) + +(define (clear-mutables) + (set! mutable-variables '())) + +; mark-mutable : symbol -> void +(define (mark-mutable symbol) + (set! mutable-variables (cons symbol mutable-variables))) + +; is-mutable? : symbol -> boolean +(define (is-mutable? symbol) + (define (is-in? S) + (if (not (pair? S)) + #f + (if (eq? (car S) symbol) + #t + (is-in? (cdr S))))) + (is-in? mutable-variables)) + +; analyze-mutable-variables : exp -> void +(define (analyze-mutable-variables exp) + (cond + ; Core forms: + ((const? exp) (void)) + ((prim? exp) (void)) + ((ref? exp) (void)) + ((quote? exp) (void)) + ((lambda? exp) (begin + (map analyze-mutable-variables (lambda->exp exp)) + (void))) + ((set!? exp) (begin (mark-mutable (set!->var exp)) + (analyze-mutable-variables (set!->exp exp)))) + ((if? exp) (begin + (analyze-mutable-variables (if->condition exp)) + (analyze-mutable-variables (if->then exp)) + (analyze-mutable-variables (if->else exp)))) + + ; Sugar: + ((let? exp) (begin + (map analyze-mutable-variables (map cadr (let->bindings exp))) + (map analyze-mutable-variables (let->exp exp)) + (void))) + ((letrec? exp) (begin + (map analyze-mutable-variables (map cadr (letrec->bindings exp))) + (map analyze-mutable-variables (letrec->exp exp)) + (void))) + ((begin? exp) (begin + (map analyze-mutable-variables (begin->exps exp)) + (void))) + + ; Application: + ((app? exp) (begin + (map analyze-mutable-variables exp) + (void))) + (else (error "unknown expression type: " exp)))) + + +; wrap-mutables : exp -> exp +(define (wrap-mutables exp globals) + + (define (wrap-mutable-formals formals body-exp) + (if (not (pair? formals)) + body-exp + (if (is-mutable? (car formals)) + `((lambda (,(car formals)) + ,(wrap-mutable-formals (cdr formals) body-exp)) + (cell ,(car formals))) + (wrap-mutable-formals (cdr formals) body-exp)))) + + (cond + ; Core forms: + ((const? exp) exp) + ((ref? exp) (if (and (not (member exp globals)) + (is-mutable? exp)) + `(cell-get ,exp) + exp)) + ((prim? exp) exp) + ((quote? exp) exp) + ((lambda? exp) `(lambda ,(lambda->formals exp) + ,(wrap-mutable-formals (lambda-formals->list exp) + (wrap-mutables (car (lambda->exp exp)) globals)))) ;; Assume single expr in lambda body, since after CPS phase + ((set!? exp) `(,(if (member (set!->var exp) globals) + 'set-global! + 'set-cell!) + ,(set!->var exp) + ,(wrap-mutables (set!->exp exp) globals))) + ((if? exp) `(if ,(wrap-mutables (if->condition exp) globals) + ,(wrap-mutables (if->then exp) globals) + ,(wrap-mutables (if->else exp) globals))) + + ; Application: + ((app? exp) (map (lambda (e) (wrap-mutables e globals)) exp)) + (else (error "unknown expression type: " exp)))) + +;; Alpha conversion +;; (aka alpha renaming) +;; +;; This phase is intended to rename identifiers to preserve lexical scoping +;; +;; TODO: does not properly handle renaming builtin functions, would probably need to +;; pass that renaming information downstream +(define (alpha-convert ast globals return-unbound) + ;; Initialize top-level variables + (define (initialize-top-level-vars ast fv) + (if (> (length fv) 0) + ;; Free variables found, set initial values + `((lambda ,fv ,ast) + ,@(map (lambda (_) #f) fv)) + ast)) + + ;; Find any defined variables in the given code block + (define (find-defined-vars ast) + (filter + (lambda (expr) + (not (null? expr))) + (map + (lambda (expr) + (if (define? expr) + (define->var expr) + '())) + ast))) + + ;; Take a list of identifiers and generate a list of + ;; renamed pairs, EG: (var . renamed-var) + (define (make-a-lookup vars) + (map + (lambda (a) (cons a (gensym a))) + vars)) + + ;; Wrap any defined variables in a lambda, so they can be initialized + (define (initialize-defined-vars ast vars) + (if (> (length vars) 0) + `(((lambda ,vars ,@ast) + ,@(map (lambda (_) #f) vars))) + ast)) + + ;; Perform actual alpha conversion + (define (convert ast renamed) +;(write `(DEBUG convert ,ast)) +;(write (newline)) + (cond + ((const? ast) ast) + ((quote? ast) ast) + ((ref? ast) + (let ((renamed (assoc ast renamed))) + (cond + (renamed + (cdr renamed)) + (else ast)))) + ((define? ast) + ;; Only internal defines at this point, of form: (define ident value) + `(set! ,@(map (lambda (a) (convert a renamed)) (cdr ast)))) + ((set!? ast) + ;; Without define, we have no way of knowing if this was a + ;; define or a set prior to this phase. But no big deal, since + ;; the set will still work in either case, so no need to check + `(set! ,@(map (lambda (a) (convert a renamed)) (cdr ast)))) + ((if? ast) + ;; Add a failsafe here in case macro expansion added more + ;; incomplete if expressions. + ;; FUTURE: append the empty (unprinted) value instead of #f + (if (if-else? ast) + `(if ,@(map (lambda (a) (convert a renamed)) (cdr ast))) + (convert (append ast '(#f)) renamed))) + ((prim-call? ast) + (let ((converted + (cons (car ast) + (map (lambda (a) (convert a renamed)) + (cdr ast))))) + (if (precompute-prim-app? converted) + (eval converted) ;; OK, evaluate at compile time + converted))) + ((lambda? ast) + (let* ((args (lambda-formals->list ast)) + (ltype (lambda-formals-type ast)) + (a-lookup (map (lambda (a) (cons a (gensym a))) args)) + (body (lambda->exp ast)) + (define-vars (find-defined-vars body)) + (defines-a-lookup (make-a-lookup define-vars)) + ) + `(lambda + ,(list->lambda-formals + (map (lambda (p) (cdr p)) a-lookup) + ltype) + ,@(initialize-defined-vars + (convert + body + (append a-lookup defines-a-lookup renamed)) + (map (lambda (p) (cdr p)) defines-a-lookup))))) + ((app? ast) + (map (lambda (a) (convert a renamed)) ast)) + (else + (error "unhandled expression: " ast)))) + + (let* ((fv (difference (free-vars ast) globals)) + ;; Only find set! and lambda vars + (bound-vars (union globals (free-vars ast #t))) + ;; vars never bound in prog, but could be built-in + (unbound-vars (difference fv bound-vars)) + ;; vars we know nothing about - error! + (unknown-vars (difference unbound-vars (built-in-syms))) + ) + (cond + ((> (length unknown-vars) 0) + (let ((unbound-to-return (list))) + (if (member 'eval unknown-vars) + (set! unbound-to-return (cons 'eval unbound-to-return))) + (if (or (member 'read unknown-vars) + (member 'read-all unknown-vars)) + (set! unbound-to-return (cons 'read unbound-to-return))) + (if (and (> (length unbound-to-return) 0) + (= (length unknown-vars) (length unbound-to-return))) + (return-unbound unbound-to-return) + ;; TODO: should not report above (eval read) as errors + (error "Unbound variable(s)" unknown-vars)))) + ((define? ast) + ;; Deconstruct define so underlying code can assume internal defines + (let ((body (car ;; Only one member by now + (define->exp ast)))) +;(write `(DEBUG body ,body)) + (cond + ((lambda? body) + (let* ((args (lambda-formals->list body)) + (ltype (lambda-formals-type body)) + (a-lookup (map (lambda (a) (cons a (gensym a))) args)) + (define-vars (find-defined-vars (lambda->exp body))) + (defines-a-lookup (make-a-lookup define-vars)) + ) + ;; Any internal defines need to be initialized within the lambda, + ;; so the lambda formals are preserved. So we need to deconstruct + ;; the defined lambda and then reconstruct it, with #f placeholders + ;; for any internal definitions. + ;; + ;; Also, initialize-top-level-vars cannot be used directly due to + ;; the required splicing. + `(define + ,(define->var ast) + (lambda + ,(list->lambda-formals + (map (lambda (p) (cdr p)) a-lookup) + ltype) + ,@(convert (let ((fv* (union + define-vars + (difference fv (built-in-syms)))) + (ast* (lambda->exp body))) + (if (> (length fv*) 0) + `(((lambda ,fv* ,@ast*) + ,@(map (lambda (_) #f) fv*))) + ast*)) + (append a-lookup defines-a-lookup)))))) + (else + `(define + ,(define->var ast) + ,@(convert (initialize-top-level-vars + (define->exp ast) + (difference fv (built-in-syms))) + (list))))))) + (else + (convert (initialize-top-level-vars + ast + (difference fv (built-in-syms))) + (list)))))) + +;; CPS conversion +;; +;; This is a port of code from the 90-minute Scheme->C Compiler by Marc Feeley +;; +;; Convert intermediate code to continuation-passing style, to allow for +;; first-class continuations and call/cc +;; + +(define (cps-convert ast) + + (define (cps ast cont-ast) + (cond + ((const? ast) + (list cont-ast ast)) + + ((ref? ast) + (list cont-ast ast)) + + ((quote? ast) + (list cont-ast ast)) + + ((set!? ast) + (cps-list (cddr ast) ;; expr passed to set + (lambda (val) + (list cont-ast + `(set! ,(cadr ast) ,@val))))) ;; cadr => variable + + ((if? ast) + (let ((xform + (lambda (cont-ast) + (cps-list (list (cadr ast)) + (lambda (test) + (list 'if + (car test) + (cps (caddr ast) + cont-ast) + (cps (cadddr ast) + cont-ast))))))) + (if (ref? cont-ast) ; prevent combinatorial explosion + (xform cont-ast) + (let ((k (gensym 'k))) + (list (list 'lambda + (list k) + (xform k)) + cont-ast))))) + + ((prim-call? ast) + (cps-list (cdr ast) ; args to primitive function + (lambda (args) + (list cont-ast + `(,(car ast) ; op + ,@args))))) + + ((lambda? ast) + (let ((k (gensym 'k)) + (ltype (lambda-formals-type ast))) + (list cont-ast + `(lambda + ,(list->lambda-formals + (cons k (cadr ast)) ; lam params + (if (equal? ltype 'args:varargs) + 'args:fixed-with-varargs ;; OK? promote due to k + ltype)) + ,(cps-seq (cddr ast) k))))) + +; +; TODO: begin is expanded already by desugar code... better to do it here? +; ((seq? ast) +; (cps-seq (ast-subx ast) cont-ast)) + + ((app? ast) + (let ((fn (app->fun ast))) + (cond + ((lambda? fn) + (cps-list (app->args ast) + (lambda (vals) + (cons (list + 'lambda + (lambda->formals fn) + (cps-seq (cddr fn) ;(ast-subx fn) + cont-ast)) + vals)))) + (else + (cps-list ast ;(ast-subx ast) + (lambda (args) + (cons (car args) + (cons cont-ast + (cdr args))))))))) + + (else + (error "unknown ast" ast)))) + + (define (cps-list asts inner) + (define (body x) + (cps-list (cdr asts) + (lambda (new-asts) + (inner (cons x new-asts))))) + + (cond ((null? asts) + (inner '())) + ((or (const? (car asts)) + (ref? (car asts))) + (body (car asts))) + (else + (let ((r (gensym 'r))) ;(new-var 'r))) + (cps (car asts) + `(lambda (,r) ,(body r))))))) + + (define (cps-seq asts cont-ast) + (cond ((null? asts) + (list cont-ast #f)) + ((null? (cdr asts)) + (cps (car asts) cont-ast)) + (else + (let ((r (gensym 'r))) + (cps (car asts) + `(lambda + (,r) + ,(cps-seq (cdr asts) cont-ast))))))) + + ;; Remove dummy symbol inserted into define forms converted to CPS + (define (remove-unused ast) + (list (car ast) (cadr ast) (cadddr ast))) + + (let* ((global-def? (define? ast)) ;; No internal defines by this phase + (ast-cps + (if global-def? + (remove-unused + `(define ,(define->var ast) + ,@(let ((k (gensym 'k)) + (r (gensym 'r))) + (cps (car (define->exp ast)) 'unused)))) + (cps ast '%halt)))) + ast-cps)) + + +;; Closure-conversion. +;; +;; Closure conversion eliminates all of the free variables from every +;; lambda term. +;; +;; The code below is based on a fusion of a port of the 90-min-scc code by +;; Marc Feeley and the closure conversion code in Matt Might's scheme->c +;; compiler. + +(define (pos-in-list x lst) + (let loop ((lst lst) (i 0)) + (cond ((not (pair? lst)) #f) + ((eq? (car lst) x) i) + (else + (loop (cdr lst) (+ i 1)))))) + +(define (closure-convert exp globals) + (define (convert exp self-var free-var-lst) + (define (cc exp) + (cond + ((const? exp) exp) + ((quote? exp) exp) + ((ref? exp) + (let ((i (pos-in-list exp free-var-lst))) + (if i + `(%closure-ref + ,self-var + ,(+ i 1)) + exp))) + ((or + (tagged-list? '%closure-ref exp) + (tagged-list? '%closure exp) + (prim-call? exp)) + `(,(car exp) + ,@(map cc (cdr exp)))) ;; TODO: need to splice? + ((set!? exp) `(set! ,(set!->var exp) + ,(cc (set!->exp exp)))) + ((lambda? exp) + (let* ((new-self-var (gensym 'self)) + (body (lambda->exp exp)) + (new-free-vars + (difference + (difference (free-vars body) (lambda-formals->list exp)) + globals))) + `(%closure + (lambda + ,(list->lambda-formals + (cons new-self-var (lambda-formals->list exp)) + (lambda-formals-type exp)) + ,(convert (car body) new-self-var new-free-vars)) ;; TODO: should this be a map??? was a list in 90-min-scc. + ,@(map (lambda (v) ;; TODO: splice here? + (cc v)) + new-free-vars)))) + ((if? exp) `(if ,@(map cc (cdr exp)))) + ((cell? exp) `(cell ,(cc (cell->value exp)))) + ((cell-get? exp) `(cell-get ,(cc (cell-get->cell exp)))) + ((set-cell!? exp) `(set-cell! ,(cc (set-cell!->cell exp)) + ,(cc (set-cell!->value exp)))) + ((app? exp) + (let ((fn (car exp)) + (args (map cc (cdr exp)))) + (if (lambda? fn) + (let* ((body (lambda->exp fn)) + (new-free-vars + (difference + (difference (free-vars body) (lambda-formals->list fn)) + globals)) + (new-free-vars? (> (length new-free-vars) 0))) + (if new-free-vars? + ; Free vars, create a closure for them + (let* ((new-self-var (gensym 'self))) + `((%closure + (lambda + ,(list->lambda-formals + (cons new-self-var (lambda-formals->list fn)) + (lambda-formals-type fn)) + ,(convert (car body) new-self-var new-free-vars)) + ,@(map (lambda (v) (cc v)) + new-free-vars)) + ,@args)) + ; No free vars, just create simple lambda + `((lambda ,(lambda->formals fn) + ,@(map cc body)) + ,@args))) + (let ((f (cc fn))) + `((%closure-ref ,f 0) + ,f + ,@args))))) + (else + (error "unhandled exp: " exp)))) + (cc exp)) + + `(lambda () + ,(convert exp #f '()))) + +; Suitable definitions for the cell functions: +;(define (cell value) (lambda (get? new-value) +; (if get? value (set! value new-value)))) +;(define (set-cell! c v) (c #f v)) +;(define (cell-get c) (c #t #t)) + +)) diff --git a/scheme/cyclone/util.scm b/scheme/cyclone/util.scm index d5c5822a..7fd1ea8c 100644 --- a/scheme/cyclone/util.scm +++ b/scheme/cyclone/util.scm @@ -1,112 +1 @@ -;; -;; Cyclone Scheme -;; Copyright (c) 2015, Justin Ethier -;; All rights reserved. -;; -;; This module contains various utility functions. -;; - -(define (tagged-list? tag exp) - (if (pair? exp) - (equal? (car exp) tag) - #f)) - -; if? : exp -> boolean -(define (if? exp) - (tagged-list? 'if exp)) - -; begin? : exp -> boolean -(define (begin? exp) - (tagged-list? 'begin exp)) - -; lambda? : exp -> boolean -(define (lambda? exp) - (tagged-list? 'lambda exp)) - -; char->natural : char -> natural -(define (char->natural c) - (let ((i (char->integer c))) - (if (< i 0) - (* -2 i) - (+ (* 2 i) 1)))) - -; integer->char-list : integer -> string -(define (integer->char-list n) - (string->list (number->string n))) - -;; Simplified version of filter from SRFI 1 -(define (filter pred lis) - (letrec ((recur (lambda (lis) - (if (null? lis) - lis - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail))))))) - (recur lis))) - -;; Based off corresponding SRFI-1 definition -(define (delete x lis) - (filter (lambda (y) (not (equal? x y))) lis)) - -;; Inefficient version based off code from SRFI-1 -(define (delete-duplicates lis) - (define (recur lis) ; ((lis lis)) - (if (null? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail)))) - (if (eq? tail new-tail) lis (cons x new-tail))))) - (recur lis)) - -;; Insert obj at index k of list, increasing length of list by one. -(define (list-insert-at! lis obj k) - (cond - ((null? lis) (error "list-insert-at!, lis cannot be null")) - ((and (> k 0) (null? (cdr lis))) - (set-cdr! lis (cons obj '()))) - ((zero? k) - (let ((old-car (car lis))) - (set-car! lis obj) - (set-cdr! lis (cons old-car (cdr lis))))) - (else - (list-insert-at! (cdr lis) obj (- k 1))))) - - -;; Name-mangling. - -;; We have to "mangle" Scheme identifiers into -;; C-compatible identifiers, because names like -;; foo-bar/baz are not identifiers in C. - -; mangle : symbol -> string -(define (mangle symbol) - (letrec - ((m (lambda (chars) - (if (null? chars) - '() - (if (or (and (char-alphabetic? (car chars)) (not (char=? (car chars) #\_))) - (char-numeric? (car chars))) - (cons (car chars) (m (cdr chars))) - (cons #\_ (append (integer->char-list (char->natural (car chars))) - (m (cdr chars)))))))) - (ident (list->string (m (string->list (symbol->string symbol)))))) - (if (member (string->symbol ident) *c-keywords*) - (string-append "_" ident) - ident))) - -(define (mangle-global symbol) - (string-append "__glo_" (mangle symbol))) - -(define *c-keywords* - '(auto _Bool break case char _Complex const continue default do double else - enum extern float for goto if _Imaginary inline int long register restrict - return short signed sizeof static struct switch typedef union unsigned - void volatile while - list ;; Not a keyword but reserved type - )) -;; END name mangling section - +#f diff --git a/scheme/cyclone/util.sld b/scheme/cyclone/util.sld index 7ddefa8d..39528aaa 100644 --- a/scheme/cyclone/util.sld +++ b/scheme/cyclone/util.sld @@ -1,3 +1,10 @@ +;; +;; Cyclone Scheme +;; Copyright (c) 2015, Justin Ethier +;; All rights reserved. +;; +;; This module contains various utility functions. +;; (define-library (scheme cyclone util) (import (scheme base) (scheme char)) @@ -18,8 +25,112 @@ any every filter) - (include "util.scm") (begin + +(define (tagged-list? tag exp) + (if (pair? exp) + (equal? (car exp) tag) + #f)) + +; if? : exp -> boolean +(define (if? exp) + (tagged-list? 'if exp)) + +; begin? : exp -> boolean +(define (begin? exp) + (tagged-list? 'begin exp)) + +; lambda? : exp -> boolean +(define (lambda? exp) + (tagged-list? 'lambda exp)) + +; char->natural : char -> natural +(define (char->natural c) + (let ((i (char->integer c))) + (if (< i 0) + (* -2 i) + (+ (* 2 i) 1)))) + +; integer->char-list : integer -> string +(define (integer->char-list n) + (string->list (number->string n))) + +;; Simplified version of filter from SRFI 1 +(define (filter pred lis) + (letrec ((recur (lambda (lis) + (if (null? lis) + lis + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail))))))) + (recur lis))) + +;; Based off corresponding SRFI-1 definition +(define (delete x lis) + (filter (lambda (y) (not (equal? x y))) lis)) + +;; Inefficient version based off code from SRFI-1 +(define (delete-duplicates lis) + (define (recur lis) ; ((lis lis)) + (if (null? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete x tail)))) + (if (eq? tail new-tail) lis (cons x new-tail))))) + (recur lis)) + +;; Insert obj at index k of list, increasing length of list by one. +(define (list-insert-at! lis obj k) + (cond + ((null? lis) (error "list-insert-at!, lis cannot be null")) + ((and (> k 0) (null? (cdr lis))) + (set-cdr! lis (cons obj '()))) + ((zero? k) + (let ((old-car (car lis))) + (set-car! lis obj) + (set-cdr! lis (cons old-car (cdr lis))))) + (else + (list-insert-at! (cdr lis) obj (- k 1))))) + + +;; Name-mangling. + +;; We have to "mangle" Scheme identifiers into +;; C-compatible identifiers, because names like +;; foo-bar/baz are not identifiers in C. + +; mangle : symbol -> string +(define (mangle symbol) + (letrec + ((m (lambda (chars) + (if (null? chars) + '() + (if (or (and (char-alphabetic? (car chars)) (not (char=? (car chars) #\_))) + (char-numeric? (car chars))) + (cons (car chars) (m (cdr chars))) + (cons #\_ (append (integer->char-list (char->natural (car chars))) + (m (cdr chars)))))))) + (ident (list->string (m (string->list (symbol->string symbol)))))) + (if (member (string->symbol ident) *c-keywords*) + (string-append "_" ident) + ident))) + +(define (mangle-global symbol) + (string-append "__glo_" (mangle symbol))) + +(define *c-keywords* + '(auto _Bool break case char _Complex const continue default do double else + enum extern float for goto if _Imaginary inline int long register restrict + return short signed sizeof static struct switch typedef union unsigned + void volatile while + list ;; Not a keyword but reserved type + )) +;; END name mangling section + ;; Simplified versions of every/any from SRFI-1 (define (any pred lst) (let any* ((l (map pred lst))) @@ -36,4 +147,5 @@ (every* (cdr l))) (else #f)))) + ))