source: project/chicken/branches/lazy-gensyms/c-platform.scm @ 12629

Last change on this file since 12629 was 12629, checked in by felix winkelmann, 12 years ago

support for lazy gensyms; some refactoring in get/put\!

File size: 48.2 KB
Line 
1;;;; c-platform.scm - Platform specific parameters and definitions
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare (unit platform))
29
30
31(private compiler
32  compiler-arguments process-command-line
33  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
34  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
35  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
36  installation-home debugging intrinsic?
37  dump-nodes unlikely-variables
38  unit-name insert-timer-checks used-units inlining
39  foreign-declarations block-compilation line-number-database-size
40  target-heap-size target-stack-size 
41  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
42  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
43  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 
44  broken-constant-nodes inline-substitutions-enabled
45  direct-call-ids foreign-type-table first-analysis
46  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments
47  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
48  reorganize-recursive-bindings substitution-table simplify-named-call find-inlining-candidates perform-inlining!
49  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
50  transform-direct-lambdas! decompose-lambda-list rewrite
51  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
52  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
53  collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
54  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
55  build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
56  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list 
57  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
58  topological-sort print-version print-usage initialize-analysis-database
59  default-declarations default-debugging-declarations units-used-by-default words-per-flonum
60  parameter-limit eq-inline-operator optimizable-rest-argument-operators
61  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
62  target-include-file default-profiling-declarations
63  default-optimization-passes internal-bindings big-fixnum?
64  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
65  foreign-argument-conversion foreign-result-conversion)
66
67
68(include "tweaks")
69
70
71;;; Parameters:
72
73(define default-optimization-passes 3)
74
75(define default-declarations
76  '((always-bound
77     ##sys#standard-input ##sys#standard-output ##sys#standard-error)
78    (bound-to-procedure
79     ##sys#for-each ##sys#map ##sys#print ##sys#setter
80     ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values
81     ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot 
82     ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!
83     ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument
84     ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string 
85     ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string ##sys#gensym
86     ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument
87     ##sys#call-with-current-continuation) ) )
88
89(define default-debugging-declarations
90  '((##core#declare
91      '(uses debugger)
92      '(bound-to-procedure
93        ##sys#push-debug-frame ##sys#pop-debug-frame ##sys#check-debug-entry ##sys#check-debug-assignment
94        ##sys#register-debug-lambdas ##sys#register-debug-variables ##sys#debug-call) ) ) )
95
96(define default-profiling-declarations
97  '((##core#declare
98     (uses profiler)
99     (bound-to-procedure
100       ##sys#profile-entry ##sys#profile-exit) ) ) )
101
102(define units-used-by-default '(library eval data-structures ports extras srfi-69)) 
103(define words-per-flonum 4)
104(define parameter-limit 1024)
105(define small-parameter-limit 128)
106(define unlikely-variables '(unquote unquote-splicing))
107
108(define eq-inline-operator "C_eqp")
109(define optimizable-rest-argument-operators '(car cadr caddr cadddr length pair? null? list-ref))
110(define membership-test-operators
111  '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")
112    ("C_i_memv" . "C_i_eqvp") ) )
113(define membership-unfold-limit 20)
114(define target-include-file "chicken.h")
115
116(define valid-compiler-options
117  '(-help h help version verbose explicit-use 
118          quiet                         ; DEPRECATED
119          no-trace no-warnings unsafe block
120    check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info 
121    profile inline keep-shadowed-macros
122    fixnum-arithmetic disable-interrupts optimize-leaf-routines
123    lambda-lift compile-syntax tag-pointers accumulate-profile
124    disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw 
125    emit-external-prototypes-first release local inline-global
126    analyze-only dynamic extension) )
127
128(define valid-compiler-options-with-argument
129  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension 
130          inline-limit profile-name disable-warning
131    prelude postlude prologue epilogue nursery extend feature 
132    emit-import-library emit-inline-file
133    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
134
135
136;;; Standard and extended bindings:
137
138(define default-standard-bindings
139  '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
140    cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
141    cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
142    null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port
143    write-char newline write display append symbol->string for-each map char? char->integer
144    integer->char eof-object? vector-length string-length string-ref string-set! vector-ref 
145    vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
146    number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
147    max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
148    exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
149    char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
150    char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
151    string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
152    string-append string->list list->string vector? vector->list list->vector string read
153    read-char substring string-fill! vector-fill! make-string make-vector open-input-file
154    open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
155    values call-with-values vector procedure? memq memv member assq assv assoc list-tail
156    list-ref abs char-ready? peek-char list->string string->list) )
157
158(define default-extended-bindings
159  '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod
160    fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
161    fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
162    arithmetic-shift void flush-output thread-specific thread-specific-set!
163    not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
164    blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
165    s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared
166    f32vector->blob/shared f64vector->blob/shared
167    blob->u8vector/shared blob->s8vector/shared blob->u16vector/shared
168    blob->s16vector/shared blob->u32vector/shared blob->s32vector/shared
169    blob->f32vector/shared blob->f64vector/shared
170    block-ref block-set! number-of-slots substring-index substring-index-ci
171    hash-table-ref any? read-string substring=? substring-ci=?
172    first second third fourth make-record-instance
173    u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
174    f32vector-length f64vector-length setter
175    u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
176    f32vector-ref f64vector-ref
177    u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
178    locative-ref locative-set! locative->object locative? global-ref
179    null-pointer? pointer->object flonum? finite?) )
180
181(define internal-bindings
182  '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
183    ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
184    ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
185    ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol 
186    ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons
187    ##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range? 
188    ##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
189    ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
190    ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?
191    ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#gensym
192    ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
193    ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
194    ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
195    ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number
196    ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
197    ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) )
198
199(define side-effecting-standard-bindings
200  '(apply call-with-current-continuation set-car! set-cdr! write-char newline write display
201    peek-char char-ready?
202    read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file
203    open-output-file close-input-port close-output-port call-with-input-port call-with-output-port
204    call-with-values eval) )
205
206(define non-foldable-standard-bindings
207  '(vector cons list string make-vector make-string string->symbol values current-input-port current-output-port
208           read-char write-char) )
209
210(define foldable-standard-bindings
211  (lset-difference 
212   eq? default-standard-bindings 
213   side-effecting-standard-bindings non-foldable-standard-bindings) )
214
215(define non-foldable-extended-bindings
216  '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void
217    u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
218    f32vector->blob/shared f64vector->blob/shared
219    s32vector->blob/shared read-string read-string!
220    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
221    ##sys#byte ##sys#setbyte 
222    u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
223    f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
224    u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
225    u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
226    ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )
227
228(define foldable-extended-bindings
229  (lset-difference
230   eq? default-extended-bindings non-foldable-extended-bindings) )
231
232(define standard-bindings-that-never-return-false
233  '(cons list length * - + / current-output-port current-input-port append symbol->string char->integer
234    integer->char vector-length string-length string-ref gcd lcm reverse string->symbol max min
235    quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact exp log sin
236    cons tan atan expt sqrt asin acos number->string char-upcase char-downcase string-append string
237    string->list list->string vector->list list->vector read-char substring make-string make-vector
238    open-input-file open-output-file vector write-char) )
239
240(define side-effect-free-standard-bindings-that-never-return-false
241  (lset-difference
242   eq? standard-bindings-that-never-return-false
243   side-effecting-standard-bindings) )
244
245
246;;; Rewriting-definitions for this platform:
247
248(rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f)
249
250(rewrite
251 '* 8 
252 (lambda (db classargs cont callargs)
253   ;; (*) -> 1
254   ;; (* <x>) -> <x>
255   ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]
256   ;; - Remove "1" from arguments.
257   ;; - Replace multiplications with 2 by shift left. [fixnum-mode]
258   (let ([callargs 
259          (remove
260           (lambda (x)
261             (and (eq? 'quote (node-class x))
262                  (= 1 (first (node-parameters x))) ) ) 
263           callargs) ] )
264     (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode 0)))]
265           [(null? (cdr callargs))
266            (make-node '##core#call '(#t) (list cont (first callargs))) ]
267           [(eq? number-type 'fixnum)
268            (make-node 
269             '##core#call '(#t)
270             (list
271              cont
272              (fold-inner
273               (lambda (x y)
274                 (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y))))
275                     (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))
276                     (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )
277               callargs) ) ) ]
278           [else #f] ) ) ) )
279
280(rewrite 
281 '- 8 
282 (lambda (db classargs cont callargs)
283   ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>)  [fixnum-mode]
284   ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>)  [fixnum-mode + unsafe]
285   ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]
286   ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...))
287   ;;    [fixnum-mode + unsafe]
288   ;; - Remove "0" from arguments, if more than 1.
289   (cond [(null? callargs) #f]
290         [(and (null? (cdr callargs)) (eq? number-type 'fixnum))
291          (make-node
292           '##core#call '(#t)
293           (list cont
294                 (make-node '##core#inline
295                            (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))
296                            callargs)) ) ]
297         [else
298          (let ([callargs
299                 (cons (car callargs)
300                       (remove
301                        (lambda (x)
302                          (and (eq? 'quote (node-class x))
303                               (zero? (first (node-parameters x))) ) ) 
304                        (cdr callargs) ) ) ] )
305            (and (eq? number-type 'fixnum)
306                 (>= (length callargs) 2)
307                 (make-node
308                  '##core#call '(#t)
309                  (list
310                   cont
311                   (fold-inner
312                    (lambda (x y)
313                      (make-node '##core#inline 
314                                 (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))
315                                 (list x y) ) )
316                    callargs) ) ) ) ) ] ) ) )
317
318(rewrite 
319 '/ 8 
320 (lambda (db classargs cont callargs)
321   ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]
322   ;; - Remove "1" from arguments, if more than 1.
323   ;; - Replace divisions by 2 with shift right. [fixnum-mode]
324   (and (>= (length callargs) 2)
325        (let ([callargs
326               (cons (car callargs)
327                     (remove
328                      (lambda (x)
329                        (and (eq? 'quote (node-class x))
330                             (= 1 (first (node-parameters x))) ) ) 
331                      (cdr callargs) ) ) ] )
332          (and (eq? number-type 'fixnum)
333               (>= (length callargs) 2)
334               (make-node
335                '##core#call '(#t)
336                (list
337                 cont
338                 (fold-inner
339                  (lambda (x y)
340                    (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y))))
341                        (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))
342                        (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )
343                  callargs) ) ) ) ) ) ) )
344
345(rewrite
346 'quotient 8
347 (lambda (db classargs cont callargs)
348   ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]
349   ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]
350   ;; (quotient <x> <y>) -> ((##core#proc "C_quotient") <x> <y>)
351   (and (= (length callargs) 2)
352        (if (eq? 'fixnum number-type)
353            (make-node
354             '##core#call '(#t)
355             (let ([arg2 (second callargs)])
356               (list cont 
357                     (if (and (eq? 'quote (node-class arg2)) 
358                              (= 2 (first (node-parameters arg2))) )
359                         (make-node 
360                          '##core#inline '("C_fixnum_shift_right") 
361                          (list (first callargs) (qnode 1)) )
362                         (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) )
363            (make-node
364             '##core#call '(#t)
365             (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) )
366
367(let ()
368  (define (eqv?-id db classargs cont callargs)
369    ;; (eqv? <var> <var>) -> (quote #t)
370    ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum]
371    (and (= (length callargs) 2)
372         (let ([arg1 (first callargs)]
373               [arg2 (second callargs)] )
374           (or (and (eq? '##core#variable (node-class arg1))
375                    (eq? '##core#variable (node-class arg2))
376                    (equal? (node-parameters arg1) (node-parameters arg2))
377                    (make-node '##core#call '(#t) (list cont (qnode #t))) )
378               (and (or (and (eq? 'quote (node-class arg1))
379                             (not (flonum? (first (node-parameters arg1)))) )
380                        (and (eq? 'quote (node-class arg2))
381                             (not (flonum? (first (node-parameters arg2)))) ) )
382                    (make-node
383                     '##core#call '(#t) 
384                     (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )
385  (rewrite 'eqv? 8 eqv?-id)
386  (rewrite '##sys#eqv? 8 eqv?-id))
387
388(rewrite
389 'equal? 8
390 (lambda (db classargs cont callargs)
391   ;; (equal? <var> <var>) -> (quote #t)
392   ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol]
393   ;; (equal? ...) -> (##core#inline "C_i_equalp" ...)
394   (and (= (length callargs) 2)
395        (let ([arg1 (first callargs)]
396              [arg2 (second callargs)] )
397          (or (and (eq? '##core#variable (node-class arg1))
398                   (eq? '##core#variable (node-class arg2))
399                   (equal? (node-parameters arg1) (node-parameters arg2))
400                   (make-node '##core#call '(#t) (list cont (qnode #t))) )
401              (and (or (and (eq? 'quote (node-class arg1))
402                            (let ([f (first (node-parameters arg1))])
403                              (or (immediate? f) (symbol? f)) ) )
404                       (and (eq? 'quote (node-class arg2))
405                            (let ([f (first (node-parameters arg2))])
406                              (or (immediate? f) (symbol? f)) ) ) )
407                   (make-node
408                    '##core#call '(#t) 
409                    (list cont (make-node '##core#inline '("C_eqp") callargs)) ) )
410              (make-node
411               '##core#call '(#t) 
412               (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )
413
414(let ()
415  (define (rewrite-apply db classargs cont callargs)
416    ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...)
417    ;; (apply ...) -> ((##core#proc "C_apply") ...)
418    ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst)
419    ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst)
420    (and (pair? callargs)
421         (let ([lastarg (last callargs)]
422               [proc (car callargs)] )
423           (if (eq? 'quote (node-class lastarg))
424               (make-node
425                '##core#call '(#f)
426                (cons* (first callargs)
427                       cont 
428                       (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )
429               (or (and (eq? '##core#variable (node-class proc))
430                        (= 2 (length callargs))
431                        (let ([name (car (node-parameters proc))])
432                          (and (memq name '(values ##sys#values))
433                               (intrinsic? name)
434                               (make-node
435                                '##core#call '(#t)
436                                (list (make-node '##core#proc '("C_apply_values" #t) '())
437                                      cont
438                                      (cadr callargs) ) ) ) ) ) 
439                   (make-node
440                    '##core#call '(#t)
441                    (cons* (make-node '##core#proc '("C_apply" #t) '())
442                           cont callargs) ) ) ) ) ) )
443  (rewrite 'apply 8 rewrite-apply)
444  (rewrite '##sys#apply 8 rewrite-apply) )
445
446(let ()
447  (define (rewrite-c..r op iop1 iop2 index)
448    (rewrite
449     op 8
450     (lambda (db classargs cont callargs)
451       ;; (<op> <rest-vector>) -> (##core#inline "C_i_vector_ref"/"C_slot" <rest-vector> (quote <index>))
452       ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe]
453       ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe]
454       (and (= (length callargs) 1)
455            (call-with-current-continuation
456             (lambda (return)
457               (let ([arg (first callargs)])
458                 (make-node
459                  '##core#call '(#t)
460                  (list
461                   cont
462                   (cond [(and (eq? '##core#variable (node-class arg))
463                               (eq? 'vector (get db (first (node-parameters arg)) 'rest-parameter)) )
464                          (make-node
465                           '##core#inline 
466                           (if unsafe
467                               '("C_slot")
468                               '("C_i_vector_ref") )
469                           (list arg (qnode index)) ) ]
470                         [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]
471                         [iop1 (make-node '##core#inline (list iop1) callargs)]
472                         [else (return #f)] ) ) ) ) ) ) ) ) ) )
473
474  (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0)
475  (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car" 0)
476  (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr" 0)
477  (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr" 1)
478  (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr" 2)
479  (rewrite-c..r 'cadddr "C_i_cadddr" "C_u_i_cadddr" 3)
480  (rewrite-c..r 'first "C_i_car" "C_u_i_car" 0)
481  (rewrite-c..r 'second "C_i_cadr" "C_u_i_cadr" 1)
482  (rewrite-c..r 'third "C_i_caddr" "C_u_i_caddr" 2)
483  (rewrite-c..r 'fourth "C_i_cadddr" "C_u_i_cadddr" 3) )
484
485(let ([rvalues
486       (lambda (db classargs cont callargs)
487         ;; (values <x>) -> <x>
488         (and (= (length callargs) 1)
489              (make-node '##core#call '(#t) (cons cont callargs) ) ) ) ] )
490  (rewrite 'values 8 rvalues)
491  (rewrite '##sys#values 8 rvalues) )
492
493(let ()
494  (define (rewrite-c-w-v db classargs cont callargs)
495   ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) (<var2> <k0> r)))) (<var1> k))
496   ;; - if <var2> is a known lambda of a single argument
497   (and (= 2 (length callargs))
498        (let ((arg1 (car callargs))
499              (arg2 (cadr callargs)) )
500          (and (eq? '##core#variable (node-class arg1)) ; probably not needed
501               (eq? '##core#variable (node-class arg2))
502               (and-let* ((sym (car (node-parameters arg2)))
503                          (val (get db sym 'value)) )
504                 (and (eq? '##core#lambda (node-class val))
505                      (let ((llist (third (node-parameters val))))
506                        (and (proper-list? llist)
507                             (= 2 (length (third (node-parameters val))))
508                             (let ((tmp (gensym))
509                                   (tmpk (gensym 'r)) )
510                               (debugging 'o "removing single-valued `call-with-values'" (node-parameters val))
511                               (make-node
512                                'let (list tmp)
513                                (list (make-node
514                                       '##core#lambda
515                                       (list (gensym 'f_) #f (list tmpk) 0)
516                                       (list (make-node
517                                              '##core#call '(#t)
518                                              (list arg2 cont (varnode tmpk)) ) ) ) 
519                                      (make-node
520                                       '##core#call '(#t)
521                                       (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )
522  (rewrite 'call-with-values 8 rewrite-c-w-v)
523  (rewrite '##sys#call-with-values 8 rewrite-c-w-v) )
524
525(rewrite 'values 13 "C_values" #t)
526(rewrite '##sys#values 13 "C_values" #t)
527(rewrite 'call-with-values 13 "C_u_call_with_values" #f)
528(rewrite 'call-with-values 13 "C_call_with_values" #t)
529(rewrite '##sys#call-with-values 13 "C_u_call_with_values" #f)
530(rewrite '##sys#call-with-values 13 "C_call_with_values" #t)
531(rewrite 'cpu-time 13 "C_cpu_time" #t)
532(rewrite 'locative-ref 13 "C_locative_ref" #t)
533(rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t)
534
535(rewrite 'caar 2 1 "C_u_i_caar" #f #f)
536(rewrite 'cdar 2 1 "C_u_i_cdar" #f #f)
537(rewrite 'cddr 2 1 "C_u_i_cddr" #f #f)
538(rewrite 'caaar 2 1 "C_u_i_caaar" #f #f)
539(rewrite 'cadar 2 1 "C_u_i_cadar" #f #f)
540(rewrite 'caddr 2 1 "C_u_i_caddr" #f #f)
541(rewrite 'cdaar 2 1 "C_u_i_cdaar" #f #f)
542(rewrite 'cdadr 2 1 "C_u_i_cdadr" #f #f)
543(rewrite 'cddar 2 1 "C_u_i_cddar" #f #f)
544(rewrite 'cdddr 2 1 "C_u_i_cdddr" #f #f)
545(rewrite 'caaaar 2 1 "C_u_i_caaaar" #f #f)
546(rewrite 'caadar 2 1 "C_u_i_caadar" #f #f)
547(rewrite 'caaddr 2 1 "C_u_i_caaddr" #f #f)
548(rewrite 'cadaar 2 1 "C_u_i_cadaar" #f #f)
549(rewrite 'cadadr 2 1 "C_u_i_cadadr" #f #f)
550(rewrite 'caddar 2 1 "C_u_i_caddar" #f #f)
551(rewrite 'cadddr 2 1 "C_u_i_cadddr" #f #f)
552(rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f #f)
553(rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f #f)
554(rewrite 'cdadar 2 1 "C_u_i_cdadar" #f #f)
555(rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f #f)
556(rewrite 'cddaar 2 1 "C_u_i_cddaar" #f #f)
557(rewrite 'cddadr 2 1 "C_u_i_cddadr" #f #f)
558(rewrite 'cdddar 2 1 "C_u_i_cdddar" #f #f)
559(rewrite 'cddddr 2 1 "C_u_i_cddddr" #f #f)
560
561(rewrite 'cddr 2 1 "C_i_cddr" #t #f)
562(rewrite 'cdddr 2 1 "C_i_cdddr" #t #f)
563(rewrite 'cddddr 2 1 "C_i_cddddr" #t #f)
564
565(rewrite 'cdr 7 1 "C_slot" 1 #f)
566(rewrite 'cdr 2 1 "C_i_cdr" #t #f)
567
568(rewrite 'eq? 1 2 "C_eqp")
569(rewrite '##sys#eq? 1 2 "C_eqp")
570(rewrite 'eqv? 1 2 "C_i_eqvp")
571(rewrite '##sys#eqv? 1 2 "C_i_eqvp")
572
573(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot")
574(rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref")
575(rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp")
576(rewrite '##sys#null? 2 1 "C_i_nullp" #t "C_vemptyp")
577(rewrite 'length 2 1 "C_i_length" #t "C_block_size")
578(rewrite 'not 2 1 "C_i_not" #t #f)
579(rewrite 'char? 2 1 "C_charp" #t #f)
580(rewrite 'string? 2 1 "C_i_stringp" #t #f)
581(rewrite 'locative? 2 1 "C_i_locativep" #t #f)
582(rewrite 'symbol? 2 1 "C_i_symbolp" #t #f)
583(rewrite 'vector? 2 1 "C_i_vectorp" #t #f)
584(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t #f)
585(rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
586(rewrite '##sys#pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
587(rewrite 'procedure? 2 1 "C_i_closurep" #t #f)
588(rewrite 'port? 2 1 "C_i_portp" #t #f)
589(rewrite 'boolean? 2 1 "C_booleanp" #t #f)
590(rewrite 'number? 2 1 "C_i_numberp" #t #f)
591(rewrite 'complex? 2 1 "C_i_numberp" #t #f)
592(rewrite 'rational? 2 1 "C_i_numberp" #t #f)
593(rewrite 'real? 2 1 "C_i_numberp" #t #f)
594(rewrite 'integer? 2 1 "C_i_integerp" #t #f)
595(rewrite 'flonum? 2 1 "C_i_flonump" #t #f)
596(rewrite 'fixnum? 2 1 "C_fixnump" #t #f)
597(rewrite 'finite? 2 1 "C_i_finitep" #f #f)
598(rewrite '##sys#pointer? 2 1 "C_pointerp" #t #f)
599(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f)
600(rewrite 'exact? 2 1 "C_fixnump" #f #f)
601(rewrite 'exact? 2 1 "C_i_exactp" #t #f)
602(rewrite 'exact? 2 1 "C_u_i_exactp" #f #f)
603(rewrite 'inexact? 2 1 "C_nfixnump" #f #f)
604(rewrite 'inexact? 2 1 "C_i_inexactp" #t #f)
605(rewrite 'inexact? 2 1 "C_u_i_inexactp" #f #f)
606(rewrite 'list? 2 1 "C_i_listp" #t #f)
607(rewrite 'proper-list? 2 1 "C_i_listp" #t #f)
608(rewrite 'eof-object? 2 1 "C_eofp" #t #f)
609(rewrite 'string-ref 2 2 "C_subchar" #f #f)
610(rewrite 'string-ref 2 2 "C_i_string_ref" #t #f)
611(rewrite 'string-set! 2 3 "C_setsubchar" #f #f)
612(rewrite 'string-set! 2 3 "C_i_string_set" #t #f)
613(rewrite 'vector-ref 2 2 "C_slot" #f #f)
614(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t #f)
615(rewrite 'char=? 2 2 "C_eqp" #t #f)
616(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t #f)
617(rewrite 'char<? 2 2 "C_fixnum_lessp" #t #f)
618(rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t #f)
619(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f)
620(rewrite '##sys#slot 2 2 "C_slot" #t #f)                ; consider as safe, the primitive is unsafe anyway.
621(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ;*** must be safe for pattern matcher (anymore?)
622(rewrite '##sys#size 2 1 "C_block_size" #t #f)
623(rewrite 'fxnot 2 1 "C_fixnum_not" #t #f)
624(rewrite 'fx* 2 2 "C_fixnum_times" #t #f)
625(rewrite 'fx/ 2 2 "C_fixnum_divide" #f #f)
626(rewrite 'fxmod 2 2 "C_fixnum_modulo" #f #f)
627(rewrite 'fx= 2 2 "C_eqp" #t #f)
628(rewrite 'fx> 2 2 "C_fixnum_greaterp" #t #f)
629(rewrite 'fx< 2 2 "C_fixnum_lessp" #t #f)
630(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t #f)
631(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t #f)
632(rewrite 'fp= 2 2 "C_flonum_equalp" #t #f)
633(rewrite 'fp> 2 2 "C_flonum_greaterp" #t #f)
634(rewrite 'fp< 2 2 "C_flonum_lessp" #t #f)
635(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t #f)
636(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t #f)
637(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t #f)
638(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t #f)
639(rewrite 'fpmax 2 2 "C_i_flonum_max" #t #f)
640(rewrite 'fpmin 2 2 "C_i_flonum_min" #t #f)
641(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t #f)
642(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t #f)
643(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t #f)
644(rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t #f)
645(rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t #f)
646(rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t #f)
647(rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t #f)
648(rewrite 'list-tail 2 2 "C_i_list_tail" #t #f)
649(rewrite '##sys#structure? 2 2 "C_i_structurep" #t #f)
650(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t #f)
651(rewrite 'block-ref 2 2 "C_slot" #f #f) ; ok to be unsafe, lolevel is anyway
652(rewrite 'number-of-slots 2 1 "C_block_size" #f #f)
653
654(rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")
655(rewrite 'assv 2 2 "C_i_assv" #t #f)
656(rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")
657(rewrite 'memv 2 2 "C_i_memv" #t #f)
658(rewrite 'assq 17 2 "C_i_assq" "C_u_i_assq")
659(rewrite 'memq 17 2 "C_i_memq" "C_u_i_memq")
660(rewrite 'assoc 2 2 "C_i_assoc" #t #f)
661(rewrite 'member 2 2 "C_i_member" #t #f)
662
663(rewrite 'set-car! 4 '##sys#setslot 0)
664(rewrite 'set-cdr! 4 '##sys#setslot 1)
665(rewrite 'set-car! 17 2 "C_i_set_car" "C_u_i_set_car")
666(rewrite 'set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr")
667
668(rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")
669(rewrite 'abs 16 1 "C_a_i_abs" #t words-per-flonum)
670
671(rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_a_i_bitwise_xor" words-per-flonum)
672(rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_a_i_bitwise_and" words-per-flonum)
673(rewrite 'bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_a_i_bitwise_ior" words-per-flonum)
674
675(rewrite 'bitwise-not 22 1 "C_a_i_bitwise_not" #t words-per-flonum "C_fixnum_not")
676
677(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #t words-per-flonum)
678(rewrite 'fp- 16 2 "C_a_i_flonum_difference" #t words-per-flonum)
679(rewrite 'fp* 16 2 "C_a_i_flonum_times" #t words-per-flonum)
680(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #t words-per-flonum)
681(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #t words-per-flonum)
682
683(rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum)
684(rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum)
685(rewrite 'cos 16 1 "C_a_i_cos" #t words-per-flonum)
686(rewrite 'tan 16 1 "C_a_i_tan" #t words-per-flonum)
687(rewrite 'log 16 1 "C_a_i_log" #t words-per-flonum)
688(rewrite 'asin 16 1 "C_a_i_asin" #t words-per-flonum)
689(rewrite 'acos 16 1 "C_a_i_acos" #t words-per-flonum)
690(rewrite 'atan 16 1 "C_a_i_atan" #t words-per-flonum)
691(rewrite 'sqrt 16 1 "C_a_i_sqrt" #t words-per-flonum)
692(rewrite 'atan 16 2 "C_a_i_atan2" #t words-per-flonum)
693
694(rewrite 'zero? 5 "C_eqp" 0 'fixnum)
695(rewrite 'zero? 2 1 "C_i_zerop" #t #f)
696(rewrite 'zero? 2 1 "C_u_i_zerop" #f #f)
697(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum)
698(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum)
699(rewrite 'positive? 2 1 "C_i_positivep" #t #f)
700(rewrite 'positive? 2 1 "C_u_i_positivep" #f #f)
701(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum)
702(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum)
703(rewrite 'negative? 2 1 "C_i_negativep" #t #f)
704(rewrite 'negative? 2 1 "C_u_i_negativep" #f #f)
705
706(rewrite 'vector-length 6 "C_fix" "C_header_size" #f)
707(rewrite 'string-length 6 "C_fix" "C_header_size" #f)
708(rewrite 'char->integer 6 "C_fix" "C_character_code" #t)
709(rewrite 'integer->char 6 "C_make_character" "C_unfix" #t)
710
711(rewrite 'vector-length 2 1 "C_i_vector_length" #t #f)
712(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t #f)
713(rewrite 'string-length 2 1 "C_i_string_length" #t #f)
714(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f)
715
716(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t #f)
717(rewrite '##sys#check-number 2 1 "C_i_check_number" #t #f)
718(rewrite '##sys#check-list 2 1 "C_i_check_list" #t #f)
719(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t #f)
720(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t #f)
721(rewrite '##sys#check-string 2 1 "C_i_check_string" #t #f)
722(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t #f)
723(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t #f)
724(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t #f)
725(rewrite '##sys#check-char 2 1 "C_i_check_char" #t #f)
726(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t #f)
727(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t #f)
728(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t #f)
729(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t #f)
730(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t #f)
731(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t #f)
732(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t #f)
733(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t #f)
734(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t #f)
735(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t #f)
736
737(rewrite '= 9 "C_eqp" "C_i_equalp" #t #t)
738(rewrite '> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f)
739(rewrite '< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f)
740(rewrite '>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f)
741(rewrite '<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f)
742
743(rewrite 'setter 11 1 '##sys#setter #t)
744(rewrite 'for-each 11 2 '##sys#for-each #t)
745(rewrite 'map 11 2 '##sys#map #t)
746(rewrite 'block-set! 11 3 '##sys#setslot #t)
747(rewrite '##sys#block-set! 11 3 '##sys#setslot #f)
748(rewrite 'make-record-instance 11 #f '##sys#make-structure #f)
749(rewrite 'substring 11 3 '##sys#substring #f)
750(rewrite 'string-append 11 2 '##sys#string-append #f)
751(rewrite 'string->list 11 1 '##sys#string->list #t)
752(rewrite 'list->string 11 1 '##sys#list->string #t)
753(rewrite 'gensym 11 0 '##sys#gensym #t)
754
755(rewrite 'vector-set! 11 3 '##sys#setslot #f)
756(rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f)
757
758(rewrite '##sys#vector->list 11 1 'vector->list #t)
759(rewrite '##sys#list->vector 11 1 'list->vector #t)
760(rewrite '##sys#>= 11 2 '>= #t)
761(rewrite '##sys#= 11 2 '= #t)
762
763(rewrite 'gcd 12 '##sys#gcd #t 2)
764(rewrite 'lcm 12 '##sys#lcm #t 2)
765(rewrite 'identity 12 #f #t 1)
766
767(rewrite 'gcd 18 0)
768(rewrite 'lcm 18 1)
769(rewrite 'list 18 '())
770
771(rewrite 'argv 13 "C_get_argv" #t)
772
773(rewrite '* 16 2 "C_a_i_times" #t 4)    ; words-per-flonum
774(rewrite '+ 16 2 "C_a_i_plus" #t 4)     ; words-per-flonum
775(rewrite '- 16 2 "C_a_i_minus" #t 4)    ; words-per-flonum
776(rewrite '/ 16 2 "C_a_i_divide" #t 4)   ; words-per-flonum
777(rewrite '= 17 2 "C_i_nequalp")
778(rewrite '> 17 2 "C_i_greaterp")
779(rewrite '< 17 2 "C_i_lessp")
780(rewrite '>= 17 2 "C_i_greater_or_equalp")
781(rewrite '<= 17 2 "C_i_less_or_equalp")
782
783(rewrite '* 13 "C_times" #t)
784(rewrite '- 13 "C_minus" #t)
785(rewrite '+ 13 "C_plus" #t)
786(rewrite '/ 13 "C_divide" #t)
787(rewrite '= 13 "C_nequalp" #t)
788(rewrite '> 13 "C_greaterp" #t)
789(rewrite '< 13 "C_lessp" #t)
790(rewrite '>= 13 "C_greater_or_equal_p" #t)
791(rewrite '<= 13 "C_less_or_equal_p" #t)
792
793(rewrite 'exact->inexact 13 "C_exact_to_inexact" #t)
794(rewrite 'string->number 13 "C_string_to_number" #t)
795(rewrite 'number->string 13 "C_number_to_string" #t)
796(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t)
797(rewrite '##sys#floor 13 "C_flonum_floor" #t)
798(rewrite '##sys#ceiling 13 "C_flonum_ceiling" #t)
799(rewrite '##sys#truncate 13 "C_flonum_truncate" #t)
800(rewrite '##sys#round 13 "C_flonum_round" #t)
801(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t)
802(rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t)
803(rewrite 'return-to-host 13 "C_return_to_host" #t)
804(rewrite '##sys#context-switch 13 "C_context_switch" #t)
805(rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t)
806(rewrite '##sys#make-symbol 13 "C_make_symbol" #t)
807
808(rewrite 'even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")
809(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
810(rewrite 'add1 14 'fixnum 1 "C_fixnum_increase" "C_u_fixnum_increase")
811(rewrite 'sub1 14 'fixnum 1 "C_fixnum_decrease" "C_u_fixnum_decrease")
812(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")
813
814(rewrite 'even? 2 1 "C_i_evenp" #t #f)
815(rewrite 'even? 2 1 "C_u_i_evenp" #f #f)
816(rewrite 'odd? 2 1 "C_i_oddp" #t #f)
817(rewrite 'odd? 2 1 "C_u_i_oddp" #f #f)
818
819(rewrite 'floor 15 'flonum 'fixnum '##sys#floor #f)
820(rewrite 'ceiling 15 'flonum 'fixnum '##sys#ceiling #f)
821(rewrite 'truncate 15 'flonum 'fixnum '##sys#truncate #f)
822(rewrite 'round 15 'flonum 'fixnum '##sys#round #f)
823
824(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
825(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
826(rewrite 'list 16 #f "C_a_i_list" #t '(3))
827(rewrite '##sys#list 16 #f "C_a_i_list" #t '(3))
828(rewrite 'vector 16 #f "C_a_i_vector" #t #t)
829(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)
830(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t)
831(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
832
833(rewrite
834 '##sys#setslot 8
835 (lambda (db classargs cont callargs)
836   ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>)
837   ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)
838   (and (= (length callargs) 3)
839        (make-node 
840         '##core#call '(#t)
841         (list cont
842               (make-node
843                '##core#inline
844                (let ([val (third callargs)])
845                  (if (and (eq? 'quote (node-class val))
846                           (immediate? (first (node-parameters val))) ) 
847                      '("C_i_set_i_slot")
848                      '("C_i_setslot") ) )
849                callargs) ) ) ) ) )
850
851(rewrite 'fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus")
852(rewrite 'fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference")
853(rewrite 'fxshl 17 2 "C_fixnum_shift_left")
854(rewrite 'fxshr 17 2 "C_fixnum_shift_right")
855(rewrite 'fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate")
856(rewrite 'fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor")
857(rewrite 'fxand 17 2 "C_fixnum_and" "C_u_fixnum_and")
858(rewrite 'fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")
859
860(rewrite
861 'arithmetic-shift 8
862 (lambda (db classargs cont callargs)
863   ;; (arithmetic-shift <x> <-int>) -> (##core#inline "C_fixnum_shift_right" <x> -<int>)
864   ;; (arithmetic-shift <x> <+int>) -> (##core#inline "C_fixnum_shift_left" <x> <int>)
865   ;; _ -> (##core#inline "C_a_i_arithmetic_shift" <x> <y>)
866   ;; not in fixnum-mode: _ -> (##core#inline_allocate ("C_a_i_arithmetic_shift" words-per-flonum) <x> <y>)
867   (and (= 2 (length callargs))
868        (let ([val (second callargs)])
869          (make-node
870           '##core#call '(#t)
871           (list cont
872                 (or (and-let* ([(eq? 'quote (node-class val))]
873                                [(eq? number-type 'fixnum)]
874                                [n (first (node-parameters val))]
875                                [(and (fixnum? n) (not (big-fixnum? n)))] )
876                       (if (negative? n)
877                           (make-node 
878                            '##core#inline '("C_fixnum_shift_right")
879                            (list (first callargs) (qnode (- n))) )
880                           (make-node
881                            '##core#inline '("C_fixnum_shift_left")
882                            (list (first callargs) val) ) ) )
883                     (if (eq? number-type 'fixnum)
884                         (make-node '##core#inline '("C_i_fixnum_arithmetic_shift") callargs)
885                         (make-node '##core#inline_allocate (list "C_a_i_arithmetic_shift" words-per-flonum) 
886                                    callargs) ) ) ) ) ) ) ) )
887
888(rewrite '##sys#byte 17 2 "C_subbyte")
889(rewrite '##sys#setbyte 17 3 "C_setbyte")
890(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")
891(rewrite '##sys#peek-byte 17 2 "C_peek_byte")
892(rewrite 'pointer->object 17 2 "C_pointer_to_object")
893(rewrite '##sys#setislot 17 3 "C_i_set_i_slot")
894(rewrite '##sys#poke-integer 17 3 "C_poke_integer")
895(rewrite '##sys#poke-double 17 3 "C_poke_double")
896(rewrite '##sys#double->number 17 1 "C_double_to_number")
897(rewrite 'string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p")
898(rewrite 'string-ci=? 17 2 "C_i_string_ci_equal_p")
899(rewrite '##sys#fudge 17 1 "C_fudge")
900(rewrite '##sys#fits-in-int? 17 1 "C_fits_in_int_p")
901(rewrite '##sys#fits-in-unsigned-int? 17 1 "C_fits_in_unsigned_int_p")
902(rewrite '##sys#flonum-in-fixnum-range? 17 1 "C_flonum_in_fixnum_range_p")
903(rewrite '##sys#permanent? 17 1 "C_permanentp")
904(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp")
905(rewrite 'null-pointer? 17 1 "C_i_null_pointerp" "C_null_pointerp")
906(rewrite '##sys#immediate? 17 1 "C_immp")
907(rewrite 'locative->object 17 1 "C_i_locative_to_object")
908(rewrite 'locative-set! 17 2 "C_i_locative_set")
909(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp")
910(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")
911(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")
912(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")
913(rewrite '##sys#foreign-number-vector-argument 17 2 "C_i_foreign_number_vector_argumentp")
914(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")
915(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")
916(rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp")
917(rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp")
918(rewrite '##sys#direct-return 17 2 "C_direct_return")
919
920(rewrite 'blob-size 2 1 "C_block_size" #f #f)
921
922(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f)
923(rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f #f)
924(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f)
925(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f)
926
927(rewrite 'u32vector-ref 22 2 "C_a_i_u32vector_ref" #f words-per-flonum "C_u_i_u32vector_ref")
928(rewrite 's32vector-ref 22 2 "C_a_i_s32vector_ref" #f words-per-flonum "C_u_i_s32vector_ref")
929
930(rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f #f)
931(rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f #f)
932(rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f #f)
933(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f)
934(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f)
935(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f)
936
937(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f)
938(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f)
939(rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f #f)
940(rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f #f)
941(rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f #f)
942(rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f #f)
943(rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f #f)
944(rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f #f)
945
946(rewrite 'not-pair? 17 1 "C_i_not_pair_p")
947(rewrite 'atom? 17 1 "C_i_not_pair_p")
948(rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp")
949
950(rewrite 'u8vector->blob/shared 7 1 "C_slot" 1 #f)
951(rewrite 's8vector->blob/shared 7 1 "C_slot" 1 #f)
952(rewrite 'u16vector->blob/shared 7 1 "C_slot" 1 #f)
953(rewrite 's16vector->blob/shared 7 1 "C_slot" 1 #f)
954(rewrite 'u32vector->blob/shared 7 1 "C_slot" 1 #f)
955(rewrite 's32vector->blob/shared 7 1 "C_slot" 1 #f)
956(rewrite 'f32vector->blob/shared 7 1 "C_slot" 1 #f)
957(rewrite 'f64vector->blob/shared 7 1 "C_slot" 1 #f)
958
959(let ()
960  (define (rewrite-make-vector db classargs cont callargs)
961    ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>))
962    ;; - <n> should be less or equal to 32.
963    (let ([argc (length callargs)])
964      (and (pair? callargs)
965           (let ([n (first callargs)])
966             (and (eq? 'quote (node-class n))
967                  (let ([tmp (gensym)]
968                        [c (first (node-parameters n))] )
969                    (and (fixnum? c)
970                         (<= c 32)
971                         (let ([val (if (pair? (cdr callargs))
972                                        (second callargs)
973                                        (make-node '##core#undefined '() '()) ) ] )
974                           (make-node
975                            'let
976                            (list tmp)
977                            (list val
978                                  (make-node
979                                   '##core#call '(#t)
980                                   (list cont
981                                         (make-node
982                                          '##core#inline_allocate 
983                                          (list "C_a_i_vector" (add1 c))
984                                          (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
985  (rewrite 'make-vector 8 rewrite-make-vector)
986  (rewrite '##sys#make-vector 8 rewrite-make-vector) )
987
988(rewrite 'thread-specific 7 1 "C_slot" 10 #f)
989(rewrite 'thread-specific-set! 20 2 "C_i_setslot" 10 #f)
990
991(let ()
992  (define (rewrite-call/cc db classargs cont callargs)
993    ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)
994    (and (= 1 (length callargs))
995         (let ([val (first callargs)])
996           (and (eq? '##core#variable (node-class val))
997                (and-let* ([proc (get db (first (node-parameters val)) 'value)]
998                           [(eq? '##core#lambda (node-class proc))] )
999                  (let ([llist (third (node-parameters proc))])
1000                    (decompose-lambda-list 
1001                     llist
1002                     (lambda (vars argc rest)
1003                       (and (= argc 2)
1004                            (let ([var (or rest (second llist))])
1005                              (and (not (get db var 'references))
1006                                   (not (get db var 'assigned)) 
1007                                   (make-node
1008                                    '##core#call '(#t)
1009                                    (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
1010  (rewrite 'call-with-current-continuation 8 rewrite-call/cc)
1011  (rewrite 'call/cc 8 rewrite-call/cc) )
1012
1013(declare (hide setter-map))
1014
1015(define setter-map
1016  '((car . set-car!)
1017    (cdr . set-cdr!)
1018    (hash-table-ref . hash-table-set!)
1019    (block-ref . block-set!)
1020    (locative-ref . locative-set!)
1021    (u8vector-ref . u8vector-set!)
1022    (s8vector-ref . s8vector-set!)
1023    (u16vector-ref . u16vector-set!)
1024    (s16vector-ref . s16vector-set!)
1025    (u32vector-ref . u32vector-set!)
1026    (s32vector-ref . s32vector-set!)
1027    (f32vector-ref . f32vector-set!)
1028    (f64vector-ref . f64vector-set!)
1029    (pointer-u8-ref . pointer-u8-set!)
1030    (pointer-s8-ref . pointer-s8-set!)
1031    (pointer-u16-ref . pointer-u16-set!)
1032    (pointer-s16-ref . pointer-s16-set!)
1033    (pointer-u32-ref . pointer-u32-set!)
1034    (pointer-s32-ref . pointer-s32-set!)
1035    (pointer-f32-ref . pointer-f32-set!)
1036    (pointer-f64-ref . pointer-f64-set!)
1037    (string-ref . string-set!)
1038    (global-ref . global-set!)
1039    (vector-ref . vector-set!) ) )
1040
1041(rewrite
1042 '##sys#setter 8
1043 (lambda (db classargs cont callargs)
1044   ;; (setter <known-getter>) -> <known-setter>
1045   (and (= 1 (length callargs))
1046        (let ((arg (car callargs)))
1047          (and (eq? '##core#variable (node-class arg))
1048               (let ((sym (car (node-parameters arg))))
1049                 (and (intrinsic? sym)
1050                      (and-let* ((a (assq sym setter-map)))
1051                        (make-node
1052                         '##core#call '(#t)
1053                         (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) )
1054                               
1055(rewrite 'void 3 '##sys#undefined-value)
1056(rewrite '##sys#void 3 '##sys#undefined-value)
1057
1058(rewrite
1059 'any? 8
1060 (lambda (db classargs cont callargs) 
1061   (and (= 1 (length callargs))
1062        (let ((arg (car callargs)))
1063          (make-node
1064           '##core#call '(#t) 
1065           (list cont
1066                 (if (and (eq? '##core#variable (node-class arg))
1067                          (not (get db (car (node-parameters arg)) 'global)) )
1068                     (qnode #t)
1069                     (make-node 
1070                      '##core#inline '("C_anyp")
1071                      (list arg)) ) ) ) ) ) ) )
1072
1073(rewrite
1074 'bit-set? 8
1075 (lambda (db classargs cont callargs)
1076   (and (= 2 (length callargs))
1077        (make-node
1078         '##core#call '(#t)
1079         (list cont
1080               (make-node
1081                '##core#inline 
1082                (list (if (eq? number-type 'fixnum) "C_u_i_bit_setp" "C_i_bit_setp"))
1083                callargs) ) ) ) ) )
1084
1085(rewrite 'read-char 23 0 '##sys#read-char/port '##sys#standard-input)
1086(rewrite 'write-char 23 1 '##sys#write-char/port '##sys#standard-output)
1087(rewrite 'read-string 23 1 '##sys#read-string/port '##sys#standard-input)
1088(rewrite 'substring=? 23 2 '##sys#substring=? 0 0 #f)
1089(rewrite 'substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)
1090(rewrite 'substring-index 23 2 '##sys#substring-index 0)
1091(rewrite 'substring-index-ci 23 2 '##sys#substring-index-ci 0)
Note: See TracBrowser for help on using the repository browser.