source: project/chicken/branches/hygienic/c-platform.scm @ 11919

Last change on this file since 11919 was 11919, checked in by felix winkelmann, 13 years ago

case macro uses qualified version if eqv?

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