goo 0.155-13 / usr / lib / goo / mods / eval / g2c.goo

;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.
;;;; BASED ON Lisp In Small Pieces by Christian Queinnec
;;;;
;;;; g2c - Goo-to-C compiler
;;;;

(use goo)
(use goo/boot)
(use goo/macros)
(use goo/system)
(use goo/io/write)
(use goo/cols/col)
(use goo/cols/str)
(use eval/ast)
(use eval/top)
(use eval/ast-linearize)
;; (use eval/typist)
(use eval/optimize)

(ddv *definitions* #f)

;;;;=======================================================================
;;;;  Module Loading
;;;;=======================================================================
;;;;  We subclass the module loader and add our own code for locating and
;;;;  processing modules.

(dc <g2c-module-loader> (<module-loader>))
  (dp module-loader-appname (<g2c-module-loader> => <str>))
  (dp module-loader-app-modname (<g2c-module-loader> => <sym>))

(dc <g2c-module> (<module>))
  (dp! module-src-file (<g2c-module> => <str>))
  (dp! module-mtime (<g2c-module> => <flo>))

(dm module-loader-module-type (loader|<g2c-module-loader> => <type>)
  <g2c-module>)

(dl %print-cpu-usage)

(dm load-module (loader|<g2c-module-loader> name|<sym> => <module>)
  (def mod      (fab-g2c-module loader name))
  (def keepmod? #f)
  (def env      (module-target-environment mod))
  (def file     (module-name-to-relpath name))
  (def src-file (add-src-path (goo-filename file)))
  (def appname  (module-loader-appname loader))
  (def out-file (add-build-path appname (c-filename file)))
  (set (module-src-file mod) src-file)
  (set (module-mtime mod) (file-mtime src-file))
  ;; (msg* out "Computing ast for %s.\n" name)
  (%print-cpu-usage (%su "START"))
  (def ast      (compute-ast src-file env))
  ;; (msg* out "Computing program for %s.\n" name)
  (def prg      (compute-program ast env))
  (%print-cpu-usage (%su "OPTIMIZE"))
  ;; (msg* out "Generating C code for %s.\n" name)
  (probe-directory (parent-directory out-file))
  (with-port (out-port (open <file-out-port> out-file))
    (dlet ((*definitions* (program-definitions prg))) 
      (generate-c-module out-port ast prg mod)))
  (do (fun (name)  ;; copy c files
        (def file       (module-name-to-relpath name))
        (def build-file (add-build-path appname file))
        (def src-file   (add-src-path file))
        (when (or (not (file-exists? build-file))
                  (>= (file-mtime src-file) (file-mtime build-file)))
          (file-copy src-file build-file)))
      (module-uses-c-files mod))
  (%print-cpu-usage (%su "EMIT"))
  ;;; No need to call roll-back-transaction here--we can
  ;;; rely on the compilation subtransaction to do all
  ;;; the work.
  mod)

(df module-up-to-date? (mod|<g2c-module> => <log>)
  (>= (module-mtime mod) (file-mtime (module-src-file mod))))

(df purge-outdated-modules (loader|<module-loader>)
  (def changed '())

  ;; Figure out which modules have changed...
  (do-module-loader-modules
   (fun (mod)
     (when (not (module-up-to-date? mod))
       (pushf changed (module-name mod))))
   loader)

  ;; ...notify the user, and dump them.
  (do (fun (name) (msg* out "%s has changed.\n" name)) changed)
  (remove-modules-by-name! loader changed))


;;;;=======================================================================
;;;;  Compiler Drivers
;;;;=======================================================================
;;;;  The new module-based compiler drivers.

;;; Create a module loader for the specified application.  'appname'
;;; will be used as the executable name.  'modname' will be used to
;;; recursively load all the modules which make up the application.
;;; TODO - Hide module loader inside wrapper object?
(df g2c-def-app (appname|<str> modname|<sym> => <g2c-module-loader>)
  (new <g2c-module-loader>
    module-loader-appname     appname
    module-loader-app-modname modname))

;;; Given a module loader, generate an up-to-date C program.
(df g2c-build-app (loader|<g2c-module-loader> => #f)
  (dlet ((*dynamic-compilation?* #f))
    (purge-outdated-modules loader)
    (def mod (probe-module loader (module-loader-app-modname loader)))
    (puts out "Searching for undefined global bindings.\n")
    (do-module-loader-modules report-undefined-global-bindings loader)
    (generate-c-application loader mod)
    (generate-makefile loader)
    #f))

(df g2c-test (x)
  (set *g2c-app* (g2c-def-app (cat "g2c-" (to-str x)) 'eval/main)))

(ddv *tmp-file-counter* -1)

(dm g2c-ast (ast env)
  (def mod      (environment-module env))
  (def name     (msg-to-str "exp-%d-%d" (process-id) (incf *tmp-file-counter*)))
  (def file     (add-tmp-path name))
  (def out-file (c-filename file))
  (def prg      (compute-program ast env))
  (with-port (out-port (open <file-out-port> out-file))
    (dlet ((*dynamic-compilation?* #t)
           (*definitions*          (program-definitions prg))) 
      (generate-c-module out-port ast prg mod)))
  file)

(dm g2c-exp (exp env)
  (g2c-ast 
   (objectify-with-subtransaction exp env *dynamic-compilation?* #f) env))

(dm compile-load (name mod)
  (def incs (module-uses-c-includes mod))
  (def istr (fold cat "" (map (op cat " -I" (as <str> _)) incs)))
  (def libs (module-uses-c-libraries mod))
  (def lstr (fold cat "" (map (op cat " -l" (as <str> _)) libs)))
  (%compile (%su (cat name *c-extension*)) (%su (cat name ".so")) 
            (%su istr) (%su lstr))
  (%load (%su (cat name ".so"))))

(dm g2c-eval (exp env)
  (def name (g2c-exp exp env))
  (compile-load name (environment-module env)))

(dm g2c-eval (ast|<program> env)
  (def name (g2c-ast ast env))
  (compile-load name (environment-module env)))

;;; Backwards compatibility for users: Build g2c itself.
(dv *g2c-app* (g2c-def-app "g2c" 'eval/main))
(dm g2c-top () (g2c-build-app *g2c-app*))
(dv g2c-goo g2c-top)
(dm g2c-clean ()
  (set *g2c-app* (g2c-def-app "g2c" 'eval/main))
  #f)

;;; Given a file name and an environment, compute an ast in that
;;; environment.
(dm compute-ast (filename ct-env)
  (def sexpr (read-file filename))
  (%print-cpu-usage (%su "READ"))
  (def ast
    (objectify-with-subtransaction sexpr ct-env *dynamic-compilation?* #f))
  (%print-cpu-usage (%su "AST"))
  ast)

;;; Given an ast 'e', prepare it for compilation to C.  Store any
;;; new global bindings into the environment 'scratch-env'.
(dm compute-program (e env)
  (def ana (analyze-calls e env))
  (%print-cpu-usage (%su "ANA"))
  (def box (insert-box! ana))
  (%print-cpu-usage (%su "BOX"))
  ;; (msg* out "BOX %=\n" box)
  ;; (def dyn (analyze-dynamic-extent box))
  ;; (%print-cpu-usage (%su "DYN"))
  ;; (msg* out "DYN %=\n" dyn)
  ;; (msg* out "CAL %=\n" cal)
  (def lft (lift! box))
  (%print-cpu-usage (%su "LFT"))
  ;; (msg* out "LFT %=\n" lft)
  (def prg (extract-things! lft))
  (%print-cpu-usage (%su "EXT"))
  ;; (msg* out "EXT %=\n" prg)
  (def flt (closurize-main! prg env 50))
  (%print-cpu-usage (%su "CLO"))
  ;; (msg* out "FLT %=\n" flt)
  (gather-temporaries! flt)
  (%print-cpu-usage (%su "TMP"))
  ;; (msg* out "FLT %=\n" flt)
  (register-allocate! flt #f)
  (%print-cpu-usage (%su "REG"))
  prg)

(dm generate-c-module (out e prg mod)
  (generate-header out mod)
  (generate-global-environment out mod)
  (generate-quotation-forwards out (program-quotations prg))
  (generate-function-forwards out (program-definitions prg))
  (generate-c-forms out (module-c-forms mod))
  (generate-function-bodies out (program-definitions prg))
  (unless *dynamic-compilation?*
    (generate-module-info out mod))
  (generate-module-init out mod (program-form prg)) 
  (generate-trailer out)
  prg)

(dm generate-c-application (loader|<module-loader> mod|<module>)
  (def appname   (module-loader-appname loader))
  (def init-name (cat appname "-init"))
  (def out-name  (add-build-path appname (c-filename init-name)))
  (with-port (out-port (open <file-out-port> out-name))
    (generate-header out-port mod)
    (generate-main out-port mod)
    (generate-trailer out-port))
  #f)

(ds for-mods ((,mod ,loader) ,@body)
  `(do-module-loader-modules (fun (,mod) ,@body) ,loader))

(dm generate-makefile (loader|<module-loader>)
  (def appname   (module-loader-appname loader))
  (def init-name (cat appname "-init"))
  (def exe-name  (exe-filename appname))
  (def sep       *path-separator*)
  (def out-name  (add-build-path appname "Makefile"))
  (with-port (out (open <file-out-port> out-name))
    (msg* out "C_OBJS_DD = $(patsubst %%,..%s%%,$(C_OBJS))\n" sep)
    (msg* out "%s%s: ..%sgrt.h\n" *c-extension* *obj-extension* sep)
    (msg* out "\t$(CC) -I.. ")
    (for-mods (mod loader)
      (do (fun (i) (unless (include-filename i) (msg* out "-I%s " i)))
          (module-uses-c-includes mod)))
    (msg* out "$(CFLAGS) -DDEFAULT_GOO_ROOT=\\\"$(GOO_ROOT)\\\" -c -o $@ $<\n\n")
    (msg* out "OBJS = \\\n")
    (for-mods (mod loader)
      (loc ((put-obj (name)
              (msg* out "\t%s \\\n" 
                    (obj-filename (module-name-to-relpath name)))))
        (put-obj (module-name mod)) 
        (do (fun (name) (when (suffix? name ".c") (put-obj (as <sym> (sub name 0 (- (len name) 2))))))
            (map (fun (n) (as <str> n)) (module-uses-c-files mod)))))
    (msg* out "\t%s\n\n" (obj-filename init-name))
    (msg* out "%s: $(C_OBJS_DD) $(OBJS)\n" exe-name)
    (msg* out "\t$(CC) $(LDFLAGS) -o %s $(C_OBJS_DD) $(OBJS) $(LIBS)"
         exe-name sep sep)
    (for-mods (mod loader)
      (do (fun (l) (msg* out " -l%s" l)) (module-uses-c-libraries mod)))
    (msg* out "\n\nclean:\n\trm -f %s $(OBJS)\n" exe-name sep)))

(dm generate-c-forms (out definitions)
  (puts out "\n/* C-FORMS: */\n\n")
  (for ((def definitions))
    (to-c def #f 0 out)))

;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
;;;              generation

;;; file header and trailer are simple.

(dm pp (e out)
  ;; (print e out pretty?: #t) ;; TODO: PRETTY?
  (write out e)) 

(dv $now-mod-var-name "_mod")

(dm include-filename (x) #f)

(dm include-filename (x|<sym>) 
  (def x (as <str> x))
  (and (prefix? x "<") (suffix? x ".h>") x))

(dm include-filename (x|<str>) 
  (and (suffix? x ".h") (cat "\"" x "\"")))

(dm generate-header (out mod)
  (def modname (module-name mod))
  (def modvar $now-mod-var-name)
  (msg* out "/* GOO 2 C $REVISION: 0.120 $ \n")
  (msg* out "  */\n\n#include \"grt.h\"\n")
  (when *dynamic-compilation?*
    (msg* out "#include \"dlgrt.h\"\n"))
  (do (fun (i) 
        (def ifn (include-filename i))
        (when ifn (msg* out "#include " ifn "\n")))
      (module-uses-c-includes mod))
  (msg* out "\nstatic PSTR %s = PNUL;\n" modvar)
  (msg* out "\nstatic P sloc (int line) {\n")
  (msg* out "  if (%s == PNUL) %s = " modvar modvar)
  (generate-quotation out modname) (msg* out ";\n")
  (msg* out "  return %s(%s((P)line), %s);\n" 
        (mangle-boot-name "%src-loc") (mangle-boot-name "%ib") modvar)
  (msg* out "}\n")
  )

(dm generate-trailer (out)
  (msg* out "\n/* END OF GENERATED CODE. */\n"))

;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
;;; generate global environment. for all global-bindings allocate a
;;; location to hold it. we also give the real name to the macro so
;;; that some reflective capabilities can be added to c.

;;; gb* is a list of instances of global-binding.

(dm generate-global-environment (out mod)
  (msg* out "\n/* MODULE ENVIRONMENT: %s */\n\n" (module-name mod))
  (loc ((gen-binding (b)
          (generate-global-binding out (not (binding-native-to? b mod)) b)))
    (if *dynamic-compilation?*
        (do gen-binding (module-referenced-bindings mod))
        (do-static-global-bindings
         gen-binding (module-target-environment mod)))))

(dm generate-global-binding (out imported? gb)
  (def kind (binding-kind gb))
  (when (or (== kind 'global) (== kind 'runtime)  (== kind 'dynamic))
    (def name (binding-name gb))
    (puts out (case kind (('runtime)  "RTV") (('dynamic) "DYN") (#t "")))
    (msg* out "%s(%s,%s,%s);\n" 
          (if imported? "EXT" "DEF")
          (mangle-binding gb)
          (mangle-string-literal (binding-module-name gb))
          (mangle-string-literal name))))

;;;; NAME MANGLING

(dv $module-separator               "Y")
(dv $local-suffix                   "_")
(dv $hygiene-marker                 "F")
(dv $escape-separator               "Z")
(dv $iep-suffix                     "I")
(dv $method-mangled-marker-string   "M")

;; Note that the following must be characters rather than strings since
;; the initialization of mangles tables assumes that.

(dv $module-marker             (elt $module-separator 0))
(dv $local-marker              (elt $local-suffix 0))
(dv $hygiene-char              (elt $hygiene-marker 0))
(dv $escape-marker             (elt $escape-separator 0))
(dv $iep-marker                (elt $iep-suffix 0))
(dv $method-mangled-marker     (elt $method-mangled-marker-string 0))

(dv $min-character-code 0)
(dv $max-character-code 255) ;; We allow 8 bit ascii.

;;; MANGLING

(dv *mangle-buffer* (new <vec>))

(dv $mangles-data
  (tup #(#\- #\_) #(#\! #\X) #(#\$ #\D) #(#\% #\P) #(#\* #\T) 
       #(#\/ #\S) #(#\< #\L) #(#\> #\G) #(#\? #\Q) #(#\+ #\A)
       #(#\& #\B) #(#\^ #\C) #(#\_ #\U) #(#\@ #\O) #(#\= #\E)
       #(#\~ #\N) #(#\| #\K) #(#\. #\I)))

(df char-buffer-as-string (buffer|<vec> => <str>)
  (def buffer-size|<int> (len buffer))
  (def string|<str>      (fab <str> buffer-size))
  ;; without-bounds-checks
  (rep loop ((i 0)) 
    (when (< i buffer-size)
      (set (fab-elt string i) (low-elt buffer i))
      (loop (+ i 1))))
  ;; end without-bounds-checks
  string)

(dv $c-escapes
  (let ((vec (fill (fab <vec> ascii-limit) #f)))
    (set (elt vec (as <int> #\tab)) "\\t")
    (set (elt vec (as <int> #\page)) "\\f")
    (set (elt vec (as <int> #\return)) "\\r")
    (set (elt vec (as <int> #\newline)) "\\n")
    (set (elt vec (as <int> #\")) "\\\"")
    (set (elt vec (as <int> #\\)) "\\\\")
    (as <tup> vec)))

(dm mangle-string-literal (str|<str> => <str>)
  (set (len *mangle-buffer*) 0)
  (def len (len str))
  (add! *mangle-buffer* #\")
  (rep loop ((i 0))
    (if (= i len)
        (seq (add! *mangle-buffer* #\")
             (char-buffer-as-string *mangle-buffer*))
        (let ((c   (elt str i))
              (enc (elt $c-escapes (as <int> c))))
          (if (= enc #f)
              (add! *mangle-buffer* c)
              (cat! *mangle-buffer* enc))
          (loop (+ i 1))))))

(dm mangle-string-literal (sym|<sym> => <str>)
  (mangle-string-literal (sym-name sym)))

(dv ($number-characters <str>) "0123456789")

(dm mangle-integer (number|<int> => <str>)
  (as <str>
      (rep process-integer (((number <int>) number) ((index <int>) 1))
        (def (tup quotient|<int> remainder|<int>) (trunc/ number 10))
        (def digit|<chr> (elt $number-characters remainder))
        (if (= quotient 0)
            (let ((result|<vec> (fab <vec> index)))
              (set (elt result 0) digit)
              result)
            (let ((result|<vec> (process-integer quotient (+ index 1))))
              (set (elt result (- (len result) index)) digit)
              result)))))

(dv $name-mangler-table
  (let ((table (fab <vec> (+ $max-character-code 1))))
    ;; fill with default manglings
    (for ((i (range $min-character-code <= $max-character-code)))
      (set (elt table i)
           (cat $escape-separator (mangle-integer i) $escape-separator)))
    ;; fill in special cases
    (for ((mangle $mangles-data))
      (set (elt table (as <int> (elt mangle 0))) (elt mangle 1)))
    ;; fill C allowable versions
    (for ((i (range (as <int> #\a) <= (as <int> #\z))))
      (set (elt table i) (as <chr> i)))
    (for ((i (range (as <int> #\0) <= (as <int> #\9))))
      (set (elt table i) (as <chr> i)))
    table))

;;; Name mangler

(df mangler-reset (buffer|<vec>)
  (set (len buffer) 0))

(df mangle-name-into (buf|<vec> name|<str>)
  (for ((c name))
    (add! buf (elt $name-mangler-table (as <int> (to-lower c)))))
  buf)

(dm mangle-raw-name (name|<str> => <str>)
  (mangler-reset *mangle-buffer*)
  (mangle-name-into *mangle-buffer* name)
  (char-buffer-as-string *mangle-buffer*))

(dm mangle-raw-name (name|<sym> => <str>)
  (mangle-raw-name (as <str> name)))

(dm mangle-local-name (name|<str> => <str>)
  (mangler-reset *mangle-buffer*)
  (mangle-name-into *mangle-buffer* name)
  (add! *mangle-buffer* $local-marker)
  (char-buffer-as-string *mangle-buffer*))

(dm mangle-local-name (name|<sym> => <str>)
  (mangle-local-name (as <str> name)))

;; TODO: GO AWAY
(df buf-cat2! (buf|<vec> name|<str>)
  (def len (len name))
  (rep loop ((i 0))
    (when (< i len)
      (add! buf (low-elt name i))
      (loop (+ i 1)))))

(dm mangle-module-into (buf|<vec> mod|<module>)
  (let ((name (or/set (module-mangled-name mod)
                      (char-buffer-as-string 
                       (mangle-name-into
                        (fab <vec> 0) (as <str> (module-name mod)))))))
    (buf-cat2! buf name)))

(dm mangle-global-name (mod name|<str> => <str>)
  (mangler-reset *mangle-buffer*)
  ;; Keep internal names as short as possible.
  (unless (or (== mod $goo-boot-module-name) 
              (== (module-name mod) $goo-boot-module-name))
    (add! *mangle-buffer* $module-marker)
    (mangle-module-into *mangle-buffer* mod))
  (add! *mangle-buffer* $module-marker)
  (mangle-name-into *mangle-buffer* name)
  (char-buffer-as-string *mangle-buffer*))

(dm mangle-global-name (mod name|<sym> => <str>)
  (mangle-global-name mod (as <str> name)))

;; Mangle a name which is defined in boot.goo.
;; Be sure to provide a matching EXT declaration in grt.h.
(df mangle-boot-name (name)
  (mangle-global-name $goo-boot-module-name name))

(df mangle-quotation-name (name|<int>)
  (mangler-reset *mangle-buffer*)
  (buf-cat2! *mangle-buffer* "lit_")
  (buf-cat2! *mangle-buffer* (mangle-integer name))
  (char-buffer-as-string *mangle-buffer*))

(dm mangle-binding (binding|<module-binding>)
  (or/set (binding-mangled-name binding)
          (if (== (binding-kind binding) 'quotation)
              (mangle-quotation-name (binding-name binding))
              (mangle-global-name
               (binding-module binding) (binding-name binding)))))

(df mangle-local-marked-name (name|<str> marker|<int>)
  (mangler-reset *mangle-buffer*)
  (mangle-name-into *mangle-buffer* name)
  (add! *mangle-buffer* $hygiene-char)
  (buf-cat2! *mangle-buffer* (mangle-integer marker))
  (char-buffer-as-string *mangle-buffer*))

(dm mangle-binding (binding|<local-binding>)
  (or/set (binding-mangled-name binding)
          (mangle-local-name (binding-name binding))))

(dm mangle-binding (binding|<renamed-local-binding>)
  (or/set (binding-mangled-name binding)
          (mangle-local-marked-name 
           (as <str> (binding-name binding)) (binding-index binding))))

;;; EMISSION

(ds for-commas (,out-val (,@clauses) ,@body)
  (let ((out-var (gensym)))
    `(let ((,out-var ,out-val))
       (for (,@clauses (first? (first-then (op #t) (op #f))))
         (unless first? (put ,out-var #\,))
         ,@body))))

(ds maybe-between-parentheses ((,out-val) ,@body)
  (let ((out-var (gensym)) (ps? (gensym)))
    `(let ((,out-var ,out-val) (,ps? (not *gen-statements?*)))
       (when ,ps? (put ,out-var #\()) ,@body (when ,ps? (put ,out-var #\))))))

(ds between-parentheses ((,out-val) ,@body)
  (let ((out-var (gensym)))
    `(let ((,out-var ,out-val))
       (put ,out-var #\() ,@body (put ,out-var #\)))))

(ds between-parentheses-comma-separated ((,out-val) ,@body)
  (let ((out-var (gensym)))
    `(let ((,out-var ,out-val))
       (put ,out-var #\() 
       ,@(rep loop ((forms '()) (body body) (first? #t))
           (if (nul? body)
               (rev! forms)
               (loop (pair (head body)
                           (pair (or first? `(put ,out-var #\,)) forms))
                     (tail body) 
                     #f)))
       (put ,out-var #\)))))

(dm gen-result (e|<program> d out => <log>)
  (def reg (program-register e))
  (and reg (msg* out "T%d = " reg) #t))

(dm gen-depth (d|<int> out)
  (for ((i (below d)))
    (puts out "  ")))

;;; either generate C statements or expressions

(ddv *gen-statements?* #t)

(ds with-statement ((,d ,out) ,@body)
  `(seq (when *gen-statements?* (gen-depth ,d ,out))
        ,@body
        (when *gen-statements?* (puts ,out ";\n"))))

(ds may-comma ((,out-val) ,@body)
  (let ((out-var (gensym)))
    `(let ((,out-var ,out-val)) 
       ,@body 
       (unless *gen-statements?* (puts ,out-var ", ")))))

(ds with-statement-may-comma ((,d ,out) ,@body)
  `(may-comma (,out) (with-statement (,d ,out) ,@body)))

(ds with-expression ((,e ,d ,out) ,@body)
  `(with-statement (,d ,out)
     (when *gen-statements?* (gen-result ,e ,d ,out))
     ,@body))

(ds with-used-expression ((,e ,d ,out) ,@body)
  `(when (program-register ,e)
     (with-expression (,e ,d ,out) ,@body)))

;;; QUOTATION EMISSION

(dm generate-quotation-forwards (out (qb* <col>))
  (puts out "\n/* FORWARD QUOTATIONS: */\n\n")
  (for ((qb qb*))
    (msg* out "DEFLIT(lit_%s);\n" (binding-name qb))))

(dm generate-quotations (out qb*|<lst>)
  (for ((qb (rev qb*))) ;; TODO: BIP
    (with-statement (1 out)
      (msg* out "lit_%s = " (binding-name qb))
      (generate-quotation out (binding-info qb)))))

(d. *lits*    (fab <vec> 0))
(d. *lits-at* (fab <tab> 0))

(df @lit (n) (elt *lits* n))

(dm ref-lit (x)
  (elt! *lits-at* x {\ (def n (len *lits*)) (add! *lits* x) n }))

(dm generate-quotation (out x|<any>)
  (msg* out "%s((P)%d)" (mangle-boot-name "%lit") (ref-lit x)))

(dm false-name ()
  (mangle-boot-name "%false"))

(dm generate-quotation (out qb|<log>)
  (puts out (mangle-boot-name (if qb "%true" "%false"))))

(dm generate-quotation (out (qb (t= '())))
  (puts out (mangle-boot-name "nil")))

(dm generate-quotation (out qb|<lst>)
  (out-list-builder (fun (x) (generate-quotation out x)) out qb))

(dm generate-quotation (out x|<int>)
  (msg* out "%s((P)%d)" (mangle-boot-name "%int") x))

(dm generate-quotation (out x|<chr>)
  (msg* out "%s((P)%d)" (mangle-boot-name "%chr") (as <int> x)))

(dm float-to-c-string (o|<flo> => <str>)
  (def s (num-to-str o))
  ;;---*** Is there a better way to do this???
  (esc done
    (rep loop ((i (- (len s) 1)))
      (if (> i (neg 1)) ;; TODO: -1
          (case (elt s i)
            ;;---*** Should be #\f but GCC complains!
            ((#\s) (set (elt s i) #\e) (done #f)) 
            ((#\d) (set (elt s i) #\e) (done #f)) 
            ;;---*** Should be #\l but GCC complains!
            ((#\x) (set (elt s i) #\e) (done #f)) 
            (#t    (loop (- i 1))))
          s))))

(dm generate-quotation (out x|<flo>)
  (msg* out "%s(FLOINT(%s))" 
       (mangle-boot-name "%flo") (float-to-c-string x)))

(dm generate-quotation (out x|<str>)
  (msg* out "%s((P)%s)" 
        (mangle-boot-name "%sb") (mangle-string-literal x)))

(dm generate-quotation (out x|<vec>)
  ;; TODO: TIE TOGETHER
  (msg* out "XCALLN(1, %s, %s" (mangle-boot-name "vec") (len x))
  (for ((e x))
    (puts out ", ")
    (generate-quotation out e))
  (puts out ")"))

(dm generate-quotation (out x|<tup>)
  ;; TODO: TIE TOGETHER
  (msg* out "XCALLN(1, %s, %s" (mangle-boot-name "tup") (len x))
  (for ((e x))
    (puts out ", ")
    (generate-quotation out e))
  (puts out ")"))

(dm generate-quotation (out x|<sym>)
  (msg* out "%s((P)%s)" 
        (mangle-boot-name "%%sym") (mangle-string-literal x)))

;;;
;;; CONVERT AN EXPRESSION TO C

;;; GENERATE THE NAME USED IN C FOR A BINDING.

(df binding->c (binding out)
  (puts out (mangle-binding binding)))

;;; WORKS FOR LOCAL- GLOBAL- PREDEFINED- REFERENCES EXCEPT FOR FREE-REFERENCES.

(dg reference->c (v|<binding> out))

(dm reference->c (v|<binding> out)
  (binding->c v out))

(dm reference->c (v|<module-binding> out)
  (puts out 
        (case (binding-kind v)
          (('quotation) "LITREF")
          (('runtime)   "RTVREF")
          (('dynamic)   "DYNREF")
          (#t           "VARREF")))
  (between-parentheses (out)
    (binding->c v out)))

(dg to-c (e|<program> f d out))

(dm to-c (e|<top-level-form> f d out)
  (generate-quotations out (form-quotations e))
  (generate-functions (form-definitions e) f d out)
  (to-pc (form-program e) f d out)
  (with-used-expression (e d out) (gen-ref (form-program e) f d out)))

(dm to-c (e|<passive-program> f d out)
  (unless *gen-statements?*
    (gen-ref* e out)))

(dm gen-ref* (e|<reference> out)
  (reference->c (reference-binding e) out))

(dm gen-ref* (e|<free-reference> out)
  (puts out "FREEREF")
  (between-parentheses (out)
    (msg* out "%d" (reference-offset e))))

(dm gen-ref* (e|<program> out)
  (def reg (program-register e))
  (if reg (msg* out "T%d" reg) (puts out "T_1")))

(dm gen-ref* (e|<raw-constant> out)
  (msg* out "(P)%s" (constant-value e)))

(dm gen-ref* (e|<constant> out)
  (generate-quotation out (constant-value e)))

(dm gen-ref* (e|<sequential> out)
  (gen-ref* (last e) out))

(dm gen-ref* (e|<locals> out)
  (gen-ref* (locals-body e) out))

(dm gen-ref* (e|<fix-let> out)
  (gen-ref* (fix-let-body e) out))

(dm gen-ref* (e|<loop> out)
  (gen-ref* (loop-body e) out))

(df gen-ref (e f d out)
  (if *gen-statements?*
      (gen-ref* e out)
      (to-c e f d out)))

;;; TO-C

;;; this is used for pregenerating nested goo expressions
;;; it's turned off when doing expression-oriented emission

(dm to-pc (e f d out)
  (when *gen-statements?*
    (to-c e f d out)))

(dm to-c (e|<global-assignment> f d out)
  (to-pc (assignment-form e) f d out)
  (with-expression (e d out)
    (puts out
          (case (binding-kind (assignment-binding e))
            (('runtime) "RTVSET(")
            (('dynamic) 
             (if (isa? e <dynamic-definition>) "DYNDEFSET(" "DYNSET("))
            (#t         "VARSET(")))
    (binding->c (assignment-binding e) out)
    (puts out ",") 
    (gen-ref (assignment-form e) f d out)
    (puts out ")")))

(dm to-c (e|<bound?> f d out)
  (to-pc (bound?-default e) f d out)
  (with-used-expression (e d out) ;; TODO: FIX FOR DYN
    (when (isa? (bound?-reference e) <runtime-reference>) (puts out "RTV"))
    (puts out "VARREF_OR")
    (between-parentheses-comma-separated (out)
      (binding->c (reference-binding (bound?-reference e)) out)
      (gen-ref (bound?-default e) f d out))))

;; TODO: DOES REF NEED TO BE TO-C'D

(dm to-c (e|<box-read> f d out)
  (def ref (box-reference e))
  (with-used-expression (e d out)
    (if (binding-closed-over? (reference-binding ref))
        { (puts out "BOXGET")
          (between-parentheses (out) (gen-ref ref f d out)) }
        (gen-ref ref f d out))))

(dm to-c (e|<box-write> f d out)
  (def ref (box-reference e))
  (to-pc (box-form e) f d out)
  (with-expression (e d out)
    (if (binding-closed-over? (reference-binding ref))
        { (puts out "BOXPUT")
          (between-parentheses-comma-separated (out) 
            (gen-ref (box-form e) f d out)
            (gen-ref ref f d out)) }
        { (gen-ref ref f d out) 
          (puts out " = ")
          (gen-ref (box-form e) f d out) })))

(dm to-c (e|<box-creation> f d out)
  (def binding (reference-binding (box-reference (box-reference e))))
  (when (binding-closed-over? binding)
    (with-expression (e d out)
      (binding->c binding out)
      (puts out " = BOXFAB")
      (between-parentheses (out) (binding->c binding out)))))

(dm bb? (x) #f)

(dm bb? (x|<predefined-application>)
  (and (== (binding-name (application-binding x)) '%bb)
       (1st (application-arguments x))))

(dm bb? (x|<fix-let>)
  (bb? (fix-let-body x)))

(dm to-c (e|<alternative> f d out)
  ;;; gcc can't optimize if with %bb tests
  (def bb-tst (bb? (alternative-condition e)))
  (def tst    (or bb-tst (alternative-condition e)))
  (if *gen-statements?*
      { (to-pc (alternative-condition e) f d out)
        (gen-depth d out) (puts out "if (") (gen-ref tst f d out)
        (if bb-tst 
            (puts out ") {\n")
            (msg* out " != %s) {\n" (false-name)))
        (to-c (alternative-consequent e) f (+ d 1) out)
        (with-used-expression (e (+ d 1) out)
          (gen-ref (alternative-consequent e) f d out))
        (gen-depth d out) (puts out "} else {\n")
        (to-c (alternative-alternant e) f (+ d 1) out)
        (with-used-expression (e (+ d 1) out)
          (gen-ref (alternative-alternant e) f d out))
        (gen-depth d out) (puts out "}\n") }
      { (puts out "((") 
        (to-c tst f d out)
        (msg* out " != %s) ? " (false-name))
        (to-c (alternative-consequent e) f d out)
        (puts out " : ")
        (to-c (alternative-alternant e) f d out)
        (puts out ")") }))

(dm to-c (e|<sequential> f d out)
  (if *gen-statements?*
      (do (fun (x) (to-c x f d out)) e)
      { (puts out "(")
        (for-commas out ((x e)) (to-c x f d out))
        (puts out ")") } ))

(ddv *loop-arg-counter* -1)

(dm to-c (e|<loop> f d out)
  (def n (set (loop-continue e) (incf *loop-arg-counter*)))
  (gen-depth d out) (msg* out "LOOP_%d: {\n" n)
  (def bindings (loop-bindings e))
  (unless (nul? bindings)
    (with-statement ((+ d 1) out)
      (puts out "P ")
      (for-commas out ((b bindings) (i (from 0)))
        (msg* out "a%d_%d" n i))))
  (to-c (loop-body e) f (+ d 1) out)
  (gen-depth d out)
  (msg* out "}\n"))

(dm to-c (e|<loop-application> f d out)
  (def loop (application-loop e))
  (def n    (loop-continue loop))
  (for ((arg (application-arguments e)))
    (to-pc arg f d out))
  (for ((arg (application-arguments e)) (i (from 0)))
    (with-statement (d out)
      (msg* out "a%d_%d = " n i)
      (gen-ref arg f d out)))
  (for ((binding (loop-bindings loop)) (i (from 0)))
    (with-statement (d out)
      (binding->c binding out)
      (msg* out " = a%d_%d" n i)))
  (with-statement (d out)
    (msg* out "goto LOOP_%d" n)))

(dv $number-call-templates 5)

(dm to-c (e|<regular-application> f d out)
  (def function (application-function e))
  (def n        (len (application-arguments e)))
  (to-pc (application-function e) f d out)
  (for ((arg (application-arguments e)))
    (to-pc arg f d out))
  (with-expression (e d out)
    (msg* out "%sCALL%s" 
          (if (not f) "XX" (if (isa? f <ast-primitive>) "X" ""))
          (if (> n $number-call-templates) "N" n))
    (between-parentheses (out)
      (puts out (if (application-known? e) "0," "1,") )
      (gen-ref (application-function e) f d out)
      (when (> n $number-call-templates) (msg* out ",%s" n))
      (for ((arg (application-arguments e)))
        (put out #\,) (gen-ref arg f d out)))))

(dm to-c (e|<method-application> f d out)
  (to-pc (application-next-methods e) f d out)
  (maybe-between-parentheses (out)
    (with-statement-may-comma (d out)
      (puts out (mangle-boot-name "%next-methods-reg-setter"))
      (between-parentheses (out)
        (gen-ref (application-next-methods e) f d out)))
    (sup e f d out)))

(dm to-c (e|<arguments> f d out)
  (for-commas out ((x e))
    (gen-ref x f d out)))

(dm to-c (e|<c-inline> f d oot)
  (dlet ((*gen-statements?* #f))
    (for ((ref (c-inline-refs e)))
      (to-pc ref f d oot)))
  (def e?  (c-inline-expr? e))
  (def lps (if f (if e? "(P)(" (cat (false-name) ";\n{ "))  ""))
  (def rps (if f (if e? ");"   "}\n")                       ""))
  (when f (gen-depth d oot) (gen-result e d oot))
  (puts oot lps)
  (dlet ((*gen-statements?* #f))
    (rep loop ((strs (c-inline-strs e)) (refs (c-inline-refs e)))
      (if (nul? strs)
          (puts oot rps)
          (let ((str (head strs)))
            (if str
                (seq (emit oot str) 
                     (loop (tail strs) refs))
                (seq (to-c (head refs) f d oot)
                     (loop (tail strs) (tail refs)))))))))

(dm to-c (e|<fix-let> f d out)
  (maybe-between-parentheses (out)
    (def low-let? (isa? e <low-let>))
    (for ((binding (fix-let-bindings e))
          (type    (fix-let-types e))
          (init    (fix-let-arguments e)))
      (to-pc init f d out)
      (unless (or (unconstrained-type? type) low-let?)
        (to-pc type f d out)
        (with-statement-may-comma (d out)
          (puts out "check_type")
          (between-parentheses-comma-separated (out)
            (gen-ref init f d out) (gen-ref type f d out))))
      (with-statement-may-comma (d out)
        (binding->c binding out)
        (puts out " = ") (gen-ref init f d out)))
    (to-c (fix-let-body e) f d out)))

(dm to-c (e|<locals> f d out)
  (maybe-between-parentheses (out)
    (for ((binding (locals-bindings e)) (init (locals-functions e)))
      (funshell-to-c binding init #f d out)
      (with-statement-may-comma (d out)
        (binding->c binding out)
        (puts out " = ") (gen-ref init f d out)))
    (do2 (fun (lb lf) (may-comma (out) (funinit-to-c lb lf f d out)))
         (locals-bindings e) (locals-functions e))
    (to-c (locals-body e) f d out)))

(dm to-c (e|<bind-exit> f d out)
  (to-pc (bind-exit-main-fun e) f d out)
  (with-expression (e d out)
    (puts out "with_exit")
    (between-parentheses (out) (gen-ref (bind-exit-main-fun e) f d out))))

(dm to-c (e|<unwind-protect> f d out)
  (to-pc (unwind-protect-protected-thunk e) f d out)
  (to-pc (unwind-protect-cleanup-thunk e) f d out)
  (with-expression (e d out)
    (puts out "with_cleanup")
    (between-parentheses-comma-separated (out)
      (gen-ref (unwind-protect-protected-thunk e) f d out)  
      (gen-ref (unwind-protect-cleanup-thunk e) f d out))))

(dm to-c (e|<monitor> f d out)
  (to-pc (monitor-type e) f d out)
  (to-pc (monitor-info e) f d out)
  (to-pc (monitor-test e) f d out)
  (to-pc (monitor-handler e) f d out)
  (to-pc (monitor-main-thunk e) f d out)
  (with-expression (e d out)
    (puts out "XCALLN")
    (between-parentheses-comma-separated (out)
      (puts out "1")
      (puts out (mangle-boot-name "%with-monitor"))
      (puts out "5")
      (gen-ref (monitor-type e) f d out)
      (gen-ref (monitor-info e) f d out)
      (gen-ref (monitor-test e) f d out)
      (gen-ref (monitor-handler e) f d out)
      (gen-ref (monitor-main-thunk e) f d out))))

(dm to-c (e|<predefined-application> f d out)
  (def binding (application-binding e))
  (for ((arg (application-arguments e)))
    (to-pc arg f d out))
  (with-expression (e d out)
    (msg* out "(P)%s" (mangle-binding (application-binding e)))
    (between-parentheses (out)
      (for-commas out ((arg (application-arguments e)))
        (gen-ref arg f d out)))))

(dm to-c (e|<closure-creation> f d out)
  (def n (len (closure-creation-free e)))
  (def f (elt *definitions* (closure-creation-index e)))
  (if (== n 0)
      (with-used-expression (e d out)
        (generate-function-binding out f))
      (seq (do (fun (x) (to-pc x f d out)) (closure-creation-free e))
           (with-expression (e d out)
             (puts out "FUNFAB")
             (between-parentheses (out)
               (generate-function-binding out f)
               (msg* out ",%d" n)
               (for ((x (closure-creation-free e)))
                 (put out #\,) (gen-ref x f d out)))))))

(dm funshell-to-c (b|<binding> e|<closure-creation> f d out)
  (def n (len (closure-creation-free e)))
  (def f (elt *definitions* (closure-creation-index e)))
  (with-expression (e d out)
    (if (== n 0)
        (generate-function-binding out f)
        ;; (msg* out "fun_%s" (closure-creation-index e))
        (seq (puts out "FUNSHELL")
             (between-parentheses-comma-separated (out)
               (msg* out "%d" (if (binding-dynamic-extent? b) 1 0))
               (generate-function-binding out f)
               (msg* out "%d" n))))))

(dm funinit-to-c (b|<binding> e|<closure-creation> f d out)
  (def n (len (closure-creation-free e)))
  (unless (== n 0)
    (do (fun (x) (to-pc x f d out)) (closure-creation-free e))
    (with-statement (d out)
      (puts out "FUNINIT")
      (between-parentheses (out)
        (binding->c b out)
        (msg* out ", %s" n)
        (for ((x (closure-creation-free e)))
          (put out #\,) (gen-ref x f d out))))))

(dm to-c (e|<ast-macro-definition> f d out)
  (to-pc (assignment-form e) #f d out)
  (with-expression (e d out)
    (puts out (mangle-boot-name "%macro"))
    (between-parentheses-comma-separated (out)
      (generate-quotation out (binding-module-name (assignment-binding e)))
      (generate-quotation out (binding-name (assignment-binding e)))
      (gen-ref (assignment-form e) f d out))))

(dm out-list-builder (f|<fun> out elts|<lst>)
  (if (nul? elts)
      (puts out (mangle-boot-name "nil"))
      (seq
        (puts out (mangle-boot-name "%%list"))
        (between-parentheses (out)
          (msg* out "%d" (len elts))
          (for ((e elts))
            (put out #\,)
            (f e))))))


(dm gen-fab-list (out refs|<fab-list>)
  (out-list-builder (fun (x) (gen-ref x #f 0 out)) out refs))

(dm generate-function-specs (out sig)
  (gen-fab-list out (req-sig-specs sig)))

(dm to-c (e|<ast-signature> f d out)
  (do (fun (x) (to-pc x f d out)) (signature-specs e))
  (to-pc (signature-value e) f d out)
  (with-expression (e d out)
    (puts out (mangle-boot-name "%fab-sig"))
    (between-parentheses-comma-separated (out)
      (generate-function-specs out e)
      (gen-ref (signature-nary? e) f d out)
      (gen-ref (signature-arity e) f d out)
      (gen-ref (signature-value e) f d out)
      (puts out (mangle-boot-name "nil")))))

(dm to-c (e|<ast-generic> f d out)
  (to-pc (function-signature e) f d out)
  (with-expression (e d out)
    (puts out (mangle-boot-name "%fab-gen"))
    (between-parentheses-comma-separated (out)
      (gen-ref (function-signature e) f d out)
      (gen-ref (function-debug-name e) f d out)
      (gen-ref (function-names e) f d out)
      (puts out (mangle-boot-name "%false")))))

;;;
;;; FUNCTION DEFINITIONS

(dm generate-function-forwards (out definitions)
  (puts out "\n/* FUNCTIONS: */\n\n")
  (for ((def definitions))
    (generate-function-forward out def)))

(dm generate-function-forward (out defn|<ast-primitive>)
  (msg* out "%s P %s (" 
        (if *dynamic-compilation?* "static" "extern")
        (mangle-binding (function-binding defn)))
  (for-commas out ((i (below (len (function-bindings defn)))))
    (puts out "P"))
  (puts out ");\n"))

(dm generate-function-binding (out defn)
  (def name (function-binding defn))
  (if (and (isa? name <module-binding>) 
           (mem? '(global runtime) (binding-kind name)))
      (puts out (mangle-binding name))
      ;; (msg-out "UNNAMED %=\n" defn)
      (if (== name #f)
          (msg* out "fun_%s" (function-index defn))
          (let ((name 
                  (if (isa? name <local-binding>) (binding-name name) name)))
            (msg* out "fun_%s_%s"
                  (mangle-raw-name name) (function-index defn))))))

(dm generate-function-forward (out defn)
  (def bound? (isa? (function-binding defn) <module-binding>))
  (puts out (if bound?  "FUNFOR(" "LOCFOR("))
  (generate-function-binding out defn)
  (puts out ");\n"))

(dm generate-function-bodies (out definitions)
  (puts out "\n/* FUNCTION CODES: */\n")
  (do (fun (def) 
        (generate-function-code out def))
      definitions))

(dm generate-functions (definitions f d out)
  (do (fun (def) 
        (unless (isa? def <ast-primitive>)
          (generate-closure-structure def f d out)))
      (rev definitions)))

(dm generate-closure-structure (definition f d out)
  (to-pc (function-signature definition) f d out)
  (with-expression (definition d out)
    (generate-function-binding out definition)
    (msg* out " = %s" 
          (if (function-inlineable? definition)
              (mangle-boot-name "%fab-met-inlineable")
              (mangle-boot-name "%fab-met")))
    (between-parentheses-comma-separated (out)
      (generate-function-body-reference out definition)
      (gen-ref (function-signature definition) f d out)
      (gen-ref (function-debug-name definition) f d out)
      (gen-ref (function-names definition) f d out)
      (if (program-line definition)
          (msg* out "sloc(%d)" (program-line definition))
          (puts out (mangle-boot-name "%false")))
      (gen-ref (function-source definition) f d out))))

(dm generate-function-body-reference (out definition)
  (puts out "FUNCODEREF(")
  (generate-function-binding out definition)
  (puts out ")"))

;; TODO: RIP THIS OUT AND USE REAL PARAMETERS
;; MAKE CALL SMART AND RESTIFY IF NEC
;; WOULD LIKE TO AVOID XEP APPROACH FIRST GO ROUND

(dm generate-return (defn|<ast-primitive> f d out)
  (with-statement (d out)
    (puts out "return ") (gen-ref (function-body defn) f d out)))

(dm generate-return (defn f d out)
  (with-statement (d out)
    (when (unconstrained-type? (function-value defn))
      (put out #\Q))
    (puts out "RET")
    (between-parentheses (out) (gen-ref (function-body defn) f d out))))

(dm generate-function-code (out e|<ast-primitive>)
  (msg* out "\n%s%sP " 
        (if *dynamic-compilation?* "static " "")
        (if (function-inlineable? e) "INLINE " ""))
  (binding->c (function-binding e) out)
  (between-parentheses (out)
    (for-commas out ((binding (function-bindings e)))
      (puts out "P ") (binding->c binding out)))
  (puts out " {\n")
  (generate-local-temporaries (function-temporaries e) out)
  (generate-registers (function-registers e) out)
  (puts out "DEFCREGS();\n")
  (to-c (function-body e) e 1 out)
  (generate-return e #f 1 out)
  (puts out "}\n"))

(dm dispatcher? (definition)
  (def binding (function-binding definition))
  (and (isa? binding <module-binding>)
       (let ((name (as <str> (binding-name binding))))
         (or (= name "%dispatch") 
             (= (finds name "-dispatch") 
                (- (len name) (len "-dispatch"))))))) ;; suffix?

(dm generate-function-code (out definition)
  (def offset 0)
  (def bindings (function-bindings definition))
  (def bound? (isa? (function-binding definition) <module-binding>))
  (puts out (if bound? "\nFUNCODEDEF(" "\nLOCCODEDEF("))
  (generate-function-binding out definition)
  (puts out ") {\n")
  (unless (nul? bindings)
    (with-statement (1 out)
      (puts out "P ")
      (for-commas out ((b (function-bindings definition)))
        (binding->c b out))))
    
  (generate-local-temporaries (function-temporaries definition) out)
  (generate-registers (function-registers definition) out)
  (puts out "LINK_STACK();\n")
  (do (fun (b)
        (when (isa? b <binding>)
          (with-statement (1 out)
            (if (binding-dotted? b)
                (puts out "NARGS(")
                (puts out "ARG("))
            (binding->c b out)
            (msg* out ", %d)" offset))
          (set offset (+ offset 1))))
      bindings)
  (to-c (function-body definition) definition 1 out)
  
  ;; FIXME: This unless is a horrible hack! This should be fixed as part of
  ;; tail-calling stuff, although even then dispatch will be special as it
  ;; calls through with the same args it got.
  (unless (dispatcher? definition) 
    (puts out "UNLINK_STACK();\n"))
  (generate-return definition definition 1 out)
  (puts out "}\n"))

(dm generate-local-temporaries (temps out)
  (for ((temp temps))
    (with-statement (1 out)
      (puts out "P ") (binding->c temp out))))

(dv *trace-registers?* #f)

(dv *registers-per-line* 16)

(dm generate-registers (regs|<vec> out)
  (def nregs (len regs))
  (rep next-line ((j 0))
    (when (< j nregs)
      (gen-depth 1 out) (puts out "P ")
      (rep next-reg ((j j) (i 0))
        (if (or (= i *registers-per-line*) (= j nregs))
            (seq (puts out ";\n") (next-line j))
            (seq (unless (= i 0) (put out #\,))
                 (gen-ref (elt regs j) #f 0 out)
                 (next-reg (+ j 1) (+ i 1))))))))

(dm module-info-name (name)
  (cat "module_info_" (mangle-raw-name name)))

;;; Declare module info objects for each of the modules we use, and each
;;; of the modules which originally defines one of our bindings.  (There're
;;; occasionally small differences between these two sets.)
(df declare-imported-module-infos (out mod)
  (def seen (fab <tab> 50))
  (def env (module-target-environment mod))
  (loc ((maybe-declare (modname)
          (unless (elt-or seen modname #f)
            (set (elt seen modname) #t)
            (msg* out "extern MODULE_INFO %s;\n"
                  (module-info-name modname)))))
    (do maybe-declare (map module-name (environment-uses-modules env)))
    (do-static-global-bindings
     (fun (binding)
       (def home-mod (binding-module-name binding))
       (unless (binding-native-to? binding mod)
         (maybe-declare home-mod)))
     (module-target-environment mod))))

;;; Output a record describing this module and its environment.
;;; This routine is effectively serializing compiler data structures,
;;; so we keep it simple at the price of performance.
(df generate-module-info (out mod)
  (def name       (module-name mod))
  (def info-name  (module-info-name name))
  (def env        (module-target-environment mod))
  (def uses       (environment-uses-modules env))
  (def uses-names (map module-name uses))
  ;;(msg* out "Dumping module information...\n")
  (puts out "\n/* MODULE ENVIRONMENT INFORMATION */\n\n")
  (declare-imported-module-infos out mod)

  (puts out "\nstatic USE_INFO use_infos[] = {\n")
  (for ((n uses-names))
    (msg* out "  {&%s},\n" (module-info-name n)))
  (puts out "  {NULL}\n};\n")

  ;;(msg* out "Dumping imports...\n")
  (puts out "\nstatic IMPORT_INFO import_infos[] = {\n")
  (do-named-static-global-bindings
   (fun (local-name binding)
     (unless (binding-native-to? binding mod)
       (msg* out "  {%s, &%s, %s},\n"
             (mangle-string-literal (binding-name binding))
             (module-info-name (binding-module-name binding))
             (if (== (binding-name binding) local-name)
                 "NULL"
                 (mangle-string-literal local-name)))))
   (module-target-environment mod))
  (puts out "  {NULL,NULL,NULL}\n};\n")

  ;;(msg* out "Dumping bindings...\n")
  (puts out "\nstatic BINDING_INFO binding_infos[] = {\n")
  (do-static-global-bindings
   (fun (binding)
     (when (binding-native-to? binding mod)
       (msg* out "  {%s, "
             (mangle-string-literal (binding-name binding)))
       (case (binding-kind binding)
         (('global)  (msg* out "CVAR, &%s},\n" (mangle-binding binding)))
         (('dynamic) (msg* out "DVAR, &%s},\n" (mangle-binding binding)))
         (#t         (puts out "PVAR, NULL},\n")))))
   (module-target-environment mod))
  (puts out "  {NULL, NVAR, NULL}\n};\n")

  ;;(msg* out "Dumping exports...\n")
  (puts out "\nstatic EXPORT_INFO export_infos[] = {\n")
  (for (((tup exported-as binding) (module-exports mod)))
    (msg* out "  {%s, %s},\n"
          (mangle-string-literal (binding-name binding))
          (if (== (binding-name binding) exported-as)
              "NULL"
              (mangle-string-literal exported-as))))
  (puts out "  {NULL, NULL}\n};\n")

  (msg* out "\nextern MODULE_INFO %s;\n" info-name)
  (msg* out "MODULE_INFO %s = {\n" info-name)
  (msg* out "  %s,\n" (mangle-string-literal name))
  (puts out "  NULL,\n")
  (puts out "  use_infos,\n")
  (puts out "  import_infos,\n")
  (puts out "  binding_infos,\n")
  (puts out "  export_infos,\n")
  (puts out "};\n"))

(dm module-init-name (name)
  (cat "load_module_" (mangle-raw-name name)))

(dm module-init-decl (name)
  (cat "void " (module-init-name name) " (void)"))

(dm generate-module-init (out mod form)
  (def name       (if *dynamic-compilation?* "dl" (module-name mod)))
  (def init-decl  (module-init-decl name))
  (def env        (module-target-environment mod))
  (def uses       (environment-uses-modules env))
  (def uses-names (map module-name uses))
  (unless *dynamic-compilation?*
    (puts out "\n/* MODULES USED: */\n\n")
    (for ((n uses-names))
      (msg* out "extern %s;\n" (module-init-decl n))))
  (puts out "\n/* EXPRESSION: */\n\n")
  (msg* out "extern %s;\n\n" init-decl)
  (msg* out "%s {\n" init-decl)
  (puts out "  static int need_init = 1;\n")
  (puts out "  if (!need_init) return;\n\n")
  (puts out "  need_init = 0;\n")
  (unless *dynamic-compilation?*
    (for ((n uses-names))
      (msg* out "  %s();\n" (module-init-name n)))
    (puts out "\n"))
  (to-c form #f 1 out)
  (puts out "\n")
  ;; (unless *dynamic-compilation?*
  ;;   (puts out "  YPprint_cpu_usage(__FILE__);\n"))
  (puts out "}\n"))

(dm generate-main (out mod)
  (def name      (module-name mod))
  (def info-name (module-info-name name))
  (puts out "\n/* APPLICATION: */\n\n")
  (msg* out "extern MODULE_INFO %s;\n" info-name)
  (msg* out "extern %s;\n\n" (module-init-decl name))
  (msg* out "MODULE_INFO *goo_toplevel_module_info = &%s;\n\n" info-name)
  (puts out "int main(int argc, char* argv[]) {\n")
  (msg* out "  %s(argc, argv);\n" (mangle-boot-name "%init-world"))
  (msg* out "  %s();\n" (module-init-name name))
  (puts out "  return 0;\n")
  (puts out "}\n"))

(export
  g2c-def-app
  g2c-build-app
  g2c-top g2c-goo
  g2c-clean
  g2c-exp
  g2c-ast
  g2c-eval
  g2c-test)