344 lines
11 KiB
Scheme
344 lines
11 KiB
Scheme
|
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
|
||
|
|
|
||
|
|
(define-c-generator let #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(let ((args (call-args call))
|
||
|
|
(vars (lambda-variables (call-arg call 0))))
|
||
|
|
(do ((i 1 (+ i 1))
|
||
|
|
(vars vars (cdr vars)))
|
||
|
|
((null? vars))
|
||
|
|
(let ((val (vector-ref args i)))
|
||
|
|
(if (not (lambda-node? val))
|
||
|
|
(c-assignment (car vars) val port indent)))))))
|
||
|
|
|
||
|
|
(define-c-generator letrec1 #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
(define-c-generator letrec2 #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
(define-c-generator jump #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(let ((proc (called-lambda call)))
|
||
|
|
(assign-argument-vars (lambda-variables proc) call 1 port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "goto " port)
|
||
|
|
(writec port #\L)
|
||
|
|
(display (lambda-id proc) port)
|
||
|
|
(write-char #\; port)
|
||
|
|
(note-jump-generated! proc)
|
||
|
|
(values))))
|
||
|
|
|
||
|
|
(define (assign-argument-vars vars call start port indent)
|
||
|
|
(really-assign-argument-vars vars call start "arg" port indent))
|
||
|
|
|
||
|
|
(define (assign-merged-argument-vars vars call start port indent)
|
||
|
|
(really-assign-argument-vars vars call start "merged_arg" port indent))
|
||
|
|
|
||
|
|
(define (assign-global-argument-vars vars call start port indent)
|
||
|
|
(really-assign-argument-vars vars call start "goto_arg" port indent))
|
||
|
|
|
||
|
|
(define (really-assign-argument-vars vars call start name port indent)
|
||
|
|
(let ((args (call-args call)))
|
||
|
|
(do ((i start (+ i 1))
|
||
|
|
(vars vars (cdr vars)))
|
||
|
|
((>= i (vector-length args)))
|
||
|
|
(if (not (or (undefined-value-node? (vector-ref args i))
|
||
|
|
(eq? type/unit (get-variable-type (car vars)))))
|
||
|
|
(c-assignment (c-argument-var name
|
||
|
|
(get-variable-type (car vars))
|
||
|
|
(- i start)
|
||
|
|
port)
|
||
|
|
(vector-ref args i)
|
||
|
|
port indent)))))
|
||
|
|
|
||
|
|
; Calls
|
||
|
|
|
||
|
|
; Unknown calls have a first argument of 'goto if they are supposed to be
|
||
|
|
; tail-recursive. For known calls the protocol field of the lambda node
|
||
|
|
; is set to 'tail-called if any of the calls are supposed to be tail-recursive.
|
||
|
|
;
|
||
|
|
; Calls to non-tail-called procedures are just regular C calls. For tail-
|
||
|
|
; called procedures there are two kinds of calls:
|
||
|
|
; Tail-call from a tail-called procedure: proceed through the driver loop
|
||
|
|
; All others: start a driver loop
|
||
|
|
;
|
||
|
|
; Known and unknown calls are handled identically, except that known calls
|
||
|
|
; may be to merged procedures.
|
||
|
|
;
|
||
|
|
; Merged procedures with GOTO calls:
|
||
|
|
; This works if we merge the return points as well. Possibly there should be
|
||
|
|
; one return switch per C procedure. There do have to be separate return point
|
||
|
|
; variables (and one global one for the switch).
|
||
|
|
|
||
|
|
(define-c-generator call #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(cond ((merged-procedure-reference (call-arg call 1))
|
||
|
|
=> (lambda (form)
|
||
|
|
(generate-merged-call call 2 form port indent)))
|
||
|
|
(else
|
||
|
|
(generate-c-call call 2 port indent)))))
|
||
|
|
|
||
|
|
(define-c-generator tail-call #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(cond ((merged-procedure-reference (call-arg call 1))
|
||
|
|
=> (lambda (form)
|
||
|
|
(generate-merged-goto-call call 2 form port indent)))
|
||
|
|
(else
|
||
|
|
(generate-c-tail-call call 2 port indent)))))
|
||
|
|
|
||
|
|
(define-c-generator unknown-call #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(if (goto-protocol? (literal-value (call-arg call 2)))
|
||
|
|
(user-warning "ignoring GOTO declaration for non-tail-recursive call to"
|
||
|
|
(variable-name (reference-variable
|
||
|
|
(call-arg call 1)))))
|
||
|
|
(generate-c-call call 3 port indent)))
|
||
|
|
|
||
|
|
(define-c-generator unknown-tail-call #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(generate-c-tail-call call 3 port indent)))
|
||
|
|
|
||
|
|
(define (generate-merged-goto-call call start form port indent)
|
||
|
|
(let ((proc (form-value form)))
|
||
|
|
(assign-merged-argument-vars (cdr (lambda-variables proc))
|
||
|
|
call start
|
||
|
|
port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "goto " port)
|
||
|
|
(display (form-c-name form) port)
|
||
|
|
(write-char #\; port)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
(define (generate-goto-call call start port indent)
|
||
|
|
(let ((proc (call-arg call 1)))
|
||
|
|
(if (not (global-reference? proc))
|
||
|
|
(bug "incorrect procedure in goto call ~S" call))
|
||
|
|
(assign-global-argument-vars (cdr (lambda-variables
|
||
|
|
(global-lambda
|
||
|
|
(reference-variable proc))))
|
||
|
|
call start
|
||
|
|
port indent)
|
||
|
|
; T is the marker for the tail-call version of the procedure
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "return((long)T" port)
|
||
|
|
(c-value proc port)
|
||
|
|
(display ");" port)))
|
||
|
|
|
||
|
|
(define (global-lambda var)
|
||
|
|
(let ((form (maybe-variable->form var)))
|
||
|
|
(if (and form
|
||
|
|
(or (eq? 'lambda (form-type form))
|
||
|
|
(eq? 'merged (form-type form))))
|
||
|
|
(form-value form)
|
||
|
|
(bug "value of ~S, called using goto, is not a known procedure"
|
||
|
|
var))))
|
||
|
|
|
||
|
|
; C requires that we dereference all but calls to global functions.
|
||
|
|
; Calls to literals are macros that must take care of themselves.
|
||
|
|
|
||
|
|
(define (generate-c-call call start port indent)
|
||
|
|
(let ((vars (lambda-variables (call-arg call 0)))
|
||
|
|
(args (call-args call))
|
||
|
|
(proc (call-arg call 1)))
|
||
|
|
(if (and (global-reference? proc)
|
||
|
|
(memq? 'tail-called (variable-flags (reference-variable proc))))
|
||
|
|
(call-with-driver-loop call start port indent (car vars))
|
||
|
|
(let ((deref? (or (and (reference-node? proc)
|
||
|
|
(variable-binder (reference-variable proc)))
|
||
|
|
(call-node? proc))))
|
||
|
|
(c-assign-to-variable (car vars) port indent)
|
||
|
|
(if deref?
|
||
|
|
(display "(*" port))
|
||
|
|
(c-value proc port)
|
||
|
|
(if deref?
|
||
|
|
(writec port #\)))
|
||
|
|
(write-value+result-var-list args start (cdr vars) port)))
|
||
|
|
(writec port #\;)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
(define (generate-c-tail-call call start port indent)
|
||
|
|
(let ((proc (call-arg call 1))
|
||
|
|
(args (call-args call)))
|
||
|
|
(cond ((not (and (global-reference? proc)
|
||
|
|
(memq? 'tail-called
|
||
|
|
(variable-flags (reference-variable proc)))))
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "return " port)
|
||
|
|
(c-value proc port)
|
||
|
|
(write-value-list-with-extras args start *extra-tail-call-args* port))
|
||
|
|
(*doing-tail-called-procedure?*
|
||
|
|
(generate-goto-call call start port indent))
|
||
|
|
(else
|
||
|
|
(call-with-driver-loop call start port indent #f)))
|
||
|
|
(writec port #\;)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
(define (global-reference? node)
|
||
|
|
(and (reference-node? node)
|
||
|
|
(global-variable? (reference-variable node))))
|
||
|
|
|
||
|
|
(define (call-with-driver-loop call start port indent result-var)
|
||
|
|
(let* ((proc-var (reference-variable (call-arg call 1)))
|
||
|
|
(vars (lambda-variables (global-lambda proc-var))))
|
||
|
|
(assign-global-argument-vars (cdr vars) call start port indent)
|
||
|
|
(if result-var
|
||
|
|
(c-assign-to-variable result-var port indent)
|
||
|
|
(begin
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "return " port)))
|
||
|
|
(display "TTrun_machine((long)" port)
|
||
|
|
(display "T" port)
|
||
|
|
(write-c-identifier (variable-name proc-var) port)
|
||
|
|
(display ")" port)))
|
||
|
|
|
||
|
|
(define (generate-merged-call call start form port indent)
|
||
|
|
(let ((return-index (form-return-count form))
|
||
|
|
(name (form-c-name form))
|
||
|
|
(res (lambda-variables (call-arg call 0))))
|
||
|
|
(set-form-return-count! form (+ 1 return-index))
|
||
|
|
(assign-merged-argument-vars (cdr (lambda-variables (form-value form)))
|
||
|
|
call start port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(format port "~A_return_tag = ~D;" name return-index)
|
||
|
|
(indent-to port indent)
|
||
|
|
(format port "goto ~A;" name)
|
||
|
|
(indent-to port (- indent 1))
|
||
|
|
(format port "~A_return_~S:" name return-index)
|
||
|
|
(do ((i 0 (+ i 1))
|
||
|
|
(res res (cdr res)))
|
||
|
|
((null? res))
|
||
|
|
(let ((var (car res)))
|
||
|
|
(cond ((and (used? var)
|
||
|
|
(let ((type (get-variable-type var)))
|
||
|
|
(and (not (eq? type type/unit))
|
||
|
|
(not (eq? type type/null)))))
|
||
|
|
(c-assign-to-variable var port indent)
|
||
|
|
(format port "~A~D_return_value;" name i)))))))
|
||
|
|
|
||
|
|
; Returns
|
||
|
|
|
||
|
|
(define-c-generator return #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(if *current-merged-procedure*
|
||
|
|
(generate-return-from-merged-call call 1 port indent)
|
||
|
|
(really-generate-c-return call 1 port indent))))
|
||
|
|
|
||
|
|
(define-c-generator unknown-return #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(cond (*doing-tail-called-procedure?*
|
||
|
|
(generate-return-from-tail-call call port indent))
|
||
|
|
(*current-merged-procedure*
|
||
|
|
(generate-return-from-merged-call call 1 port indent))
|
||
|
|
(else
|
||
|
|
(really-generate-c-return call 1 port indent)))))
|
||
|
|
|
||
|
|
(define (generate-return-from-tail-call call port indent)
|
||
|
|
(if (not (no-value-node? (call-arg call 1)))
|
||
|
|
(c-assignment "TTreturn_value" (call-arg call 1) port indent))
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "return(0L);" port))
|
||
|
|
|
||
|
|
(define (generate-return-from-merged-call call start port indent)
|
||
|
|
(let ((name *current-merged-procedure*))
|
||
|
|
(do ((i start (+ i 1)))
|
||
|
|
((= i (call-arg-count call)))
|
||
|
|
(let ((arg (call-arg call i)))
|
||
|
|
(if (not (no-value-node? arg))
|
||
|
|
(c-assignment (format #f "~A~D_return_value" name (- i start))
|
||
|
|
arg port indent))))
|
||
|
|
(indent-to port indent)
|
||
|
|
(format port "goto ~A_return;" name)))
|
||
|
|
|
||
|
|
(define (really-generate-c-return call start port indent)
|
||
|
|
(do ((i (+ start 1) (+ i 1)))
|
||
|
|
((= i (call-arg-count call)))
|
||
|
|
(let ((arg (call-arg call i)))
|
||
|
|
(if (not (no-value-node? arg))
|
||
|
|
(begin
|
||
|
|
(indent-to port indent)
|
||
|
|
(format port "*TT~D = " (- (- i start) 1))
|
||
|
|
(c-value arg port)
|
||
|
|
(write-char #\; port)))))
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "return" port)
|
||
|
|
(if (not (no-value-node? (call-arg call start)))
|
||
|
|
(begin
|
||
|
|
(write-char #\space port)
|
||
|
|
(c-value (call-arg call start) port)))
|
||
|
|
(display ";" port)
|
||
|
|
(values))
|
||
|
|
|
||
|
|
; Allocate
|
||
|
|
|
||
|
|
;(define-c-generator allocate #f
|
||
|
|
; (lambda (call port indent)
|
||
|
|
; (let ((cont (call-arg call 0))
|
||
|
|
; (size (call-arg call 1)))
|
||
|
|
; (c-assign-to-variable (car (lambda-variables cont)) port indent)
|
||
|
|
; (display "(long) malloc(" port)
|
||
|
|
; (c-value size port)
|
||
|
|
; (display "* sizeof(char));" port))))
|
||
|
|
|
||
|
|
(define-c-generator global-ref #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(c-value (call-arg call 0) port)))
|
||
|
|
|
||
|
|
(define-c-generator global-set! #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(let ((value (call-arg call 2)))
|
||
|
|
(if (not (and (literal-node? value)
|
||
|
|
(unspecific? (literal-value value))))
|
||
|
|
(c-assignment (reference-variable (call-arg call 1))
|
||
|
|
value
|
||
|
|
port indent)))))
|
||
|
|
|
||
|
|
; if (ARG1 OP ARG2) {
|
||
|
|
; cont1 }
|
||
|
|
; else {
|
||
|
|
; cont2 }
|
||
|
|
|
||
|
|
(define-c-generator test #f
|
||
|
|
(lambda (call port indent)
|
||
|
|
(destructure ((#(cont1 cont2 value) (call-args call)))
|
||
|
|
(generate-c-conditional-prelude port indent)
|
||
|
|
(c-value value port)
|
||
|
|
(generate-c-conditional-jumps cont1 cont2 port indent))))
|
||
|
|
|
||
|
|
(define (generate-c-conditional-prelude port indent)
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "if " port)
|
||
|
|
(writec port #\())
|
||
|
|
|
||
|
|
(define (generate-c-conditional-jumps cont1 cont2 port indent)
|
||
|
|
(display ") {" port)
|
||
|
|
(write-c-block (lambda-body cont1) port (+ indent 2))
|
||
|
|
(newline port)
|
||
|
|
(indent-to port indent)
|
||
|
|
(display "else {" port)
|
||
|
|
(write-c-block (lambda-body cont2) port (+ indent 2)))
|
||
|
|
|
||
|
|
(define-c-generator unspecific #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(bug "generating code for undefined value ~S" call)))
|
||
|
|
|
||
|
|
(define-c-generator uninitialized-value #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(bug "generating code for uninitialized value ~S" call)))
|
||
|
|
|
||
|
|
(define-c-generator null-pointer? #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(display "NULL == " port)
|
||
|
|
(c-value (call-arg call 0) port)))
|
||
|
|
|
||
|
|
(define-c-generator null-pointer #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(display "NULL" port)))
|
||
|
|
|
||
|
|
(define-c-generator eq? #t
|
||
|
|
(lambda (call port indent)
|
||
|
|
(simple-c-primop "==" call port)))
|
||
|
|
|