386 lines
11 KiB
Scheme
386 lines
11 KiB
Scheme
|
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
|
||
|
|
|
||
|
|
; C variable declarations.
|
||
|
|
;
|
||
|
|
; (write-function-prototypes forms port)
|
||
|
|
;
|
||
|
|
; (write-variable-declarations vars port indent)
|
||
|
|
|
||
|
|
; Writing declarations.
|
||
|
|
|
||
|
|
(define (write-function-prototypes forms port)
|
||
|
|
(for-each (lambda (f)
|
||
|
|
(if (eq? (form-type f) 'lambda)
|
||
|
|
(if (form-tail-called? f)
|
||
|
|
(write-function-tail-prototype (form-c-name f)
|
||
|
|
(form-exported? f)
|
||
|
|
port)
|
||
|
|
(write-function-prototype (form-var f)
|
||
|
|
(form-c-name f)
|
||
|
|
(form-exported? f)
|
||
|
|
port))))
|
||
|
|
forms))
|
||
|
|
|
||
|
|
(define (write-function-tail-prototype name exported? port)
|
||
|
|
(if (not exported?)
|
||
|
|
(display "static " port))
|
||
|
|
(display "long T" port)
|
||
|
|
(display name port)
|
||
|
|
(display "(void);" port)
|
||
|
|
(newline port))
|
||
|
|
|
||
|
|
(define (write-function-prototype var name exported? port)
|
||
|
|
(if (not exported?)
|
||
|
|
(display "static " port))
|
||
|
|
(receive (result args)
|
||
|
|
(parse-arrow-type (final-variable-type var))
|
||
|
|
(display-c-type result
|
||
|
|
(lambda (port)
|
||
|
|
(display name port))
|
||
|
|
port)
|
||
|
|
(write-char #\( port)
|
||
|
|
(if (null? args)
|
||
|
|
(display "void" port)
|
||
|
|
(begin
|
||
|
|
(display-c-type (car args) #f port)
|
||
|
|
(let loop ((args (cdr args)))
|
||
|
|
(if (not (null? args))
|
||
|
|
(begin
|
||
|
|
(display ", " port)
|
||
|
|
(display-c-type (car args) #f port)
|
||
|
|
(loop (cdr args)))))))
|
||
|
|
(display ");" port)
|
||
|
|
(newline port)))
|
||
|
|
|
||
|
|
; Write declarations for global variables.
|
||
|
|
|
||
|
|
(define (write-global-variable-declarations forms port)
|
||
|
|
(for-each (lambda (form)
|
||
|
|
(if (memq (form-type form)
|
||
|
|
'(stob initialize alias))
|
||
|
|
(let* ((var (form-var form))
|
||
|
|
(type (final-variable-type var)))
|
||
|
|
(if (not (or (eq? type type/unit)
|
||
|
|
(eq? type type/null)))
|
||
|
|
(really-write-variable-declaration
|
||
|
|
var type (form-exported? form) port 0)))))
|
||
|
|
forms))
|
||
|
|
|
||
|
|
; Write general variable declarations.
|
||
|
|
|
||
|
|
(define (write-variable-declarations vars port indent)
|
||
|
|
(for-each (lambda (var)
|
||
|
|
(let ((type (final-variable-type var)))
|
||
|
|
(if (not (or (eq? type type/unit)
|
||
|
|
(eq? type type/null)))
|
||
|
|
(really-write-variable-declaration var type #t port indent))))
|
||
|
|
vars))
|
||
|
|
|
||
|
|
(define (really-write-variable-declaration var type exported? port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(if (not exported?)
|
||
|
|
(display "static " port))
|
||
|
|
(display-c-type type
|
||
|
|
(lambda (port)
|
||
|
|
(c-variable-no-shadowing var port))
|
||
|
|
port)
|
||
|
|
(writec port #\;))
|
||
|
|
|
||
|
|
;----------------------------------------------------------------
|
||
|
|
; Writing C types
|
||
|
|
|
||
|
|
(define (display-c-type type name port)
|
||
|
|
(display-c-base-type (type->c-base-type type) port)
|
||
|
|
(if name (display " " port))
|
||
|
|
(display-c-type-modifiers type name port))
|
||
|
|
|
||
|
|
(define (write-c-coercion type out)
|
||
|
|
(write-char #\( out)
|
||
|
|
(display-c-type type #f out)
|
||
|
|
(write-char #\) out))
|
||
|
|
|
||
|
|
; Searches through the type modifiers until the base type is found.
|
||
|
|
; Unspecified result types are assumed to be `void'.
|
||
|
|
|
||
|
|
(define (type->c-base-type type)
|
||
|
|
(let ((type (maybe-follow-uvar type)))
|
||
|
|
(cond ((or (base-type? type)
|
||
|
|
(record-type? type))
|
||
|
|
type)
|
||
|
|
((pointer-type? type)
|
||
|
|
(type->c-base-type (pointer-type-to type)))
|
||
|
|
((arrow-type? type)
|
||
|
|
(let ((res (arrow-type-result type)))
|
||
|
|
(cond ((and (uvar? res)
|
||
|
|
(not (uvar-binding res)))
|
||
|
|
type/unit)
|
||
|
|
((not (tuple-type? res))
|
||
|
|
(type->c-base-type res))
|
||
|
|
((null? (tuple-type-types res))
|
||
|
|
type/unit)
|
||
|
|
(else
|
||
|
|
(type->c-base-type (car (tuple-type-types res)))))))
|
||
|
|
(else
|
||
|
|
(bug "don't know how to write ~S as a C type" type)))))
|
||
|
|
|
||
|
|
; Table of C names for base types.
|
||
|
|
|
||
|
|
(define c-decl-table (make-integer-table))
|
||
|
|
|
||
|
|
(define (add-c-type-declaration! type decl)
|
||
|
|
(table-set! c-decl-table (base-type-uid type) decl))
|
||
|
|
|
||
|
|
(for-each (lambda (p)
|
||
|
|
(let ((type (lookup-type (car p))))
|
||
|
|
(add-c-type-declaration! type (cadr p))))
|
||
|
|
'((boolean "char")
|
||
|
|
(char "char")
|
||
|
|
(integer "long")
|
||
|
|
(address "char *")
|
||
|
|
(input-port "FILE *")
|
||
|
|
(output-port "FILE *")
|
||
|
|
(unit "void")
|
||
|
|
(null "void")))
|
||
|
|
|
||
|
|
(define (display-c-base-type type port)
|
||
|
|
(cond ((record-type? type)
|
||
|
|
(display "struct " port)
|
||
|
|
(write-c-identifier (record-type-name type) port))
|
||
|
|
(else
|
||
|
|
(display (or (table-ref c-decl-table (base-type-uid type))
|
||
|
|
(bug "no C declaration for ~S" type))
|
||
|
|
port))))
|
||
|
|
|
||
|
|
; Writes out the modifiers of TYPE with NAME used when the base type is reached.
|
||
|
|
|
||
|
|
(define (display-c-type-modifiers type name port)
|
||
|
|
(let label ((type type) (name name))
|
||
|
|
(let ((type (maybe-follow-uvar type)))
|
||
|
|
(cond ((or (base-type? type)
|
||
|
|
(record-type? type))
|
||
|
|
(if name (name port)))
|
||
|
|
((pointer-type? type)
|
||
|
|
(label (pointer-type-to type)
|
||
|
|
(lambda (port)
|
||
|
|
(format port "*")
|
||
|
|
(if name (name port)))))
|
||
|
|
((arrow-type? type)
|
||
|
|
(format port "(*")
|
||
|
|
(receive (return-type args)
|
||
|
|
(parse-arrow-type type)
|
||
|
|
(label return-type name)
|
||
|
|
(format port ")(")
|
||
|
|
(cond ((null? args)
|
||
|
|
(display "void" port))
|
||
|
|
(else
|
||
|
|
(display-c-type (car args) #f port)
|
||
|
|
(do ((args (cdr args) (cdr args)))
|
||
|
|
((null? args))
|
||
|
|
(display ", " port)
|
||
|
|
(display-c-type (car args) #f port))))
|
||
|
|
(format port ")")))
|
||
|
|
(else
|
||
|
|
(bug "don't know how to write ~S as a C type" type))))))
|
||
|
|
|
||
|
|
(define (parse-arrow-type type)
|
||
|
|
(receive (first rest)
|
||
|
|
(parse-return-type (arrow-type-result type))
|
||
|
|
(values first
|
||
|
|
(append (arrow-type-args type)
|
||
|
|
(map make-pointer-type rest)))))
|
||
|
|
|
||
|
|
(define (parse-return-type type)
|
||
|
|
(cond ((not (tuple-type? type))
|
||
|
|
(values (if (and (uvar? type)
|
||
|
|
(not (uvar-binding type)))
|
||
|
|
type/unit
|
||
|
|
type)
|
||
|
|
'()))
|
||
|
|
((null? (tuple-type-types type))
|
||
|
|
(values type/unit '()))
|
||
|
|
(else
|
||
|
|
(values (car (tuple-type-types type))
|
||
|
|
(cdr (tuple-type-types type))))))
|
||
|
|
|
||
|
|
;------------------------------------------------------------
|
||
|
|
; Collecting local variables. Each is added to this list when it is first
|
||
|
|
; used.
|
||
|
|
|
||
|
|
(define *local-vars* '())
|
||
|
|
|
||
|
|
(define (declare-local-variables port)
|
||
|
|
(write-variable-declarations *local-vars* port 2))
|
||
|
|
|
||
|
|
; Some primops must be given continuations so that calls to them will
|
||
|
|
; be translated into separate C statements and so expand into arbitrarily
|
||
|
|
; complex chunks of C if necessary.
|
||
|
|
|
||
|
|
(define (fixup-nasty-c-primops! call)
|
||
|
|
(let ((top call))
|
||
|
|
(let label ((call call))
|
||
|
|
(cond ((call-node? call)
|
||
|
|
(if (and (= 0 (call-exits call))
|
||
|
|
(nasty-c-primop-call? call))
|
||
|
|
(set! top (expand-nasty-c-primop! call top)))
|
||
|
|
(walk-vector label (call-args call)))))
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i (call-arg-count top)))
|
||
|
|
(let ((arg (call-arg top i)))
|
||
|
|
(if (lambda-node? arg)
|
||
|
|
(fixup-nasty-c-primops! (lambda-body arg)))))))
|
||
|
|
|
||
|
|
(define (nasty-c-primop-call? call)
|
||
|
|
(case (primop-id (call-primop call))
|
||
|
|
((lshl ashl ashr) ; C does poorly when shifting by large amounts
|
||
|
|
(not (literal-node? (call-arg call 1))))
|
||
|
|
(else #f)))
|
||
|
|
|
||
|
|
; Give CALL a continuation and move it above TOP, replacing CALL
|
||
|
|
; with the continuation's variable.
|
||
|
|
;
|
||
|
|
; top = (p1 ... (p2 a1 ...) ...)
|
||
|
|
; =>
|
||
|
|
; (p2 (lambda (v) (p1 ... v ...)) a1 ...)
|
||
|
|
|
||
|
|
(define (expand-nasty-c-primop! call top)
|
||
|
|
(let* ((var (make-variable 'x (node-type call)))
|
||
|
|
(cont (make-lambda-node 'c 'cont (list var))))
|
||
|
|
(move call
|
||
|
|
(lambda (call)
|
||
|
|
(make-reference-node var)))
|
||
|
|
(insert-body call
|
||
|
|
cont
|
||
|
|
(node-parent top))
|
||
|
|
(set-call-exits! call 1)
|
||
|
|
(insert-call-arg call 0 cont)
|
||
|
|
call))
|
||
|
|
|
||
|
|
;------------------------------------------------------------
|
||
|
|
; Declare the variables used to pass arguments to procedures.
|
||
|
|
; This is done in each procedure so that the C compiler doesn't have to contend
|
||
|
|
; with the possibility of globally visible side-effects.
|
||
|
|
|
||
|
|
(define (write-arg-variable-declarations lambdas merged port)
|
||
|
|
(let ((lambdas (filter (lambda (l)
|
||
|
|
(eq? 'jump (lambda-type l)))
|
||
|
|
lambdas))
|
||
|
|
(merged (map form-value merged)))
|
||
|
|
(really-write-arg-variable-declarations lambdas "arg" port 2)
|
||
|
|
(really-write-arg-variable-declarations merged "merged_arg" port 2)))
|
||
|
|
|
||
|
|
(define (write-global-arg-variable-declarations forms port)
|
||
|
|
(let ((lambdas (filter-map (lambda (f)
|
||
|
|
(if (and (form-var f)
|
||
|
|
(memq? 'tail-called
|
||
|
|
(variable-flags (form-var f))))
|
||
|
|
(form-value f)
|
||
|
|
#f))
|
||
|
|
forms)))
|
||
|
|
(really-write-arg-variable-declarations lambdas "goto_arg" port 0)))
|
||
|
|
|
||
|
|
(define (really-write-arg-variable-declarations lambdas name port indent)
|
||
|
|
(for-each (lambda (data)
|
||
|
|
(destructure (((uid type . indicies) data))
|
||
|
|
(if (not (eq? type type/unit))
|
||
|
|
(for-each (lambda (i)
|
||
|
|
(indent-to port indent)
|
||
|
|
(declare-arg-variable type uid i name port))
|
||
|
|
indicies))))
|
||
|
|
(get-variable-decl-data lambdas)))
|
||
|
|
|
||
|
|
(define (get-variable-decl-data lambdas)
|
||
|
|
(let ((data '()))
|
||
|
|
(for-each (lambda (l)
|
||
|
|
(do ((vars (if (eq? 'jump (lambda-type l))
|
||
|
|
(lambda-variables l)
|
||
|
|
(cdr (lambda-variables l)))
|
||
|
|
(cdr vars))
|
||
|
|
(i 0 (+ i 1)))
|
||
|
|
((null? vars))
|
||
|
|
(let* ((type (final-variable-type (car vars)))
|
||
|
|
(uid (type->uid type))
|
||
|
|
(datum (assq uid data)))
|
||
|
|
(cond ((not datum)
|
||
|
|
(set! data (cons (list uid type i) data)))
|
||
|
|
((not (memq i (cddr datum)))
|
||
|
|
(set-cdr! (cdr datum) (cons i (cddr datum))))))))
|
||
|
|
lambdas)
|
||
|
|
data))
|
||
|
|
|
||
|
|
(define (declare-arg-variable type uid i name port)
|
||
|
|
(display-c-type type
|
||
|
|
(lambda (port)
|
||
|
|
(format port "~A~DK~D" name uid i))
|
||
|
|
port)
|
||
|
|
(format port ";~%"))
|
||
|
|
|
||
|
|
;------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (write-argument-initializers arg-vars port indent)
|
||
|
|
(really-write-argument-initializers arg-vars "arg" #f port indent))
|
||
|
|
|
||
|
|
(define (write-merged-argument-initializers arg-vars port indent)
|
||
|
|
(really-write-argument-initializers arg-vars "merged_arg" #f port indent))
|
||
|
|
|
||
|
|
(define (write-global-argument-initializers arg-vars port indent)
|
||
|
|
(really-write-argument-initializers arg-vars "goto_arg" #t port indent))
|
||
|
|
|
||
|
|
(define (really-write-argument-initializers arg-vars name type? port indent)
|
||
|
|
(do ((i 0 (+ i 1))
|
||
|
|
(vars arg-vars (cdr vars)))
|
||
|
|
((null? vars) (values))
|
||
|
|
(if (used? (car vars))
|
||
|
|
(let* ((var (car vars))
|
||
|
|
(type (final-variable-type var)))
|
||
|
|
(cond ((not (eq? type/unit type))
|
||
|
|
(indent-to port indent)
|
||
|
|
(if type?
|
||
|
|
(display-c-type type
|
||
|
|
(lambda (port) (c-variable var port))
|
||
|
|
port)
|
||
|
|
(c-variable var port))
|
||
|
|
(display " = " port)
|
||
|
|
(display (c-argument-var name type i port) port)
|
||
|
|
(write-char '#\; port)))))))
|
||
|
|
|
||
|
|
(define (c-argument-var name type i port)
|
||
|
|
(format #f "~A~DK~D" name (type->uid type) i))
|
||
|
|
|
||
|
|
(define *type-uids* '())
|
||
|
|
(define *next-type-uid* 0)
|
||
|
|
|
||
|
|
(define (type->uid type)
|
||
|
|
(cond ((any (lambda (p)
|
||
|
|
(type-eq? type (car p)))
|
||
|
|
*type-uids*)
|
||
|
|
=> cdr)
|
||
|
|
(else
|
||
|
|
(let ((id *next-type-uid*))
|
||
|
|
(set! *next-type-uid* (+ id 1))
|
||
|
|
(set! *type-uids* (cons (cons type id) *type-uids*))
|
||
|
|
id))))
|
||
|
|
|
||
|
|
;----------------------------------------------------------------
|
||
|
|
; Random utility here for historical reasons.
|
||
|
|
|
||
|
|
(define (goto-call? call)
|
||
|
|
(and (calls-this-primop? call 'unknown-tail-call)
|
||
|
|
(goto-protocol? (literal-value (call-arg call 2)))))
|
||
|
|
|
||
|
|
;----------------------------------------------------------------
|
||
|
|
; random type stuff
|
||
|
|
|
||
|
|
(define (reference-type node)
|
||
|
|
(finalize-variable-type (reference-variable node)))
|
||
|
|
|
||
|
|
(define (finalize-variable-type var)
|
||
|
|
(let* ((type (finalize-type (variable-type var)))
|
||
|
|
(type (if (uvar? type)
|
||
|
|
type/null
|
||
|
|
type)))
|
||
|
|
(set-variable-type! var type)
|
||
|
|
type))
|
||
|
|
|
||
|
|
(define final-variable-type finalize-variable-type)
|
||
|
|
|