source: project/chicken/branches/inlining/c-platform.scm @ 15323

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

more intelligent inlining; standard-extension procedure in setup-api

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