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

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

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