source: project/chicken/c-platform.scm @ 5358

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