source: project/chicken/trunk/c-platform.scm @ 15799

Last change on this file since 15799 was 15799, checked in by felix winkelmann, 10 years ago

enabled compiler-syntax for map, better rewrites for add1/sub1; WARNING: not tested, yet

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