guile-prescheme/ps-compiler/prescheme/c.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Timo Harter, Martin Gasbichler
;;;
;;;   scheme48-1.9.2/ps-compiler/prescheme/c.scm
;;;
;;; Translating the node tree into C

(define-module (ps-compiler prescheme c)
  #:use-module (ice-9 format)
  #:use-module (prescheme scheme48)
  #:use-module (ps-compiler node node)
  #:use-module (ps-compiler node node-util)
  #:use-module (ps-compiler node variable)
  #:use-module (ps-compiler prescheme c-call)
  #:use-module (ps-compiler prescheme c-decl)
  #:use-module (ps-compiler prescheme c-util)
  #:use-module (ps-compiler prescheme flatten)
  #:use-module (ps-compiler prescheme form)
  #:use-module (ps-compiler prescheme hoist)
  #:use-module ((ps-compiler prescheme infer-early) #:select (literal-value-type))
  #:use-module (ps-compiler prescheme merge)
  #:use-module (ps-compiler prescheme record)
  #:use-module (ps-compiler prescheme type)
  #:use-module (ps-compiler prescheme type-var)
  #:use-module (ps-compiler util util)
  #:export (write-c-file

            *doing-tail-called-procedure?*
            *current-merged-procedure*
            *extra-tail-call-args*
            write-c-block
            no-value-node?
            note-jump-generated!))

