source: project/chicken/branches/release/c-platform.scm @ 7276

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

merged trunk

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