~ chicken-core (master) /c-platform.scm
Trap1;;;; c-platform.scm - Platform specific parameters and definitions2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; 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 promote15; 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 EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (unit c-platform)30 (uses internal optimizer support compiler))3132(module chicken.compiler.c-platform33 (;; Batch compilation defaults34 default-declarations default-profiling-declarations default-units3536 ;; Compiler flags37 valid-compiler-options valid-compiler-options-with-argument3839 ;; For consumption by c-backend *only*40 target-include-file words-per-flonum)4142(import scheme43 chicken.base44 chicken.compiler.optimizer45 chicken.compiler.support46 chicken.compiler.core47 chicken.fixnum48 chicken.internal)49(import (only (scheme base) port?))5051(include "tweaks")52(include "mini-srfi-1.scm")5354;;; Parameters:5556(default-optimization-passes 3)5758(define default-declarations59 '((always-bound60 ##sys#standard-input ##sys#standard-output ##sys#standard-error61 ##sys#undefined-value)62 (bound-to-procedure63 ##sys#for-each ##sys#map ##sys#print ##sys#setter64 ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values65 ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#structure? ##sys#slot66 ##sys#allocate-vector ##sys#allocate-bytevector ##sys#list->vector ##sys#block-ref ##sys#block-set!67 ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument68 ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string69 ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string70 ##sys#foreign-block-argument ##sys#foreign-string-argument71 ##sys#foreign-symbol-argument72 ##sys#foreign-pointer-argument ##sys#call-with-current-continuation)))7374(define default-profiling-declarations75 '((##core#declare76 (uses profiler)77 (bound-to-procedure ##sys#profile-entry78 ##sys#profile-exit79 ##sys#register-profile-info80 ##sys#set-profile-info-vector!))))8182(define default-units '(library eval))8384(define words-per-flonum 4)85(define min-words-per-bignum 5)8687(eq-inline-operator "C_eqp")88(membership-test-operators89 '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")90 ("C_i_memv" . "C_i_eqvp") ) )91(membership-unfold-limit 20)92(define target-include-file "chicken.h")9394(define valid-compiler-options95 '(-help96 h help version verbose explicit-use97 no-trace no-warnings unsafe block98 check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info99 profile inline keep-shadowed-macros ignore-repository100 fixnum-arithmetic disable-interrupts optimize-leaf-routines101 compile-syntax tag-pointers accumulate-profile102 disable-stack-overflow-checks raw specialize103 emit-external-prototypes-first release local inline-global104 analyze-only dynamic static105 no-argc-checks no-procedure-checks no-parentheses-synonyms106 no-procedure-checks-for-toplevel-bindings107 no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax108 no-parentheses-synonyms r7rs-syntax emit-all-import-libraries109 strict-types lfa2 debug-info merge-reusable-closures merge-shareable-closures110 regenerate-import-libraries setup-mode111 module-registration no-module-registration))112113(define valid-compiler-options-with-argument114 '(debug link emit-link-file115 output-file include-path heap-size stack-size unit uses module116 keyword-style require-extension inline-limit profile-name117 prelude postlude prologue epilogue nursery extend feature no-feature118 unroll-limit119 emit-inline-file consult-inline-file120 emit-types-file consult-types-file121 emit-import-library))122123124;;; Standard and extended bindings:125126(set! default-standard-bindings127 (map (lambda (x) (symbol-append 'scheme# x))128 '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr129 cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar130 cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!131 null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port132 write-char newline write display append symbol->string for-each map char? char->integer133 integer->char eof-object? vector-length string-length string-ref string-set! vector-ref134 vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol135 number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact? exact-integer?136 max min quotient remainder modulo floor ceiling truncate round rationalize137 exact->inexact inexact->exact138 exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?139 char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?140 char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?141 string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?142 string-append string->list list->string vector? vector->list list->vector string read143 read-char substring string-fill! vector-copy! vector-fill! make-string make-vector open-input-file144 open-output-file call-with-input-file call-with-output-file close-input-port close-output-port145 values call-with-values vector procedure? memq memv member assq assv assoc list-tail146 list-ref abs char-ready? u8-ready? peek-char list->string string->list147 current-input-port current-output-port call/cc148 make-polar make-rectangular real-part imag-part149 load eval interaction-environment null-environment150 scheme-report-environment)))151152(define-constant +flonum-bindings+153 (map (lambda (x) (symbol-append 'chicken.flonum# x))154 '(fp/? fp+ fp- fp* fp/ fp> fp< fp= fp>= fp<= fpmin fpmax fpneg fpgcd fp*+155 fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos156 fpatan fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger?)))157158(define-constant +fixnum-bindings+159 (map (lambda (x) (symbol-append 'chicken.fixnum# x))160 '(fx* fx*? fx+ fx+? fx- fx-? fx/ fx/? fx< fx<= fx= fx> fx>= fxand161 fxeven? fxgcd fxior fxlen fxmax fxmin fxmod fxneg fxnot fxodd?162 fxrem fxshl fxshr fxxor)))163164(define-constant +extended-bindings+165 '(chicken.base#bignum? chicken.base#cplxnum? chicken.base#fixnum?166 chicken.base#flonum? chicken.base#ratnum?167 chicken.base#add1 chicken.base#sub1168 chicken.base#nan? chicken.base#finite? chicken.base#infinite?169 chicken.base#gensym170 chicken.base#void chicken.base#print chicken.base#print*171 chicken.base#error chicken.base#char-name172 chicken.base#current-error-port173 chicken.base#symbol-append chicken.base#foldl chicken.base#foldr174 chicken.base#setter chicken.base#getter-with-setter175 chicken.base#equal=?176 chicken.base#flush-output177178 chicken.base#weak-cons chicken.base#weak-pair? chicken.base#bwp-object?179180 chicken.base#identity chicken.base#o chicken.base#atom?181 chicken.base#alist-ref chicken.base#rassoc182183 chicken.bitwise#integer-length184 chicken.bitwise#bitwise-and chicken.bitwise#bitwise-not185 chicken.bitwise#bitwise-ior chicken.bitwise#bitwise-xor186 chicken.bitwise#arithmetic-shift chicken.bitwise#bit->boolean187188 chicken.bytevector#bytevector-length chicken.bytevector#bytevector=?189190 chicken.keyword#get-keyword191192 chicken.bytevector#bytevector? chicken.bytevector#bytevector-u8-set!193 chicken.bytevector#bytevector-u8-ref194195 chicken.number-vector#u8vector? chicken.number-vector#s8vector?196 chicken.number-vector#u16vector? chicken.number-vector#s16vector?197 chicken.number-vector#u32vector? chicken.number-vector#u64vector?198 chicken.number-vector#s32vector? chicken.number-vector#s64vector?199 chicken.number-vector#f32vector? chicken.number-vector#f64vector?200 chicken.number-vector#c64vector? chicken.number-vector#c128vector?201202 chicken.number-vector#u8vector-length chicken.number-vector#s8vector-length203 chicken.number-vector#u16vector-length chicken.number-vector#s16vector-length204 chicken.number-vector#u32vector-length chicken.number-vector#u64vector-length205 chicken.number-vector#s32vector-length chicken.number-vector#s64vector-length206 chicken.number-vector#f32vector-length chicken.number-vector#f64vector-length207 chicken.number-vector#c64vector-length chicken.number-vector#c128vector-length208209 chicken.number-vector#u8vector-ref chicken.number-vector#s8vector-ref210 chicken.number-vector#u16vector-ref chicken.number-vector#s16vector-ref211 chicken.number-vector#u32vector-ref chicken.number-vector#u64vector-ref212 chicken.number-vector#s32vector-ref chicken.number-vector#s64vector-ref213 chicken.number-vector#f32vector-ref chicken.number-vector#f64vector-ref214 chicken.number-vector#c64vector-ref chicken.number-vector#c128vector-ref215216 chicken.number-vector#u8vector-set! chicken.number-vector#s8vector-set!217 chicken.number-vector#u16vector-set! chicken.number-vector#s16vector-set!218 chicken.number-vector#u32vector-set! chicken.number-vector#u64vector-set!219 chicken.number-vector#s32vector-set! chicken.number-vector#s64vector-set!220 chicken.number-vector#f32vector-set! chicken.number-vector#f64vector-set!221 chicken.number-vector#c64vector-set! chicken.number-vector#c128vector-set!222223 chicken.number-vector#u16vector->bytevector/shared chicken.number-vector#s16vector->bytevector/shared224 chicken.number-vector#u32vector->bytevector/shared chicken.number-vector#s32vector->bytevector/shared225 chicken.number-vector#u64vector->bytevector/shared chicken.number-vector#s64vector->bytevector/shared226 chicken.number-vector#f32vector->bytevector/shared chicken.number-vector#f64vector->bytevector/shared227 chicken.number-vector#bytevector->u16vector/shared chicken.number-vector#bytevector->s16vector/shared228 chicken.number-vector#bytevector->u32vector/shared chicken.number-vector#bytevector->s32vector/shared229 chicken.number-vector#bytevector->u64vector/shared chicken.number-vector#bytevector->s64vector/shared230 chicken.number-vector#bytevector->f32vector/shared chicken.number-vector#bytevector->f64vector/shared231 chicken.number-vector#bytevector->c64vector/shared chicken.number-vector#bytevector->c128vector/shared232233 chicken.memory.representation#number-of-slots234 chicken.memory.representation#make-record-instance235 chicken.memory.representation#block-ref236 chicken.memory.representation#block-set!237238 chicken.locative#locative-ref chicken.locative#locative-set!239 chicken.locative#locative->object chicken.locative#locative?240 chicken.locative#locative-index241242 chicken.memory#pointer+ chicken.memory#pointer=?243 chicken.memory#address->pointer chicken.memory#pointer->address244 chicken.memory#pointer->object chicken.memory#object->pointer245 chicken.memory#pointer-u8-ref chicken.memory#pointer-s8-ref246 chicken.memory#pointer-u16-ref chicken.memory#pointer-s16-ref247 chicken.memory#pointer-u32-ref chicken.memory#pointer-s32-ref248 chicken.memory#pointer-f32-ref chicken.memory#pointer-f64-ref249 chicken.memory#pointer-u8-set! chicken.memory#pointer-s8-set!250 chicken.memory#pointer-u16-set! chicken.memory#pointer-s16-set!251 chicken.memory#pointer-u32-set! chicken.memory#pointer-s32-set!252 chicken.memory#pointer-f32-set! chicken.memory#pointer-f64-set!253254 chicken.string#substring-index chicken.string#substring-index-ci255 chicken.string#substring=? chicken.string#substring-ci=?256257 chicken.io#read-string258259 chicken.format#format260 chicken.format#printf chicken.format#sprintf chicken.format#fprintf))261262(set! default-extended-bindings263 (append +fixnum-bindings+ +flonum-bindings+ +extended-bindings+))264265(set! internal-bindings266 '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set! ##sys#/-2267 ##sys#call-with-current-continuation ##sys#size ##sys#byte268 ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure269 ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string270 ##sys#check-symbol ##sys#check-boolean ##sys#check-locative271 ##sys#check-fixnum ##sys#check-range ##sys#check-range/internal272 ##sys#check-port ##sys#check-input-port ##sys#check-output-port273 ##sys#check-open-port ##sys#check-bytevector ##sys#signal-hook274 ##sys#check-char ##sys#check-vector ##sys#check-bytevector ##sys#list ##sys#cons275 ##sys#call-with-values ##sys#flonum-in-fixnum-range?276 ##sys#immediate? ##sys#context-switch277 ##sys#make-structure ##sys#apply ##sys#apply-values278 chicken.continuation#continuation-graft279 ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?280 ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#get-keyword281 ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument282 ##sys#foreign-block-argument ##sys#foreign-struct-wrapper-argument283 ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void284 ##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument285 ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double286 ##sys#intern-symbol ##sys#intern-keyword ##sys#null-pointer? ##sys#peek-byte287 ##sys#foreign-symbol-argument ##sys#buffer->string!288 ##sys#symbol->string/shared ##sys#buffer->string ##sys#string->symbol-name289 ##sys#bytevector->list ##sys#list->bytevector ##sys#make-bytevector290 ##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd))291292(for-each293 (cut mark-variable <> '##compiler#pure '#t)294 '(##sys#slot ##sys#block-ref ##sys#size ##sys#byte295 ##sys#pointer? ##sys#generic-structure? ##sys#immediate?296 ##sys#bytevector? ##sys#pair? ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?297 ##sys#get-keyword ; ok it isn't, but this is only used for ext. llists298 ##sys#void ##sys#permanent?))299300301;;; Rewriting-definitions for this platform:302303(let ()304 ;; (add1 <x>) -> (##core#inline "C_fixnum_increase" <x>) [fixnum-mode]305 ;; (add1 <x>) -> (##core#inline "C_u_fixnum_increase" <x>) [fixnum-mode + unsafe]306 ;; (add1 <x>) -> (##core#inline_allocate ("C_s_a_i_plus" 36) <x> 1)307 ;; (sub1 <x>) -> (##core#inline "C_fixnum_decrease" <x>) [fixnum-mode]308 ;; (sub1 <x>) -> (##core#inline "C_u_fixnum_decrease" <x>) [fixnum-mode + unsafe]309 ;; (sub1 <x>) -> (##core#inline_allocate ("C_s_a_i_minus" 36) <x> 1)310 (define ((op1 fiop ufiop aiop) db classargs cont callargs)311 (and (= (length callargs) 1)312 (make-node313 '##core#call (list #t)314 (list315 cont316 (if (eq? 'fixnum number-type)317 (make-node '##core#inline (list (if unsafe ufiop fiop)) callargs)318 (make-node319 '##core#inline_allocate (list aiop 36)320 (list (car callargs) (qnode 1))))))))321 (rewrite 'chicken.base#add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_s_a_i_plus"))322 (rewrite 'chicken.base#sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_s_a_i_minus")))323324(let ()325 (define (eqv?-id db classargs cont callargs)326 ;; (eqv? <var> <var>) -> (quote #t) [two identical objects]327 ;; (eqv? ...) -> (##core#inline "C_eqp" ...)328 ;; [one argument is a constant and either immediate or not a number]329 (and (= (length callargs) 2)330 (let ((arg1 (first callargs))331 (arg2 (second callargs)) )332 (or (and (eq? '##core#variable (node-class arg1))333 (eq? '##core#variable (node-class arg2))334 (equal? (node-parameters arg1) (node-parameters arg2))335 (make-node '##core#call (list #t) (list cont (qnode #t))) )336 (and (or (and (eq? 'quote (node-class arg1))337 (let ((p1 (first (node-parameters arg1))))338 (or (immediate? p1) (not (number? p1)))) )339 (and (eq? 'quote (node-class arg2))340 (let ((p2 (first (node-parameters arg2))))341 (or (immediate? p2) (not (number? p2)))) ) )342 (make-node343 '##core#call (list #t)344 (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )345 (rewrite 'scheme#eqv? 8 eqv?-id)346 (rewrite '##sys#eqv? 8 eqv?-id))347348(rewrite349 'scheme#equal? 8350 (lambda (db classargs cont callargs)351 ;; (equal? <var> <var>) -> (quote #t)352 ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol]353 ;; (equal? ...) -> (##core#inline "C_i_equalp" ...)354 (and (= (length callargs) 2)355 (let ([arg1 (first callargs)]356 [arg2 (second callargs)] )357 (or (and (eq? '##core#variable (node-class arg1))358 (eq? '##core#variable (node-class arg2))359 (equal? (node-parameters arg1) (node-parameters arg2))360 (make-node '##core#call (list #t) (list cont (qnode #t))) )361 (and (or (and (eq? 'quote (node-class arg1))362 (let ([f (first (node-parameters arg1))])363 (or (immediate? f) (symbol? f)) ) )364 (and (eq? 'quote (node-class arg2))365 (let ([f (first (node-parameters arg2))])366 (or (immediate? f) (symbol? f)) ) ) )367 (make-node368 '##core#call (list #t)369 (list cont (make-node '##core#inline '("C_eqp") callargs)) ) )370 (make-node371 '##core#call (list #t)372 (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )373374(let ()375 (define (rewrite-apply db classargs cont callargs)376 ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...)377 ;; (apply ...) -> ((##core#proc "C_apply") ...)378 ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst)379 ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst)380 (and (pair? callargs)381 (let ([lastarg (last callargs)]382 [proc (car callargs)] )383 (if (eq? 'quote (node-class lastarg))384 (make-node385 '##core#call (list #f)386 (cons* (first callargs)387 cont388 (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )389 (or (and (eq? '##core#variable (node-class proc))390 (= 2 (length callargs))391 (let ([name (car (node-parameters proc))])392 (and (memq name '(values ##sys#values))393 (intrinsic? name)394 (make-node395 '##core#call (list #t)396 (list (make-node '##core#proc '("C_apply_values" #t) '())397 cont398 (cadr callargs) ) ) ) ) )399 (make-node400 '##core#call (list #t)401 (cons* (make-node '##core#proc '("C_apply" #t) '())402 cont callargs) ) ) ) ) ) )403 (rewrite 'scheme#apply 8 rewrite-apply)404 (rewrite '##sys#apply 8 rewrite-apply) )405406(let ()407 (define (rewrite-c..r op iop1 iop2)408 (rewrite409 op 8410 (lambda (db classargs cont callargs)411 ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe]412 ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe]413 (and (= (length callargs) 1)414 (call-with-current-continuation415 (lambda (return)416 (let ((arg (first callargs)))417 (make-node418 '##core#call (list #t)419 (list420 cont421 (cond [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]422 [iop1 (make-node '##core#inline (list iop1) callargs)]423 [else (return #f)] ) ) ) ) ) ) ) ) ) )424425 (rewrite-c..r 'scheme#car "C_i_car" "C_u_i_car")426 (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car")427 (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr")428 (rewrite-c..r 'scheme#cadr "C_i_cadr" "C_u_i_cadr")429 (rewrite-c..r 'scheme#caddr "C_i_caddr" "C_u_i_caddr")430 (rewrite-c..r 'scheme#cadddr "C_i_cadddr" "C_u_i_cadddr") )431432(let ((rvalues433 (lambda (db classargs cont callargs)434 ;; (values <x>) -> <x>435 (and (= (length callargs) 1)436 (make-node '##core#call (list #t) (cons cont callargs) ) ) ) ) )437 (rewrite 'scheme#values 8 rvalues)438 (rewrite '##sys#values 8 rvalues) )439440(let ()441 (define (rewrite-c-w-v db classargs cont callargs)442 ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) [<var2> <k0> r]))) [<var1> k])443 ;; - if <var2> is a known lambda of a single argument444 (and (= 2 (length callargs))445 (let ((arg1 (car callargs))446 (arg2 (cadr callargs)) )447 (and (eq? '##core#variable (node-class arg1)) ; probably not needed448 (eq? '##core#variable (node-class arg2))449 (and-let* ((sym (car (node-parameters arg2)))450 (val (db-get db sym 'value)) )451 (and (eq? '##core#lambda (node-class val))452 (let ((llist (third (node-parameters val))))453 (and (list? llist)454 (= 2 (length llist))455 (let ((tmp (gensym))456 (tmpk (gensym 'r)) )457 (debugging 'o "removing single-valued `call-with-values'" (node-parameters val))458 (make-node459 'let (list tmp)460 (list (make-node461 '##core#lambda462 (list (gensym 'f_) #f (list tmpk) 0)463 (list (make-node464 '##core#call (list #t)465 (list arg2 cont (varnode tmpk)) ) ) )466 (make-node467 '##core#call (list #t)468 (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )469 (rewrite 'scheme#call-with-values 8 rewrite-c-w-v)470 (rewrite '##sys#call-with-values 8 rewrite-c-w-v) )471472(rewrite 'scheme#values 13 #f "C_values" #t)473(rewrite '##sys#values 13 #f "C_values" #t)474(rewrite 'scheme#call-with-values 13 2 "C_u_call_with_values" #f)475(rewrite 'scheme#call-with-values 13 2 "C_call_with_values" #t)476(rewrite '##sys#call-with-values 13 2 "C_u_call_with_values" #f)477(rewrite '##sys#call-with-values 13 2 "C_call_with_values" #t)478(rewrite 'chicken.continuation#continuation-graft 13 2 "C_continuation_graft" #t)479480(rewrite 'scheme#caar 2 1 "C_u_i_caar" #f)481(rewrite 'scheme#cdar 2 1 "C_u_i_cdar" #f)482(rewrite 'scheme#cddr 2 1 "C_u_i_cddr" #f)483(rewrite 'scheme#caaar 2 1 "C_u_i_caaar" #f)484(rewrite 'scheme#cadar 2 1 "C_u_i_cadar" #f)485(rewrite 'scheme#caddr 2 1 "C_u_i_caddr" #f)486(rewrite 'scheme#cdaar 2 1 "C_u_i_cdaar" #f)487(rewrite 'scheme#cdadr 2 1 "C_u_i_cdadr" #f)488(rewrite 'scheme#cddar 2 1 "C_u_i_cddar" #f)489(rewrite 'scheme#cdddr 2 1 "C_u_i_cdddr" #f)490(rewrite 'scheme#caaaar 2 1 "C_u_i_caaaar" #f)491(rewrite 'scheme#caadar 2 1 "C_u_i_caadar" #f)492(rewrite 'scheme#caaddr 2 1 "C_u_i_caaddr" #f)493(rewrite 'scheme#cadaar 2 1 "C_u_i_cadaar" #f)494(rewrite 'scheme#cadadr 2 1 "C_u_i_cadadr" #f)495(rewrite 'scheme#caddar 2 1 "C_u_i_caddar" #f)496(rewrite 'scheme#cadddr 2 1 "C_u_i_cadddr" #f)497(rewrite 'scheme#cdaaar 2 1 "C_u_i_cdaaar" #f)498(rewrite 'scheme#cdaadr 2 1 "C_u_i_cdaadr" #f)499(rewrite 'scheme#cdadar 2 1 "C_u_i_cdadar" #f)500(rewrite 'scheme#cdaddr 2 1 "C_u_i_cdaddr" #f)501(rewrite 'scheme#cddaar 2 1 "C_u_i_cddaar" #f)502(rewrite 'scheme#cddadr 2 1 "C_u_i_cddadr" #f)503(rewrite 'scheme#cdddar 2 1 "C_u_i_cdddar" #f)504(rewrite 'scheme#cddddr 2 1 "C_u_i_cddddr" #f)505506(rewrite 'scheme#caar 2 1 "C_i_caar" #t)507(rewrite 'scheme#cdar 2 1 "C_i_cdar" #t)508(rewrite 'scheme#cddr 2 1 "C_i_cddr" #t)509(rewrite 'scheme#cdddr 2 1 "C_i_cdddr" #t)510(rewrite 'scheme#cddddr 2 1 "C_i_cddddr" #t)511512(rewrite 'scheme#cdr 2 1 "C_u_i_cdr" #f)513(rewrite 'scheme#cdr 2 1 "C_i_cdr" #t)514515(rewrite 'scheme#eq? 1 2 "C_eqp")516(rewrite '##sys#eq? 1 2 "C_eqp")517(rewrite 'scheme#eqv? 1 2 "C_i_eqvp")518(rewrite '##sys#eqv? 1 2 "C_i_eqvp")519520(rewrite 'scheme#list-ref 2 2 "C_u_i_list_ref" #f)521(rewrite 'scheme#list-ref 2 2 "C_i_list_ref" #t)522(rewrite 'scheme#null? 2 1 "C_i_nullp" #t)523(rewrite '##sys#null? 2 1 "C_i_nullp" #t)524(rewrite 'scheme#length 2 1 "C_i_length" #t)525(rewrite 'scheme#not 2 1 "C_i_not"#t )526(rewrite 'scheme#char? 2 1 "C_charp" #t)527(rewrite 'scheme#string? 2 1 "C_i_stringp" #t)528(rewrite 'chicken.locative#locative? 2 1 "C_i_locativep" #t)529(rewrite 'scheme#symbol? 2 1 "C_i_symbolp" #t)530(rewrite 'scheme#vector? 2 1 "C_i_vectorp" #t)531(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t)532(rewrite 'chicken.number-vector#u8vector? 2 1 "C_i_bytevectorp" #t)533(rewrite 'chicken.number-vector#s8vector? 2 1 "C_i_s8vectorp" #t)534(rewrite 'chicken.number-vector#u16vector? 2 1 "C_i_u16vectorp" #t)535(rewrite 'chicken.number-vector#s16vector? 2 1 "C_i_s16vectorp" #t)536(rewrite 'chicken.number-vector#u32vector? 2 1 "C_i_u32vectorp" #t)537(rewrite 'chicken.number-vector#s32vector? 2 1 "C_i_s32vectorp" #t)538(rewrite 'chicken.number-vector#u64vector? 2 1 "C_i_u64vectorp" #t)539(rewrite 'chicken.number-vector#s64vector? 2 1 "C_i_s64vectorp" #t)540(rewrite 'chicken.number-vector#f32vector? 2 1 "C_i_f32vectorp" #t)541(rewrite 'chicken.number-vector#f64vector? 2 1 "C_i_f64vectorp" #t)542(rewrite 'chicken.bytevector#bytevector? 2 1 "C_i_bytevectorp" #t)543(rewrite 'scheme#pair? 2 1 "C_i_pairp" #t)544(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)545(rewrite 'chicken.base#weak-pair? 2 1 "C_i_weak_pairp" #t)546(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t)547(rewrite 'scheme#port? 2 1 "C_i_portp" #t)548(rewrite 'scheme#boolean? 2 1 "C_booleanp" #t)549(rewrite 'scheme#number? 2 1 "C_i_numberp" #t)550(rewrite 'scheme#complex? 2 1 "C_i_numberp" #t)551(rewrite 'scheme#rational? 2 1 "C_i_rationalp" #t)552(rewrite 'scheme#real? 2 1 "C_i_realp" #t)553(rewrite 'scheme#integer? 2 1 "C_i_integerp" #t)554(rewrite 'scheme#exact-integer? 2 1 "C_i_exact_integerp" #t)555(rewrite 'chicken.base#flonum? 2 1 "C_i_flonump" #t)556(rewrite 'chicken.base#fixnum? 2 1 "C_fixnump" #t)557(rewrite 'chicken.base#bignum? 2 1 "C_i_bignump" #t)558(rewrite 'chicken.base#cplxnum? 2 1 "C_i_cplxnump" #t)559(rewrite 'chicken.base#ratnum? 2 1 "C_i_ratnump" #t)560(rewrite 'chicken.base#nan? 2 1 "C_i_nanp" #f)561(rewrite 'chicken.base#finite? 2 1 "C_i_finitep" #f)562(rewrite 'chicken.base#infinite? 2 1 "C_i_infinitep" #f)563(rewrite 'chicken.flonum#fpinteger? 2 1 "C_u_i_fpintegerp" #f)564(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t)565(rewrite 'pointer? 2 1 "C_i_safe_pointerp" #t)566(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t)567(rewrite 'scheme#exact? 2 1 "C_i_exactp" #t)568(rewrite 'scheme#exact? 2 1 "C_u_i_exactp" #f)569(rewrite 'scheme#inexact? 2 1 "C_i_inexactp" #t)570(rewrite 'scheme#inexact? 2 1 "C_u_i_inexactp" #f)571(rewrite 'scheme#list? 2 1 "C_i_listp" #t)572(rewrite 'scheme#eof-object? 2 1 "C_eofp" #t)573(rewrite 'scheme#string-ref 2 2 "C_utf_subchar" #f)574(rewrite 'chicken.base#bwp-object? 2 1 "C_bwpp" #t)575(rewrite 'scheme#string-ref 2 2 "C_i_string_ref" #t)576(rewrite 'scheme#string-set! 2 3 "C_utf_setsubchar" #f)577(rewrite 'scheme#string-set! 2 3 "C_i_string_set" #t)578(rewrite 'scheme#vector-ref 2 2 "C_slot" #f)579(rewrite 'scheme#vector-ref 2 2 "C_i_vector_ref" #t)580(rewrite 'scheme#char=? 2 2 "C_u_i_char_equalp" #f)581(rewrite 'scheme#char=? 2 2 "C_i_char_equalp" #t)582(rewrite 'scheme#char>? 2 2 "C_u_i_char_greaterp" #f)583(rewrite 'scheme#char>? 2 2 "C_i_char_greaterp" #t)584(rewrite 'scheme#char<? 2 2 "C_u_i_char_lessp" #f)585(rewrite 'scheme#char<? 2 2 "C_i_char_lessp" #t)586(rewrite 'scheme#char>=? 2 2 "C_u_i_char_greater_or_equal_p" #f)587(rewrite 'scheme#char>=? 2 2 "C_i_char_greater_or_equal_p" #t)588(rewrite 'scheme#char<=? 2 2 "C_u_i_char_less_or_equal_p" #f)589(rewrite 'scheme#char<=? 2 2 "C_i_char_less_or_equal_p" #t)590(rewrite '##sys#slot 2 2 "C_slot" #t) ; consider as safe, the primitive is unsafe anyway.591(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t) ;XXX must be safe for pattern matcher (anymore?)592(rewrite '##sys#size 2 1 "C_block_size" #t)593(rewrite 'chicken.fixnum#fxnot 2 1 "C_fixnum_not" #t)594(rewrite 'chicken.fixnum#fx* 2 2 "C_fixnum_times" #t)595(rewrite 'chicken.fixnum#fx+? 2 2 "C_i_o_fixnum_plus" #t)596(rewrite 'chicken.fixnum#fx-? 2 2 "C_i_o_fixnum_difference" #t)597(rewrite 'chicken.fixnum#fx*? 2 2 "C_i_o_fixnum_times" #t)598(rewrite 'chicken.fixnum#fx/? 2 2 "C_i_o_fixnum_quotient" #t)599(rewrite 'chicken.fixnum#fx= 2 2 "C_eqp" #t)600(rewrite 'chicken.fixnum#fx> 2 2 "C_fixnum_greaterp" #t)601(rewrite 'chicken.fixnum#fx< 2 2 "C_fixnum_lessp" #t)602(rewrite 'chicken.fixnum#fx>= 2 2 "C_fixnum_greater_or_equal_p" #t)603(rewrite 'chicken.fixnum#fx<= 2 2 "C_fixnum_less_or_equal_p" #t)604(rewrite 'chicken.flonum#fp= 2 2 "C_flonum_equalp" #f)605(rewrite 'chicken.flonum#fp> 2 2 "C_flonum_greaterp" #f)606(rewrite 'chicken.flonum#fp< 2 2 "C_flonum_lessp" #f)607(rewrite 'chicken.flonum#fp>= 2 2 "C_flonum_greater_or_equal_p" #f)608(rewrite 'chicken.flonum#fp<= 2 2 "C_flonum_less_or_equal_p" #f)609(rewrite 'chicken.fixnum#fxmax 2 2 "C_i_fixnum_max" #t)610(rewrite 'chicken.fixnum#fxmin 2 2 "C_i_fixnum_min" #t)611(rewrite 'chicken.flonum#fpmax 2 2 "C_i_flonum_max" #f)612(rewrite 'chicken.flonum#fpmin 2 2 "C_i_flonum_min" #f)613(rewrite 'chicken.fixnum#fxgcd 2 2 "C_i_fixnum_gcd" #t)614(rewrite 'chicken.fixnum#fxlen 2 1 "C_i_fixnum_length" #t)615(rewrite 'scheme#char-numeric? 2 1 "C_u_i_char_numericp" #t)616(rewrite 'scheme#char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)617(rewrite 'scheme#char-whitespace? 2 1 "C_u_i_char_whitespacep" #t)618(rewrite 'scheme#char-upper-case? 2 1 "C_u_i_char_upper_casep" #t)619(rewrite 'scheme#char-lower-case? 2 1 "C_u_i_char_lower_casep" #t)620(rewrite 'scheme#char-upcase 2 1 "C_u_i_char_upcase" #t)621(rewrite 'scheme#char-downcase 2 1 "C_u_i_char_downcase" #t)622(rewrite 'scheme#list-tail 2 2 "C_i_list_tail" #t)623(rewrite '##sys#structure? 2 2 "C_i_structurep" #t)624(rewrite '##sys#bytevector? 2 1 "C_bytevectorp" #t)625(rewrite 'chicken.memory.representation#block-ref 2 2 "C_slot" #f) ; ok to be unsafe, lolevel is anyway626(rewrite 'chicken.memory.representation#number-of-slots 2 1 "C_block_size" #f)627628(rewrite 'scheme#assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")629(rewrite 'scheme#assv 2 2 "C_i_assv" #t)630(rewrite 'scheme#memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")631(rewrite 'scheme#memv 2 2 "C_i_memv" #t)632(rewrite 'scheme#assq 17 2 "C_i_assq" "C_u_i_assq")633(rewrite 'scheme#memq 17 2 "C_i_memq" "C_u_i_memq")634(rewrite 'scheme#assoc 2 2 "C_i_assoc" #t)635(rewrite 'scheme#member 2 2 "C_i_member" #t)636637(rewrite 'scheme#set-car! 4 '##sys#setslot 0)638(rewrite 'scheme#set-cdr! 4 '##sys#setslot 1)639(rewrite 'scheme#set-car! 17 2 "C_i_set_car" "C_u_i_set_car")640(rewrite 'scheme#set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr")641642(rewrite 'scheme#abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")643644(rewrite 'chicken.bitwise#bitwise-and 19)645(rewrite 'chicken.bitwise#bitwise-xor 19)646(rewrite 'chicken.bitwise#bitwise-ior 19)647648(rewrite 'chicken.bitwise#bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_s_a_i_bitwise_and" 5)649(rewrite 'chicken.bitwise#bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_s_a_i_bitwise_xor" 5)650(rewrite 'chicken.bitwise#bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_s_a_i_bitwise_ior" 5)651652(rewrite 'chicken.bitwise#bitwise-not 22 1 "C_s_a_i_bitwise_not" #t 5 "C_fixnum_not")653654(rewrite 'chicken.flonum#fp+ 16 2 "C_a_i_flonum_plus" #f words-per-flonum)655(rewrite 'chicken.flonum#fp- 16 2 "C_a_i_flonum_difference" #f words-per-flonum)656(rewrite 'chicken.flonum#fp* 16 2 "C_a_i_flonum_times" #f words-per-flonum)657(rewrite 'chicken.flonum#fp/ 16 2 "C_a_i_flonum_quotient" #f words-per-flonum)658(rewrite 'chicken.flonum#fp/? 16 2 "C_a_i_flonum_quotient_checked" #f words-per-flonum)659(rewrite 'chicken.flonum#fpneg 16 1 "C_a_i_flonum_negate" #f words-per-flonum)660(rewrite 'chicken.flonum#fpgcd 16 2 "C_a_i_flonum_gcd" #f words-per-flonum)661(rewrite 'chicken.flonum#fp*+ 16 3 "C_a_i_flonum_multiply_add" #f words-per-flonum)662663(rewrite 'scheme#zero? 5 "C_eqp" 0 'fixnum)664(rewrite 'scheme#zero? 2 1 "C_u_i_zerop2" #f)665(rewrite 'scheme#zero? 2 1 "C_i_zerop" #t)666(rewrite 'scheme#positive? 5 "C_fixnum_greaterp" 0 'fixnum)667(rewrite 'scheme#positive? 5 "C_flonum_greaterp" 0 'flonum)668(rewrite 'scheme#positive? 2 1 "C_i_positivep" #t)669(rewrite 'scheme#negative? 5 "C_fixnum_lessp" 0 'fixnum)670(rewrite 'scheme#negative? 5 "C_flonum_lessp" 0 'flonum)671(rewrite 'scheme#negative? 2 1 "C_i_negativep" #t)672673(rewrite 'scheme#vector-length 6 "C_fix" "C_header_size" #f)674(rewrite 'scheme#char->integer 6 "C_fix" "C_character_code" #t)675(rewrite 'scheme#integer->char 6 "C_make_character" "C_unfix" #f)676677(rewrite 'scheme#vector-length 2 1 "C_i_vector_length" #t)678(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t)679(rewrite 'scheme#string-length 2 1 "C_i_string_length" #t)680681(rewrite '##sys#check-fixnum 2 1 "C_i_check_fixnum" #t)682(rewrite '##sys#check-number 2 1 "C_i_check_number" #t)683(rewrite '##sys#check-list 2 1 "C_i_check_list" #t)684(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t)685(rewrite '##sys#check-boolean 2 1 "C_i_check_boolean" #t)686(rewrite '##sys#check-locative 2 1 "C_i_check_locative" #t)687(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t)688(rewrite '##sys#check-string 2 1 "C_i_check_string" #t)689(rewrite '##sys#check-bytevector 2 1 "C_i_check_bytevector" #t)690(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t)691(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t)692(rewrite '##sys#check-char 2 1 "C_i_check_char" #t)693(rewrite '##sys#check-fixnum 2 2 "C_i_check_fixnum_2" #t)694(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t)695(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t)696(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t)697(rewrite '##sys#check-boolean 2 2 "C_i_check_boolean_2" #t)698(rewrite '##sys#check-locative 2 2 "C_i_check_locative_2" #t)699(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t)700(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t)701(rewrite '##sys#check-bytevector 2 2 "C_i_check_bytevector_2" #t)702(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t)703(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t)704(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t)705(rewrite '##sys#check-range 2 3 "C_i_check_range" #t)706(rewrite '##sys#check-range 2 4 "C_i_check_range_2" #t)707(rewrite '##sys#check-range/including 2 3 "C_i_check_range_including" #t)708(rewrite '##sys#check-range/including 2 4 "C_i_check_range_including_2" #t)709710(rewrite 'scheme#= 9 "C_eqp" "C_i_equalp" #t #t)711(rewrite 'scheme#> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f)712(rewrite 'scheme#< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f)713(rewrite 'scheme#>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f)714(rewrite 'scheme#<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f)715716(rewrite 'setter 11 1 '##sys#setter #t)717(rewrite 'scheme#for-each 11 2 '##sys#for-each #t)718(rewrite 'scheme#map 11 2 '##sys#map #t)719(rewrite 'chicken.memory.representation#block-set! 11 3 '##sys#setslot #t)720(rewrite '##sys#block-set! 11 3 '##sys#setslot #f)721(rewrite 'chicken.memory.representation#make-record-instance 11 #f '##sys#make-structure #f)722(rewrite 'scheme#substring 11 3 '##sys#substring #f)723(rewrite 'scheme#string-append 11 2 '##sys#string-append #f)724(rewrite 'scheme#string->list 11 1 '##sys#string->list #t)725(rewrite 'scheme#list->string 11 1 '##sys#list->string #t)726727(rewrite 'scheme#vector-set! 11 3 '##sys#setslot #f)728(rewrite 'scheme#vector-set! 2 3 "C_i_vector_set" #t)729730(rewrite 'scheme#gcd 12 '##sys#gcd #t 2)731(rewrite 'scheme#lcm 12 '##sys#lcm #t 2)732(rewrite 'chicken.base#identity 12 #f #t 1)733734(rewrite 'scheme#gcd 19)735(rewrite 'scheme#lcm 19)736737(rewrite 'scheme#gcd 18 0)738(rewrite 'scheme#lcm 18 1)739(rewrite 'scheme#list 18 '())740741(rewrite742 'scheme#* 8743 (lambda (db classargs cont callargs)744 ;; (*) -> 1745 ;; (* <x>) -> <x>746 ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]747 ;; - Remove "1" from arguments.748 ;; - Replace multiplications with 2 by shift left. [fixnum-mode]749 (let ((callargs750 (filter751 (lambda (x)752 (not (and (eq? 'quote (node-class x))753 (eq? 1 (first (node-parameters x))) ) ) )754 callargs) ) )755 (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode 0))))756 ((null? (cdr callargs))757 (make-node '##core#call (list #t) (list cont (first callargs))) )758 ((eq? number-type 'fixnum)759 (make-node760 '##core#call (list #t)761 (list762 cont763 (fold-inner764 (lambda (x y)765 (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))766 (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))767 (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )768 callargs) ) ) )769 (else #f) ) ) ) )770771(rewrite772 'scheme#+ 8773 (lambda (db classargs cont callargs)774 ;; (+ <x>) -> <x>775 ;; (+ <x1> ...) -> (##core#inline "C_fixnum_plus" <x1> (##core#inline "C_fixnum_plus" ...)) [fixnum-mode]776 ;; (+ <x1> ...) -> (##core#inline "C_u_fixnum_plus" <x1> (##core#inline "C_u_fixnum_plus" ...))777 ;; [fixnum-mode + unsafe]778 ;; - Remove "0" from arguments, if more than 1.779 (cond ((or (null? callargs) (not (eq? number-type 'fixnum))) #f)780 ((null? (cdr callargs))781 (make-node782 '##core#call (list #t)783 (list cont784 (make-node '##core#inline785 (if unsafe '("C_u_fixnum_plus") '("C_fixnum_plus"))786 callargs)) ) )787 (else788 (let ((callargs789 (cons (car callargs)790 (filter791 (lambda (x)792 (not (and (eq? 'quote (node-class x))793 (zero? (first (node-parameters x))) ) ) )794 (cdr callargs) ) ) ) )795 (and (>= (length callargs) 2)796 (make-node797 '##core#call (list #t)798 (list799 cont800 (fold-inner801 (lambda (x y)802 (make-node '##core#inline803 (if unsafe '("C_u_fixnum_plus") '("C_fixnum_plus"))804 (list x y) ) )805 callargs) ) ) ) ) ) ) ) )806807(rewrite808 'scheme#- 8809 (lambda (db classargs cont callargs)810 ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>) [fixnum-mode]811 ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>) [fixnum-mode + unsafe]812 ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]813 ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...))814 ;; [fixnum-mode + unsafe]815 ;; - Remove "0" from arguments, if more than 1.816 (cond ((or (null? callargs) (not (eq? number-type 'fixnum))) #f)817 ((null? (cdr callargs))818 (make-node819 '##core#call (list #t)820 (list cont821 (make-node '##core#inline822 (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))823 callargs)) ) )824 (else825 (let ((callargs826 (cons (car callargs)827 (filter828 (lambda (x)829 (not (and (eq? 'quote (node-class x))830 (zero? (first (node-parameters x))) ) ) )831 (cdr callargs) ) ) ) )832 (and (>= (length callargs) 2)833 (make-node834 '##core#call (list #t)835 (list836 cont837 (fold-inner838 (lambda (x y)839 (make-node '##core#inline840 (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))841 (list x y) ) )842 callargs) ) ) ) ) ) ) ) )843844(let ()845 (define (rewrite-div db classargs cont callargs)846 ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]847 ;; - Remove "1" from arguments, if more than 1.848 ;; - Replace divisions by 2 with shift right. [fixnum-mode]849 (and (eq? number-type 'fixnum)850 (>= (length callargs) 2)851 (let ((callargs852 (cons (car callargs)853 (filter854 (lambda (x)855 (not (and (eq? 'quote (node-class x))856 (eq? 1 (first (node-parameters x))) ) ) )857 (cdr callargs) ) ) ) )858 (and (>= (length callargs) 2)859 (make-node860 '##core#call (list #t)861 (list862 cont863 (fold-inner864 (lambda (x y)865 (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))866 (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))867 (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )868 callargs) ) ) ) ) ) )869 (rewrite 'scheme#/ 8 rewrite-div)870 (rewrite '##sys#/-2 8 rewrite-div))871872(rewrite873 'scheme#quotient 8874 (lambda (db classargs cont callargs)875 ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]876 ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]877 (and (eq? 'fixnum number-type)878 (= (length callargs) 2)879 (make-node880 '##core#call (list #t)881 (let ([arg2 (second callargs)])882 (list cont883 (if (and (eq? 'quote (node-class arg2))884 (eq? 2 (first (node-parameters arg2))) )885 (make-node886 '##core#inline '("C_fixnum_shift_right")887 (list (first callargs) (qnode 1)) )888 (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) ) ) ) )889890(rewrite 'scheme#+ 19)891(rewrite 'scheme#- 19)892(rewrite 'scheme#* 19)893(rewrite 'scheme#/ 19)894895(rewrite 'scheme#+ 16 2 "C_s_a_i_plus" #t 29)896(rewrite 'scheme#- 16 2 "C_s_a_i_minus" #t 29)897(rewrite 'scheme#* 16 2 "C_s_a_i_times" #t 33)898(rewrite 'scheme#quotient 16 2 "C_s_a_i_quotient" #t 5)899(rewrite 'scheme#remainder 16 2 "C_s_a_i_remainder" #t 5)900(rewrite 'scheme#modulo 16 2 "C_s_a_i_modulo" #t 5)901902(rewrite 'scheme#= 17 2 "C_i_nequalp")903(rewrite 'scheme#> 17 2 "C_i_greaterp")904(rewrite 'scheme#< 17 2 "C_i_lessp")905(rewrite 'scheme#>= 17 2 "C_i_greater_or_equalp")906(rewrite 'scheme#<= 17 2 "C_i_less_or_equalp")907908(rewrite 'scheme#= 13 #f "C_nequalp" #t)909(rewrite 'scheme#> 13 #f "C_greaterp" #t)910(rewrite 'scheme#< 13 #f "C_lessp" #t)911(rewrite 'scheme#>= 13 #f "C_greater_or_equal_p" #t)912(rewrite 'scheme#<= 13 #f "C_less_or_equal_p" #t)913914(rewrite 'scheme#* 13 #f "C_times" #t)915(rewrite 'scheme#+ 13 #f "C_plus" #t)916(rewrite 'scheme#- 13 '(1 . #f) "C_minus" #t)917918(rewrite 'scheme#number->string 13 '(1 . 2) "C_number_to_string" #t)919(rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t)920(rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t)921(rewrite '##sys#allocate-bytevector 13 4 "C_allocate_bytevector" #t)922(rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t)923(rewrite 'chicken.platform#return-to-host 13 0 "C_return_to_host" #t)924(rewrite '##sys#context-switch 13 1 "C_context_switch" #t)925926(rewrite 'scheme#even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")927(rewrite 'scheme#odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")928(rewrite 'scheme#remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")929930(rewrite 'scheme#even? 17 1 "C_i_evenp")931(rewrite 'scheme#odd? 17 1 "C_i_oddp")932933(rewrite 'chicken.fixnum#fxodd? 2 1 "C_i_fixnumoddp" #t)934(rewrite 'chicken.fixnum#fxeven? 2 1 "C_i_fixnumevenp" #t)935936(rewrite 'scheme#floor 15 'flonum 'fixnum 'chicken.flonum#fpfloor #f)937(rewrite 'scheme#ceiling 15 'flonum 'fixnum 'chicken.flonum#fpceiling #f)938(rewrite 'scheme#truncate 15 'flonum 'fixnum 'chicken.flonum#fptruncate #f)939940(rewrite 'chicken.flonum#fpsin 16 1 "C_a_i_flonum_sin" #f words-per-flonum)941(rewrite 'chicken.flonum#fpcos 16 1 "C_a_i_flonum_cos" #f words-per-flonum)942(rewrite 'chicken.flonum#fptan 16 1 "C_a_i_flonum_tan" #f words-per-flonum)943(rewrite 'chicken.flonum#fpasin 16 1 "C_a_i_flonum_asin" #f words-per-flonum)944(rewrite 'chicken.flonum#fpacos 16 1 "C_a_i_flonum_acos" #f words-per-flonum)945(rewrite 'chicken.flonum#fpatan 16 1 "C_a_i_flonum_atan" #f words-per-flonum)946(rewrite 'chicken.flonum#fpatan2 16 2 "C_a_i_flonum_atan2" #f words-per-flonum)947(rewrite 'chicken.flonum#fpexp 16 1 "C_a_i_flonum_exp" #f words-per-flonum)948(rewrite 'chicken.flonum#fpexpt 16 2 "C_a_i_flonum_expt" #f words-per-flonum)949(rewrite 'chicken.flonum#fplog 16 1 "C_a_i_flonum_log" #f words-per-flonum)950(rewrite 'chicken.flonum#fpsqrt 16 1 "C_a_i_flonum_sqrt" #f words-per-flonum)951(rewrite 'chicken.flonum#fpabs 16 1 "C_a_i_flonum_abs" #f words-per-flonum)952(rewrite 'chicken.flonum#fptruncate 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)953(rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_round" #f words-per-flonum)954(rewrite 'chicken.flonum#fpceiling 16 1 "C_a_i_flonum_ceiling" #f words-per-flonum)955(rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_floor" #f words-per-flonum)956957(rewrite 'scheme#cons 16 2 "C_a_i_cons" #t 3)958(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)959(rewrite 'chicken.base#weak-cons 16 2 "C_a_i_weak_cons" #t 3)960(rewrite 'scheme#list 16 #f "C_a_i_list" #t '(0 3) #t)961(rewrite '##sys#list 16 #f "C_a_i_list" #t '(0 3))962(rewrite 'scheme#vector 16 #f "C_a_i_vector" #t #t #t)963(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)964(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t #t)965(rewrite 'scheme#string 16 #f "C_a_i_string" #t '(7 1))966(rewrite 'chicken.memory#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)967(rewrite 'chicken.memory#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)968(rewrite 'chicken.memory#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)969(rewrite 'chicken.locative#locative-ref 16 1 "C_a_i_locative_ref" #t 6)970971(rewrite 'chicken.memory#pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)972(rewrite 'chicken.memory#pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)973(rewrite 'chicken.memory#pointer-u16-ref 2 1 "C_u_i_pointer_u16_ref" #f)974(rewrite 'chicken.memory#pointer-s16-ref 2 1 "C_u_i_pointer_s16_ref" #f)975(rewrite 'chicken.memory#pointer-u8-set! 2 2 "C_u_i_pointer_u8_set" #f)976(rewrite 'chicken.memory#pointer-s8-set! 2 2 "C_u_i_pointer_s8_set" #f)977(rewrite 'chicken.memory#pointer-u16-set! 2 2 "C_u_i_pointer_u16_set" #f)978(rewrite 'chicken.memory#pointer-s16-set! 2 2 "C_u_i_pointer_s16_set" #f)979(rewrite 'chicken.memory#pointer-u32-set! 2 2 "C_u_i_pointer_u32_set" #f)980(rewrite 'chicken.memory#pointer-s32-set! 2 2 "C_u_i_pointer_s32_set" #f)981(rewrite 'chicken.memory#pointer-f32-set! 2 2 "C_u_i_pointer_f32_set" #f)982(rewrite 'chicken.memory#pointer-f64-set! 2 2 "C_u_i_pointer_f64_set" #f)983984;; on 32-bit platforms, 32-bit integers do not always fit in a word,985;; bignum1 and bignum wrapper (5 words) may be used instead986(rewrite 'chicken.memory#pointer-u32-ref 16 1 "C_a_u_i_pointer_u32_ref" #f min-words-per-bignum)987(rewrite 'chicken.memory#pointer-s32-ref 16 1 "C_a_u_i_pointer_s32_ref" #f min-words-per-bignum)988989(rewrite 'chicken.memory#pointer-f32-ref 16 1 "C_a_u_i_pointer_f32_ref" #f words-per-flonum)990(rewrite 'chicken.memory#pointer-f64-ref 16 1 "C_a_u_i_pointer_f64_ref" #f words-per-flonum)991992(rewrite993 '##sys#setslot 8994 (lambda (db classargs cont callargs)995 ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>)996 ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)997 (and (= (length callargs) 3)998 (make-node999 '##core#call (list #t)1000 (list cont1001 (make-node1002 '##core#inline1003 (let ([val (third callargs)])1004 (if (and (eq? 'quote (node-class val))1005 (immediate? (first (node-parameters val))) )1006 '("C_i_set_i_slot")1007 '("C_i_setslot") ) )1008 callargs) ) ) ) ) )10091010(rewrite 'chicken.fixnum#fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus")1011(rewrite 'chicken.fixnum#fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference")1012(rewrite 'chicken.fixnum#fxshl 17 2 "C_fixnum_shift_left")1013(rewrite 'chicken.fixnum#fxshr 17 2 "C_fixnum_shift_right")1014(rewrite 'chicken.fixnum#fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate")1015(rewrite 'chicken.fixnum#fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor")1016(rewrite 'chicken.fixnum#fxand 17 2 "C_fixnum_and" "C_u_fixnum_and")1017(rewrite 'chicken.fixnum#fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")1018(rewrite 'chicken.fixnum#fx/ 17 2 "C_fixnum_divide" "C_u_fixnum_divide")1019(rewrite 'chicken.fixnum#fxmod 17 2 "C_fixnum_modulo" "C_u_fixnum_modulo")1020(rewrite 'chicken.fixnum#fxrem 17 2 "C_i_fixnum_remainder_checked")10211022(rewrite1023 'chicken.bitwise#arithmetic-shift 81024 (lambda (db classargs cont callargs)1025 ;; (arithmetic-shift <x> <-int>)1026 ;; -> (##core#inline "C_fixnum_shift_right" <x> -<int>)1027 ;; (arithmetic-shift <x> <+int>)1028 ;; -> (##core#inline "C_fixnum_shift_left" <x> <int>)1029 ;; _ -> (##core#inline "C_i_fixnum_arithmetic_shift" <x> <y>)1030 ;;1031 ;; not in fixnum-mode:1032 ;; _ -> (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 6) <x> <y>)1033 (and (= 2 (length callargs))1034 (let ((val (second callargs)))1035 (make-node1036 '##core#call (list #t)1037 (list cont1038 (or (and-let* (((eq? 'quote (node-class val)))1039 ((eq? number-type 'fixnum))1040 (n (first (node-parameters val)))1041 ((and (fixnum? n) (not (big-fixnum? n)))) )1042 (if (negative? n)1043 (make-node1044 '##core#inline '("C_fixnum_shift_right")1045 (list (first callargs) (qnode (- n))) )1046 (make-node1047 '##core#inline '("C_fixnum_shift_left")1048 (list (first callargs) val) ) ) )1049 (if (eq? number-type 'fixnum)1050 (make-node '##core#inline1051 '("C_i_fixnum_arithmetic_shift") callargs)1052 (make-node '##core#inline_allocate1053 (list "C_s_a_i_arithmetic_shift" 5)1054 callargs) ) ) ) ) ) ) ) )10551056(rewrite '##sys#byte 17 2 "C_subbyte")1057(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")1058(rewrite '##sys#peek-byte 17 2 "C_peek_byte")1059(rewrite 'chicken.memory#pointer->object 17 2 "C_pointer_to_object")1060(rewrite '##sys#setislot 17 3 "C_i_set_i_slot")1061(rewrite '##sys#poke-integer 17 3 "C_poke_integer")1062(rewrite '##sys#poke-double 17 3 "C_poke_double")1063(rewrite 'scheme#string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p")1064(rewrite 'scheme#string-ci=? 17 2 "C_i_string_ci_equal_p")1065(rewrite '##sys#permanent? 17 1 "C_permanentp")1066(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp")1067(rewrite '##sys#immediate? 17 1 "C_immp")1068(rewrite 'chicken.locative#locative->object 17 1 "C_i_locative_to_object")1069(rewrite 'chicken.locative#locative->object 17 1 "C_i_locative_to_object")1070(rewrite 'chicken.locative#locative-index 17 1 "C_i_locative_index")1071(rewrite 'chicken.locative#locative-set! 17 2 "C_i_locative_set")1072(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp")1073(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")1074(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")1075(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")1076(rewrite '##sys#foreign-symbol-argument 17 1 "C_i_foreign_symbol_argumentp")1077(rewrite '##sys#foreign-struct-wrapper-argument 17 2 "C_i_foreign_struct_wrapper_argumentp")1078(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")1079(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")1080(rewrite '##sys#foreign-ranged-integer-argument 17 2 "C_i_foreign_ranged_integer_argumentp")1081(rewrite '##sys#foreign-unsigned-ranged-integer-argument 17 2 "C_i_foreign_unsigned_ranged_integer_argumentp")10821083(rewrite 'chicken.bytevector#bytevector-length 2 1 "C_block_size" #f)1084(rewrite 'chicken.number-vector#bytevector-u8-set! 2 3 "C_u_i_u8vector_set" #f)1085(rewrite 'chicken.number-vector#bytevector-u8-set! 2 3 "C_i_u8vector_set" #t)10861087;; TODO: Move this stuff to types.db1088(rewrite 'chicken.number-vector#s8vector-ref 2 2 "C_u_i_s8vector_ref" #f)1089(rewrite 'chicken.number-vector#s8vector-ref 2 2 "C_i_s8vector_ref" #t)1090(rewrite 'chicken.number-vector#u16vector-ref 2 2 "C_u_i_u16vector_ref" #f)1091(rewrite 'chicken.number-vector#u16vector-ref 2 2 "C_i_u16vector_ref" #t)1092(rewrite 'chicken.number-vector#s16vector-ref 2 2 "C_u_i_s16vector_ref" #f)1093(rewrite 'chicken.number-vector#s16vector-ref 2 2 "C_i_s16vector_ref" #t)10941095(rewrite 'chicken.number-vector#u32vector-ref 16 2 "C_a_i_u32vector_ref" #t min-words-per-bignum)1096(rewrite 'chicken.number-vector#s32vector-ref 16 2 "C_a_i_s32vector_ref" #t min-words-per-bignum)10971098(rewrite 'chicken.number-vector#f32vector-ref 16 2 "C_a_u_i_f32vector_ref" #f words-per-flonum)1099(rewrite 'chicken.number-vector#f32vector-ref 16 2 "C_a_i_f32vector_ref" #t words-per-flonum)1100(rewrite 'chicken.number-vector#f64vector-ref 16 2 "C_a_u_i_f64vector_ref" #f words-per-flonum)1101(rewrite 'chicken.number-vector#f64vector-ref 16 2 "C_a_i_f64vector_ref" #t words-per-flonum)11021103(rewrite 'chicken.number-vector#u8vector-set! 2 3 "C_u_i_u8vector_set" #f)1104(rewrite 'chicken.number-vector#u8vector-set! 2 3 "C_i_u8vector_set" #t)1105(rewrite 'chicken.number-vector#s8vector-set! 2 3 "C_u_i_s8vector_set" #f)1106(rewrite 'chicken.number-vector#s8vector-set! 2 3 "C_i_s8vector_set" #t)1107(rewrite 'chicken.number-vector#u16vector-set! 2 3 "C_u_i_u16vector_set" #f)1108(rewrite 'chicken.number-vector#u16vector-set! 2 3 "C_i_u16vector_set" #t)1109(rewrite 'chicken.number-vector#s16vector-set! 2 3 "C_u_i_s16vector_set" #f)1110(rewrite 'chicken.number-vector#s16vector-set! 2 3 "C_i_s16vector_set" #t)1111(rewrite 'chicken.number-vector#u32vector-set! 2 3 "C_u_i_u32vector_set" #f)1112(rewrite 'chicken.number-vector#u32vector-set! 2 3 "C_i_u32vector_set" #t)1113(rewrite 'chicken.number-vector#s32vector-set! 2 3 "C_u_i_s32vector_set" #f)1114(rewrite 'chicken.number-vector#s32vector-set! 2 3 "C_i_s32vector_set" #t)1115(rewrite 'chicken.number-vector#u64vector-set! 2 3 "C_u_i_u64vector_set" #f)1116(rewrite 'chicken.number-vector#u64vector-set! 2 3 "C_i_u64vector_set" #t)1117(rewrite 'chicken.number-vector#s64vector-set! 2 3 "C_u_i_s64vector_set" #f)1118(rewrite 'chicken.number-vector#s64vector-set! 2 3 "C_i_s64vector_set" #t)1119(rewrite 'chicken.number-vector#f32vector-set! 2 3 "C_i_f32vector_set" #t)1120(rewrite 'chicken.number-vector#f64vector-set! 2 3 "C_i_f64vector_set" #t)11211122(rewrite 'chicken.number-vector#u8vector-length 2 1 "C_u_i_bytevector_length" #f)1123(rewrite 'chicken.number-vector#u8vector-length 2 1 "C_i_bytevector_length" #t)1124(rewrite 'chicken.number-vector#s8vector-length 2 1 "C_u_i_s8vector_length" #f)1125(rewrite 'chicken.number-vector#s8vector-length 2 1 "C_i_s8vector_length" #t)1126(rewrite 'chicken.number-vector#u16vector-length 2 1 "C_u_i_u16vector_length" #f)1127(rewrite 'chicken.number-vector#u16vector-length 2 1 "C_i_u16vector_length" #t)1128(rewrite 'chicken.number-vector#s16vector-length 2 1 "C_u_i_s16vector_length" #f)1129(rewrite 'chicken.number-vector#s16vector-length 2 1 "C_i_s16vector_length" #t)1130(rewrite 'chicken.number-vector#u32vector-length 2 1 "C_u_i_u32vector_length" #f)1131(rewrite 'chicken.number-vector#u32vector-length 2 1 "C_i_u32vector_length" #t)1132(rewrite 'chicken.number-vector#s32vector-length 2 1 "C_u_i_s32vector_length" #f)1133(rewrite 'chicken.number-vector#s32vector-length 2 1 "C_i_s32vector_length" #t)1134(rewrite 'chicken.number-vector#u64vector-length 2 1 "C_u_i_u64vector_length" #f)1135(rewrite 'chicken.number-vector#u64vector-length 2 1 "C_i_u64vector_length" #t)1136(rewrite 'chicken.number-vector#s64vector-length 2 1 "C_u_i_s64vector_length" #f)1137(rewrite 'chicken.number-vector#s64vector-length 2 1 "C_i_s64vector_length" #t)1138(rewrite 'chicken.number-vector#f32vector-length 2 1 "C_u_i_f32vector_length" #f)1139(rewrite 'chicken.number-vector#f32vector-length 2 1 "C_i_f32vector_length" #t)1140(rewrite 'chicken.number-vector#f64vector-length 2 1 "C_u_i_f64vector_length" #f)1141(rewrite 'chicken.number-vector#f64vector-length 2 1 "C_i_f64vector_length" #t)11421143(rewrite 'chicken.base#atom? 17 1 "C_i_not_pair_p")11441145(rewrite 'chicken.number-vector#s8vector->bytevector/shared 7 1 "C_slot" 1 #f)1146(rewrite 'chicken.number-vector#u16vector->bytevector/shared 7 1 "C_slot" 1 #f)1147(rewrite 'chicken.number-vector#s16vector->bytevector/shared 7 1 "C_slot" 1 #f)1148(rewrite 'chicken.number-vector#u32vector->bytevector/shared 7 1 "C_slot" 1 #f)1149(rewrite 'chicken.number-vector#s32vector->bytevector/shared 7 1 "C_slot" 1 #f)1150(rewrite 'chicken.number-vector#u64vector->bytevector/shared 7 1 "C_slot" 1 #f)1151(rewrite 'chicken.number-vector#s64vector->bytevector/shared 7 1 "C_slot" 1 #f)1152(rewrite 'chicken.number-vector#f32vector->bytevector/shared 7 1 "C_slot" 1 #f)1153(rewrite 'chicken.number-vector#f64vector->bytevector/shared 7 1 "C_slot" 1 #f)1154(rewrite 'chicken.number-vector#c64vector->bytevector/shared 7 1 "C_slot" 1 #f)1155(rewrite 'chicken.number-vector#c128vector->bytevector/shared 7 1 "C_slot" 1 #f)11561157(let ()1158 (define (rewrite-make-vector db classargs cont callargs)1159 ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>))1160 ;; - <n> should be less or equal to 32.1161 (let ([argc (length callargs)])1162 (and (pair? callargs)1163 (let ([n (first callargs)])1164 (and (eq? 'quote (node-class n))1165 (let ([tmp (gensym)]1166 [c (first (node-parameters n))] )1167 (and (fixnum? c)1168 (<= 0 c 32)1169 (let ([val (if (pair? (cdr callargs))1170 (second callargs)1171 (make-node '##core#undefined '() '()) ) ] )1172 (make-node1173 'let1174 (list tmp)1175 (list val1176 (make-node1177 '##core#call (list #t)1178 (list cont1179 (make-node1180 '##core#inline_allocate1181 (list "C_a_i_vector" (add1 c))1182 (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) )1183 (rewrite 'scheme#make-vector 8 rewrite-make-vector)1184 (rewrite '##sys#make-vector 8 rewrite-make-vector) )11851186(let ()1187 (define (rewrite-call/cc db classargs cont callargs)1188 ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)1189 (and (= 1 (length callargs))1190 (let ((val (first callargs)))1191 (and (eq? '##core#variable (node-class val))1192 (and-let* ((proc (db-get db (first (node-parameters val)) 'value))1193 ((eq? '##core#lambda (node-class proc))) )1194 (let ((llist (third (node-parameters proc))))1195 (##sys#decompose-lambda-list1196 llist1197 (lambda (vars argc rest)1198 (and (= argc 2)1199 (let ((var (or rest (second llist))))1200 (and (not (db-get db var 'references))1201 (not (db-get db var 'assigned))1202 (not (db-get db var 'inline-transient))1203 (make-node1204 '##core#call (list #t)1205 (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )1206 (rewrite 'scheme#call-with-current-continuation 8 rewrite-call/cc)1207 (rewrite 'scheme#call/cc 8 rewrite-call/cc))12081209(define setter-map1210 '((scheme#car . scheme#set-car!)1211 (scheme#cdr . scheme#set-cdr!)1212 (scheme#string-ref . scheme#string-set!)1213 (scheme#vector-ref . scheme#vector-set!)1214 (chicken.number-vector#u8vector-ref . chicken.number-vector#u8vector-set!)1215 (chicken.number-vector#s8vector-ref . chicken.number-vector#s8vector-set!)1216 (chicken.number-vector#u16vector-ref . chicken.number-vector#u16vector-set!)1217 (chicken.number-vector#s16vector-ref . chicken.number-vector#s16vector-set!)1218 (chicken.number-vector#u32vector-ref . chicken.number-vector#u32vector-set!)1219 (chicken.number-vector#s32vector-ref . chicken.number-vector#s32vector-set!)1220 (chicken.number-vector#u64vector-ref . chicken.number-vector#u64vector-set!)1221 (chicken.number-vector#s64vector-ref . chicken.number-vector#s64vector-set!)1222 (chicken.number-vector#f32vector-ref . chicken.number-vector#f32vector-set!)1223 (chicken.number-vector#f64vector-ref . chicken.number-vector#f64vector-set!)1224 (chicken.number-vector#c64vector-ref . chicken.number-vector#c64vector-set!)1225 (chicken.number-vector#c128vector-ref . chicken.number-vector#c128vector-set!)1226 (chicken.locative#locative-ref . chicken.locative#locative-set!)1227 (chicken.memory#pointer-u8-ref . chicken.memory#pointer-u8-set!)1228 (chicken.memory#pointer-s8-ref . chicken.memory#pointer-s8-set!)1229 (chicken.memory#pointer-u16-ref . chicken.memory#pointer-u16-set!)1230 (chicken.memory#pointer-s16-ref . chicken.memory#pointer-s16-set!)1231 (chicken.memory#pointer-u32-ref . chicken.memory#pointer-u32-set!)1232 (chicken.memory#pointer-s32-ref . chicken.memory#pointer-s32-set!)1233 (chicken.memory#pointer-f32-ref . chicken.memory#pointer-f32-set!)1234 (chicken.memory#pointer-f64-ref . chicken.memory#pointer-f64-set!)1235 (chicken.memory.representation#block-ref . chicken.memory.representation#block-set!) ))12361237(rewrite1238 '##sys#setter 81239 (lambda (db classargs cont callargs)1240 ;; (setter <known-getter>) -> <known-setter>1241 (and (= 1 (length callargs))1242 (let ((arg (car callargs)))1243 (and (eq? '##core#variable (node-class arg))1244 (let ((sym (car (node-parameters arg))))1245 (and (intrinsic? sym)1246 (and-let* ((a (assq sym setter-map)))1247 (make-node1248 '##core#call (list #t)1249 (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) )12501251(rewrite 'chicken.base#void 3 '##sys#undefined-value 0)1252(rewrite '##sys#void 3 '##sys#undefined-value #f)1253(rewrite 'scheme#current-input-port 3 '##sys#standard-input 0)1254(rewrite 'scheme#current-output-port 3 '##sys#standard-output 0)1255(rewrite 'chicken.base#current-error-port 3 '##sys#standard-error 0)12561257(rewrite1258 'chicken.bitwise#bit->boolean 81259 (lambda (db classargs cont callargs)1260 (and (= 2 (length callargs))1261 (make-node1262 '##core#call (list #t)1263 (list cont1264 (make-node1265 '##core#inline1266 (list (if (eq? number-type 'fixnum) "C_u_i_bit_to_bool" "C_i_bit_to_bool"))1267 callargs) ) ) ) ) )12681269(rewrite1270 'chicken.bitwise#integer-length 81271 (lambda (db classargs cont callargs)1272 (and (= 1 (length callargs))1273 (make-node1274 '##core#call (list #t)1275 (list cont1276 (make-node1277 '##core#inline1278 (list (if (eq? number-type 'fixnum) "C_i_fixnum_length" "C_i_integer_length"))1279 callargs) ) ) ) ) )12801281(rewrite 'scheme#read-char 23 0 '##sys#read-char/port '##sys#standard-input)1282(rewrite 'scheme#write-char 23 1 '##sys#write-char/port '##sys#standard-output)1283(rewrite 'chicken.string#substring=? 23 2 '##sys#substring=? 0 0 #f)1284(rewrite 'chicken.string#substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)1285(rewrite 'chicken.string#substring-index 23 2 '##sys#substring-index 0)1286(rewrite 'chicken.string#substring-index-ci 23 2 '##sys#substring-index-ci 0)12871288(rewrite 'chicken.keyword#get-keyword 7 2 "C_i_get_keyword" #f #t)1289(rewrite '##sys#get-keyword 7 2 "C_i_get_keyword" #f #t)12901291)