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

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

merged scrutiny branch

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