1; Part of Scheme 48 1.9. See file COPYING for notices and license. 2 3; Authors: Richard Kelsey, Timo Harter, Mike Sperber 4 5(define-c-generator let #f 6 (lambda (call port indent) 7 (let ((args (call-args call)) 8 (vars (lambda-variables (call-arg call 0)))) 9 (do ((i 1 (+ i 1)) 10 (vars vars (cdr vars))) 11 ((null? vars)) 12 (let ((val (vector-ref args i))) 13 (if (not (lambda-node? val)) 14 (c-assignment (car vars) val port indent))))))) 15 16(define-c-generator letrec1 #f 17 (lambda (call port indent) 18 (values))) 19 20(define-c-generator letrec2 #f 21 (lambda (call port indent) 22 (values))) 23 24(define-c-generator jump #f 25 (lambda (call port indent) 26 (let ((proc (called-lambda call))) 27 (assign-argument-vars (lambda-variables proc) call 1 port indent) 28 (indent-to port indent) 29 (display "goto " port) 30 (writec port #\L) 31 (display (lambda-id proc) port) 32 (write-char #\; port) 33 (note-jump-generated! proc) 34 (values)))) 35 36(define (assign-argument-vars vars call start port indent) 37 (really-assign-argument-vars vars call start "arg" port indent)) 38 39(define (assign-merged-argument-vars vars call start port indent) 40 (really-assign-argument-vars vars call start "merged_arg" port indent)) 41 42(define (assign-global-argument-vars vars call start port indent) 43 (really-assign-argument-vars vars call start "goto_arg" port indent)) 44 45(define (really-assign-argument-vars vars call start name port indent) 46 (let ((args (call-args call))) 47 (do ((i start (+ i 1)) 48 (vars vars (cdr vars))) 49 ((>= i (vector-length args))) 50 (if (not (or (undefined-value-node? (vector-ref args i)) 51 (eq? type/unit (get-variable-type (car vars))))) 52 (c-assignment (c-argument-var name 53 (get-variable-type (car vars)) 54 (- i start) 55 port) 56 (vector-ref args i) 57 port indent))))) 58 59; Calls 60 61; Unknown calls have a first argument of 'goto if they are supposed to be 62; tail-recursive. For known calls the protocol field of the lambda node 63; is set to 'tail-called if any of the calls are supposed to be tail-recursive. 64; 65; Calls to non-tail-called procedures are just regular C calls. For tail- 66; called procedures there are two kinds of calls: 67; Tail-call from a tail-called procedure: proceed through the driver loop 68; All others: start a driver loop 69; 70; Known and unknown calls are handled identically, except that known calls 71; may be to merged procedures. 72; 73; Merged procedures with GOTO calls: 74; This works if we merge the return points as well. Possibly there should be 75; one return switch per C procedure. There do have to be separate return point 76; variables (and one global one for the switch). 77 78(define-c-generator call #f 79 (lambda (call port indent) 80 (cond ((merged-procedure-reference (call-arg call 1)) 81 => (lambda (form) 82 (generate-merged-call call 2 form port indent))) 83 (else 84 (generate-c-call call 2 port indent))))) 85 86(define-c-generator tail-call #f 87 (lambda (call port indent) 88 (cond ((merged-procedure-reference (call-arg call 1)) 89 => (lambda (form) 90 (generate-merged-goto-call call 2 form port indent))) 91 (else 92 (generate-c-tail-call call 2 port indent))))) 93 94(define-c-generator unknown-call #f 95 (lambda (call port indent) 96 (if (goto-protocol? (literal-value (call-arg call 2))) 97 (user-warning "ignoring GOTO declaration for non-tail-recursive call to" 98 (variable-name (reference-variable 99 (call-arg call 1))))) 100 (generate-c-call call 3 port indent))) 101 102(define-c-generator unknown-tail-call #f 103 (lambda (call port indent) 104 (generate-c-tail-call call 3 port indent))) 105 106(define (generate-merged-goto-call call start form port indent) 107 (let ((proc (form-value form))) 108 (assign-merged-argument-vars (cdr (lambda-variables proc)) 109 call start 110 port indent) 111 (indent-to port indent) 112 (display "goto " port) 113 (display (form-c-name form) port) 114 (write-char #\; port) 115 (values))) 116 117(define (generate-goto-call call start port indent) 118 (let ((proc (call-arg call 1))) 119 (if (not (global-reference? proc)) 120 (bug "incorrect procedure in goto call ~S" call)) 121 (assign-global-argument-vars (cdr (lambda-variables 122 (global-lambda 123 (reference-variable proc)))) 124 call start 125 port indent) 126 ; T is the marker for the tail-call version of the procedure 127 (indent-to port indent) 128 (display "return((long)T" port) 129 (c-value proc port) 130 (display ");" port))) 131 132(define (global-lambda var) 133 (let ((form (maybe-variable->form var))) 134 (if (and form 135 (or (eq? 'lambda (form-type form)) 136 (eq? 'merged (form-type form)))) 137 (form-value form) 138 (bug "value of ~S, called using goto, is not a known procedure" 139 var)))) 140 141; C requires that we dereference all but calls to global functions. 142; Calls to literals are macros that must take care of themselves. 143 144(define (generate-c-call call start port indent) 145 (let ((vars (lambda-variables (call-arg call 0))) 146 (args (call-args call)) 147 (proc (call-arg call 1))) 148 (if (and (global-reference? proc) 149 (memq? 'tail-called (variable-flags (reference-variable proc)))) 150 (call-with-driver-loop call start port indent (car vars)) 151 (let ((deref? (or (and (reference-node? proc) 152 (variable-binder (reference-variable proc))) 153 (call-node? proc)))) 154 (if (used? (car vars)) 155 (c-assign-to-variable (car vars) port indent)) 156 (if deref? 157 (display "(*" port)) 158 (c-value proc port) 159 (if deref? 160 (writec port #\))) 161 (write-value+result-var-list args start (cdr vars) port))) 162 (writec port #\;) 163 (values))) 164 165(define (generate-c-tail-call call start port indent) 166 (let ((proc (call-arg call 1)) 167 (args (call-args call)) 168 (cont (call-arg call 0))) 169 (cond ((not (and (global-reference? proc) 170 (memq? 'tail-called 171 (variable-flags (reference-variable proc))))) 172 (let* ((type (get-variable-type (reference-variable cont))) 173 (void? (or (eq? type type/unit) 174 (eq? type type/null)))) 175 (indent-to port indent) 176 (if (not void?) 177 (display "return " port)) 178 (c-value proc port) 179 (write-value-list-with-extras args start *extra-tail-call-args* port) 180 (if void? 181 (begin 182 (display ";" port) 183 (indent-to port indent) 184 (display "return" port))))) 185 (*doing-tail-called-procedure?* 186 (generate-goto-call call start port indent)) 187 (else 188 (call-with-driver-loop call start port indent #f))) 189 (writec port #\;) 190 (values))) 191 192(define (global-reference? node) 193 (and (reference-node? node) 194 (global-variable? (reference-variable node)))) 195 196(define (call-with-driver-loop call start port indent result-var) 197 (let* ((proc-var (reference-variable (call-arg call 1))) 198 (vars (lambda-variables (global-lambda proc-var)))) 199 (assign-global-argument-vars (cdr vars) call start port indent) 200 (if result-var 201 (c-assign-to-variable result-var port indent) 202 (begin 203 (indent-to port indent) 204 (display "return " port))) 205 (display "TTrun_machine((long)" port) 206 (display "T" port) 207 (write-c-identifier (variable-name proc-var) port) 208 (display ")" port))) 209 210(define (generate-merged-call call start form port indent) 211 (let ((return-index (form-return-count form)) 212 (name (form-c-name form)) 213 (res (lambda-variables (call-arg call 0)))) 214 (set-form-return-count! form (+ 1 return-index)) 215 (assign-merged-argument-vars (cdr (lambda-variables (form-value form))) 216 call start port indent) 217 (format port "~%#ifdef USE_DIRECT_THREADING~%") 218 (indent-to port indent) 219 (format port "~A_return_address = &&~A_return_~S;~%#else~%" name name return-index) 220 (indent-to port indent) 221 (format port "~A_return_tag = ~D;~%#endif~%" name return-index) 222 (indent-to port indent) 223 (format port "goto ~A;" name) 224 (indent-to port (- indent 1)) 225 (format port "~A_return_~S:" name return-index) 226 (do ((i 0 (+ i 1)) 227 (res res (cdr res))) 228 ((null? res)) 229 (let ((var (car res))) 230 (cond ((and (used? var) 231 (let ((type (get-variable-type var))) 232 (and (not (eq? type type/unit)) 233 (not (eq? type type/null))))) 234 (c-assign-to-variable var port indent) 235 (format port "~A~D_return_value;" name i))))))) 236 237; Returns 238 239(define-c-generator return #f 240 (lambda (call port indent) 241 (if *current-merged-procedure* 242 (generate-return-from-merged-call call 1 port indent) 243 (really-generate-c-return call 1 port indent)))) 244 245(define-c-generator unknown-return #f 246 (lambda (call port indent) 247 (cond (*doing-tail-called-procedure?* 248 (generate-return-from-tail-call call port indent)) 249 (*current-merged-procedure* 250 (generate-return-from-merged-call call 1 port indent)) 251 (else 252 (really-generate-c-return call 1 port indent))))) 253 254(define (generate-return-from-tail-call call port indent) 255 (if (not (no-value-node? (call-arg call 1))) 256 (c-assignment "TTreturn_value" (call-arg call 1) port indent)) 257 (indent-to port indent) 258 (display "return(0L);" port)) 259 260(define (generate-return-from-merged-call call start port indent) 261 (let ((name *current-merged-procedure*)) 262 (do ((i start (+ i 1))) 263 ((= i (call-arg-count call))) 264 (let ((arg (call-arg call i))) 265 (if (not (no-value-node? arg)) 266 (c-assignment (format #f "~A~D_return_value" name (- i start)) 267 arg port indent)))) 268 (format port "~%#ifdef USE_DIRECT_THREADING~%") 269 (indent-to port indent) 270 (format port "goto *~A_return_address;~%#else~%" name) 271 (indent-to port indent) 272 (format port "goto ~A_return;~%#endif~%" name))) 273 274(define (really-generate-c-return call start port indent) 275 (do ((i (+ start 1) (+ i 1))) 276 ((= i (call-arg-count call))) 277 (let ((arg (call-arg call i))) 278 (if (not (no-value-node? arg)) 279 (begin 280 (indent-to port indent) 281 (format port "*TT~D = " (- (- i start) 1)) 282 (c-value arg port) 283 (write-char #\; port))))) 284 (let ((result (call-arg call start))) 285 (cond 286 ((and (not (no-value-node? result)) 287 (let ((type (get-variable-type 288 (reference-variable (call-arg call 0))))) 289 (and (not (eq? type type/unit)) 290 (not (eq? type type/null))))) 291 292 (indent-to port indent) 293 (display "return" port) 294 (write-char #\space port) 295 (c-value result port) 296 (display ";" port)) 297 (else 298 (if (call-node? result) 299 ;; emit for the side effects 300 (begin 301 (indent-to port indent) 302 (primop-generate-c (call-primop result) result port 0) 303 (display ";" port) 304 (newline port))) 305 (indent-to port indent) 306 (display "return" port) 307 (display ";" port)))) 308 (values)) 309 310; Allocate 311 312;(define-c-generator allocate #f 313; (lambda (call port indent) 314; (let ((cont (call-arg call 0)) 315; (size (call-arg call 1))) 316; (c-assign-to-variable (car (lambda-variables cont)) port indent) 317; (display "(long) malloc(" port) 318; (c-value size port) 319; (display "* sizeof(char));" port)))) 320 321(define-c-generator global-ref #t 322 (lambda (call port indent) 323 (c-value (call-arg call 0) port))) 324 325(define-c-generator global-set! #f 326 (lambda (call port indent) 327 (let ((value (call-arg call 2))) 328 (if (not (and (literal-node? value) 329 (unspecific? (literal-value value)))) 330 (c-assignment (reference-variable (call-arg call 1)) 331 value 332 port indent))))) 333 334; if (ARG1 OP ARG2) { 335; cont1 } 336; else { 337; cont2 } 338 339(define-c-generator test #f 340 (lambda (call port indent) 341 (destructure ((#(cont1 cont2 value) (call-args call))) 342 (generate-c-conditional-prelude port indent) 343 (c-value value port) 344 (generate-c-conditional-jumps cont1 cont2 port indent)))) 345 346(define (generate-c-conditional-prelude port indent) 347 (indent-to port indent) 348 (display "if " port) 349 (writec port #\()) 350 351(define (generate-c-conditional-jumps cont1 cont2 port indent) 352 (display ") {" port) 353 (write-c-block (lambda-body cont1) port (+ indent 2)) 354 (newline port) 355 (indent-to port indent) 356 (display "else {" port) 357 (write-c-block (lambda-body cont2) port (+ indent 2))) 358 359(define-c-generator unspecific #t 360 (lambda (call port indent) 361 (bug "generating code for undefined value ~S" call))) 362 363(define-c-generator uninitialized-value #t 364 (lambda (call port indent) 365 (bug "generating code for uninitialized value ~S" call))) 366 367(define-c-generator null-pointer? #t 368 (lambda (call port indent) 369 (display "NULL == " port) 370 (c-value (call-arg call 0) port))) 371 372(define-c-generator null-pointer #t 373 (lambda (call port indent) 374 (display "NULL" port))) 375 376(define-c-generator eq? #t 377 (lambda (call port indent) 378 (simple-c-primop "==" call port))) 379 380