(define (write-c-file init-name file header forms)
  (set! *c-variable-id* 0)
  (set! *type-uids* '())
  (set! *next-type-uid* 0)
  (let* ((real-out (open-output-file file))
         (out (make-tracking-output-port real-out)))
    (merge-forms forms)
    (check-hoisting forms)
    (format #t "Translating~%")
    (write-c-header header out)
    (write-function-prototypes forms out)
    (write-global-arg-variable-declarations forms out)
    (write-global-variable-declarations forms out)
    (newline out)
    (for-each (lambda (f)
                (case (form-type f)
                  ((lambda)
                   (compile-proc-to-c f out))
                  ((alias constant integrate merged stob initialize unused)
                   (values))
                  (else
                   (bug "unknown type of form ~S" f))))
              forms)
    (write-c-main init-name out forms)
    (newline out)
    (set! *type-uids* '())
    (close-output-port out)
    (close-output-port real-out)))


(define (write-c-main init-name out forms)
  (set! *doing-tail-called-procedure?* #f)
  (set! *current-merged-procedure* #f)
  (cond ((any? (lambda (f)
                 (or (eq? (form-type f) 'initialize)
                     (eq? (form-type f) 'stob)
                     (eq? (form-type f) 'alias)))
               forms)
         (write-c-main-header (if init-name init-name 'main) out)
         (for-each (lambda (f)
                     (case (form-type f)
                       ((initialize alias)
                        (write-initialize (form-var f) (form-value f) out))
                       ((stob)
                        (write-stob (form-var f)
                                    (form-value-type f)
                                    (lambda-body (form-value f))
                                    out))))
                   forms)
         (write-c-main-end out))))

(define (write-c-header header out)
  (format out "#include <stdio.h>~%")
  (format out "#include <string.h>~%")
  (format out "#include <stdlib.h>~%")
  (format out "#include \"prescheme.h\"~%")
  (for-each (lambda (s)
              (display s out)
              (newline out))
            header)
  (for-each (lambda (rtype)
              (declare-record-type rtype out))
            (all-record-types))
  (newline out)
  (values))

(define (declare-record-type rtype out)
  (format out "~%struct ")
  (write-c-identifier (record-type-name rtype) out)
  (format out " {~%")
  (for-each (lambda (field)
              (format out "  ")
              (display-c-type (record-field-type field)
                              (lambda (port)
                                (write-c-identifier (record-field-name field)
                                                    out))
                              out)
              (format out ";~%"))
            (record-type-fields rtype))
  (format out "};"))

;; Even when finished we need to keep the lambda around for help with
;; calls to it.

(define (compile-proc-to-c form out)
  (format #t " ~A~%" (form-c-name form))
  (let ((name (form-c-name form)))
    (proc->c name form (form-shadowed form) out #f)
    (for-each make-form-unused! (form-merged form))
    (erase (detach-body (lambda-body (form-value form))))
    (suspend-form-use! form)))

(define (no-value-node? node)
  (or (undefined-value-node? node)
      (and (reference-node? node)
           (let ((type (final-variable-type (reference-variable node))))
             (or (eq? type type/unit)
                 (eq? type type/null))))))

;;------------------------------------------------------------
;; Initialization procedure at the end of the file (often called `main').

;; Header for initialization code

(define (write-c-main-header initname out)
  (format out "void~%")
  (write-c-identifier initname out)
  (format out "(void)~%{"))

;; Write the end of the initialization code

(define (write-c-main-end out)
  (format out "~&}"))

(define (write-initialize var value out)
  (let ((wants (maybe-follow-uvar (variable-type var))))
    (receive (value has)
        (cond ((variable? value)
               (values value (final-variable-type value)))
              ((literal-node? value)
               (values (literal-value value) (literal-type value)))
              ((reference-node? value)
               (let ((var (reference-variable value)))
                 (values var (final-variable-type var))))
              (else
               (error "unknown kind of initial value ~S" value)))
      (cond ((not (unspecific? value))
             (c-assign-to-variable var out 0)
             (if (not (type-eq? wants has))
                 (write-c-coercion wants out))
             (cond ((input-port? value)
                    (display "0" out))
                   ((output-port? value)
                    (display "1" out))
                   ((variable? value)
                    (c-variable value out))
                   (else
                    (c-literal-value value has out)))
             (writec out '#\;))))))

(define (write-stob var type call out)
  (let ((value (literal-value (call-arg call 0)))
        (wants (final-variable-type var)))
    (c-assign-to-variable var out 0)
    (cond ((vector? value)
           (if (not (type-eq? type wants))
               (write-c-coercion wants out))
           (format out "malloc(~D * sizeof(" (vector-length value))
           (display-c-type (pointer-type-to type) #f out)
           (format out "));")
           (do ((i 0 (+ i 1)))
               ((>= i (vector-length value)))
             (let* ((elt (call-arg call (+ i 1)))
                    (has (finalize-type
                          (if (reference-node? elt)
                              (variable-type (reference-variable elt))
                              (literal-value-type (literal-value elt))))))
               (newline out)
               (c-variable var out)
               (format out "[~D] = " i)
               (if (not (type-eq? (pointer-type-to type) has))
                   (write-c-coercion (pointer-type-to type) out))
               (c-value elt out)
               (write-char #\; out))))
          (else
           (error "don't know how to generate stob value ~S" value)))))

;;------------------------------------------------------------
;; Writing out a procedure.

(define (proc->c name form rename-vars port maybe-merged-count)
  (let ((top       (form-value form))
        (merged    (form-merged form))
        (tail?     (form-tail-called? form))
        (exported? (form-exported? form))
        (lambda-kids lambda-block))        ;; filled in by the hoist code
    (let ((lambdas (filter (lambda (l)
                             (not (proc-lambda? l)))
                           (lambda-kids top))))
      (if maybe-merged-count
          (merged-proc->c name top lambdas merged maybe-merged-count port tail?)
          (real-proc->c name (form-var form) top lambdas
                        merged rename-vars port tail? exported?))
      (values))))

(define (write-merged-form form port)
  (format #t "  ~A~%" (form-c-name form))
;;  (breakpoint "write-merged-form ~S" form)
  (proc->c (form-c-name form)
           form
           '()
           port
           (length (variable-refs (form-var form)))))

;;------------------------------------------------------------

;; 1. write the header
;; 2. declare the local variables
;; 3. write out the body
;; 4. write out all of the label lambdas

(define (real-proc->c id var top lambdas merged rename-vars port tail? exported?)
  (let ((vars (cdr (lambda-variables top)))
        (return-type (final-variable-type (car (lambda-variables top))))
        (all-lambdas (append lambdas (gather-merged-lambdas merged)))
        (merged-procs (gather-merged-procs merged)))
    (set! *doing-tail-called-procedure?* tail?)
    (set! *current-merged-procedure* #f)
    (receive (first rest)
        (parse-return-type return-type)
      (set! *extra-tail-call-args*
            (do ((i (length rest) (- i 1))
                 (args '() (cons (format #f "TT~D" (- i 1)) args)))
                ((= i 0)
                 args))))
    (set! *jumps-to-do* '())
    (write-procedure-header id return-type vars port tail? exported?)
    (write-char '#\{ port)
    (newline port)
    (for-each (lambda (v)
                (set-variable-flags! v (cons 'shadowed (variable-flags v))))
              rename-vars)
    (write-arg-variable-declarations all-lambdas merged port)
    (write-rename-variable-declarations rename-vars port)
    (write-merged-declarations merged port)
    (fixup-nasty-c-primops! (lambda-body top))
    (for-each (lambda (form)
                (write-merged-decls form port))
              merged)
    (clear-lambda-generated?-flags lambdas)
    (set! *local-vars* '())
    (let ((body (call-with-string-output-port
                 (lambda (temp-port)
                   (let ((temp-port (make-tracking-output-port temp-port)))
                     (write-c-block (lambda-body top) temp-port 2)
                     (write-jump-lambdas temp-port 0)
                     (for-each (lambda (f)
                                 (write-merged-form f temp-port))
                               (reverse merged))  ;; makes for more readable output
                     (newline temp-port)
                     (force-output temp-port))))))
      (declare-local-variables port)
      (if tail?
          (write-global-argument-initializers (cdr (lambda-variables top))
                                              port 2))
      (format port "~% {")
      (display body port)
      (write-char '#\} port))
    (for-each (lambda (v)
                (set-variable-flags! v (delq! 'shadowed (variable-flags v))))
              rename-vars)
    (values)))

;; These global variables should be replaced with fluids.

(define *doing-tail-called-procedure?* #f)
(define *current-merged-procedure* #f)
(define *extra-tail-call-args* '())

(define (gather-merged-lambdas merged)
  (let loop ((merged merged) (lambdas '()))
    (if (null? merged)
        lambdas
        (loop (append (form-merged (car merged)) (cdr merged))
              (append (form-lambdas (car merged)) lambdas)))))

(define (gather-merged-procs merged)
  (let loop ((merged merged) (procs '()))
    (if (null? merged)
        procs
        (loop (append (form-merged (car merged)) (cdr merged))
              (cons (form-value (car merged)) procs)))))

(define (write-merged-decls form port)
  (let ((top (form-value form))
        (merged (form-merged form)))
    (let ((vars (filter (lambda (var)
                          (and (used? var)
                               (not (eq? type/unit (final-variable-type var)))))
                        (cdr (lambda-variables top)))))
      (write-variable-declarations vars port 2))
    (write-merged-declarations merged port)))

(define (merged-proc->c name top lambdas merged return-count port tail?)
  (let ((vars (cdr (lambda-variables top)))
        (body (lambda-body top)))
    (set! *doing-tail-called-procedure?* tail?)
    (set! *current-merged-procedure* name)
    (write-merged-header name top port)
    (write-char '#\{ port)
    (clear-lambda-generated?-flags lambdas)
    (write-c-block body port 2)
    (write-jump-lambdas port 0)
    (if (not tail?)
        (write-merged-return name return-count port))
    (for-each (lambda (f)
                (write-merged-form f port))
              (reverse merged))  ;; makes for more readable output
    (write-char '#\} port)
    (newline port)
    (values)))

(define (write-merged-header name top port)
  (format port "~% ~A: {~%" name)
  (if (not (null? (cdr (lambda-variables top))))
      (write-merged-argument-initializers (cdr (lambda-variables top)) port 2)))

;; We use `default:' for the last tag so that the C compiler will
;; know that the code following the switch is unreachable (to avoid
;; a spurious warning if this is the end of the procedure).

(define (write-merged-return name return-count port)
  (format port "~%#ifndef USE_DIRECT_THREADING~% ~A_return:~%  switch (~A_return_tag) {~%" name name)
  (do ((i 0 (+ i 1)))
      ((>= i (- return-count 1)))
    (format port "  case ~S: goto ~A_return_~S;~%" i name i))
  (format port "  default: goto ~A_return_~S;~%" name (- return-count 1))
  (format port "  }~%#endif~%"))

(define (write-merged-declarations forms port)
  (for-each (lambda (f)
              (if (not (form-tail-called? f))
                  (write-merged-declaration f port)))
            forms))

(define (write-merged-declaration form port)
  (let ((name (form-c-name form))
        (types (lambda-return-types (form-value form))))
    (format port "~%#ifdef USE_DIRECT_THREADING~%  void *~A_return_address;~%#else~%  int ~A_return_tag;~%#endif" name name)
    (do ((i 0 (+ i 1))
         (types types (cdr types)))
        ((null? types))
      (let ((type (car types)))
        (cond ((not (or (eq? type type/unit)
                        (eq? type type/null)))
               (format port "~%  ")
               (display-c-type type
                               (lambda (port)
                                 (format port "~A~D_return_value" name i))
                               port)
               (writec port #\;)))))))

(define (lambda-return-types node)
  (let ((type (final-variable-type (car (lambda-variables node)))))
    (if (tuple-type? type)
        (tuple-type-types type)
        (list type))))

(define (write-procedure-header id return-type vars port tail? exported?)
  (newline port)
  (if (not exported?)
      (display "static " port))
  (receive (first rest)
      (parse-return-type return-type)
    (display-c-type (if tail? type/integer first)
                    (lambda (port)
                      (if tail? (write-char #\T port))
                      (display id port))
                    port)
    (write-char '#\( port)
    (if (not tail?)
        (let ((args (append vars
                            (do ((i 0 (+ i 1))
                                 (rest rest (cdr rest))
                                 (res '() (cons (cons i (car rest)) res)))
                                ((null? rest)
                                 (reverse res))))))
          (if (null? args)
              (display "void" port)
              (write-variables args port))))
    (write-char '#\) port)
    (newline port)))

;; Write the names of VARS out to the port.  VARS may contain pairs of the
;; form (<integer> . <type>) as well as variables.

(define (write-variables vars port)
  (let ((do-one (lambda (var)
                  (display-c-type (if (pair? var)
                                      (make-pointer-type (cdr var))
                                      (final-variable-type var))
                                  (lambda (port)
                                    (if (pair? var)
                                        (format port "TT~D" (car var))
                                        (c-variable var port)))
                                  port))))
    (cond ((null? vars)
           (values))
          ((null? (cdr vars))
           (do-one (car vars)))
          (else
           (do-one (car vars))
           (do ((vars (cdr vars) (cdr vars)))
               ((null? vars)
                (values))
             (write-char '#\, port)
             (write-char '#\space port)
             (do-one (car vars)))))))

(define (write-rename-variable-declarations vars port)
  (for-each (lambda (var)
              (indent-to port 2)
              (display-c-type (final-variable-type var)
                              (lambda (port)
                                (writec port #\R)
                                (write-c-identifier (variable-name var) port))
                              port)
              (display " = " port)
              (write-c-identifier (variable-name var) port)
              (format port ";~%"))
            vars))

(define (write-c-block body port indent)
  (write-c-block-with-args body '() port indent))

(define (write-c-block-with-args body arg-vars port indent)
  (if (not (null? arg-vars))
      (write-argument-initializers arg-vars port indent))
  (call->c body port indent)
  (write-char '#\} port))

;; Jump lambdas.  These are generated more-or-less in the order they are
;; referenced.

(define (clear-lambda-generated?-flags lambdas)
  (for-each (lambda (l)
              (set-lambda-block! l #f))
            lambdas))

(define *jumps-to-do* '())

(define (note-jump-generated! proc)
  (if (not (lambda-block proc))
      (begin
        (set! *jumps-to-do* (cons proc *jumps-to-do*))
        (set-lambda-block! proc #t))))

(define (write-jump-lambdas port indent)
  (let loop ()
    (let ((jumps (reverse *jumps-to-do*)))
      (set! *jumps-to-do* '())
      (for-each (lambda (jump)
                  (jump-lambda->c jump port indent))
                jumps)
      (if (not (null? *jumps-to-do*))
          (loop)))))

(define (jump-lambda->c node port indent)
  (newline port)
  (indent-to port indent)
  (display " L" port)
  (display (lambda-id node) port)
  (display ": {" port)
  (newline port)
  (write-c-block-with-args (lambda-body node)
                           (lambda-variables node)
                           port
                           (+ '2 indent)))