source: project/chicken/branches/prerelease/c-platform.scm @ 15229

Last change on this file since 15229 was 15229, checked in by felix winkelmann, 11 years ago

(really) merged trunk changes till 15228 into prerelease branch

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