~ chicken-core (chicken-5) /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)4950(include "tweaks")51(include "mini-srfi-1.scm")5253;;; Parameters:5455(default-optimization-passes 3)5657(define default-declarations58 '((always-bound59 ##sys#standard-input ##sys#standard-output ##sys#standard-error60 ##sys#undefined-value)61 (bound-to-procedure62 ##sys#for-each ##sys#map ##sys#print ##sys#setter63 ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values64 ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#structure? ##sys#slot65 ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!66 ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument67 ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string68 ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string69 ##sys#foreign-block-argument ##sys#foreign-string-argument70 ##sys#foreign-pointer-argument ##sys#call-with-current-continuation)))7172(define default-profiling-declarations73 '((##core#declare74 (uses profiler)75 (bound-to-procedure ##sys#profile-entry76 ##sys#profile-exit77 ##sys#register-profile-info78 ##sys#set-profile-info-vector!))))7980(define default-units '(library eval))8182(define words-per-flonum 4)83(define min-words-per-bignum 5)8485(eq-inline-operator "C_eqp")86(membership-test-operators87 '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")88 ("C_i_memv" . "C_i_eqvp") ) )89(membership-unfold-limit 20)90(define target-include-file "chicken.h")9192(define valid-compiler-options93 '(-help94 h help version verbose explicit-use95 no-trace no-warnings unsafe block96 check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info97 profile inline keep-shadowed-macros ignore-repository98 fixnum-arithmetic disable-interrupts optimize-leaf-routines99 compile-syntax tag-pointers accumulate-profile100 disable-stack-overflow-checks raw specialize101 emit-external-prototypes-first release local inline-global102 analyze-only dynamic static103 no-argc-checks no-procedure-checks no-parentheses-synonyms104 no-procedure-checks-for-toplevel-bindings105 no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax106 no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries107 strict-types clustering lfa2 debug-info108 regenerate-import-libraries setup-mode109 module-registration no-module-registration))110111(define valid-compiler-options-with-argument112 '(debug link emit-link-file113 output-file include-path heap-size stack-size unit uses module114 keyword-style require-extension inline-limit profile-name115 prelude postlude prologue epilogue nursery extend feature no-feature116 unroll-limit117 emit-inline-file consult-inline-file118 emit-types-file consult-types-file119 emit-import-library))120121122;;; Standard and extended bindings:123124(set! default-standard-bindings125 (map (lambda (x) (symbol-append 'scheme# x))126 '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr127 cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar128 cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!129 null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port130 write-char newline write display append symbol->string for-each map char? char->integer131 integer->char eof-object? vector-length string-length string-ref string-set! vector-ref132 vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol133 number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?134 max min quotient remainder modulo floor ceiling truncate round rationalize135 exact->inexact inexact->exact136 exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?137 char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?138 char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?139 string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?140 string-append string->list list->string vector? vector->list list->vector string read141 read-char substring string-fill! vector-copy! vector-fill! make-string make-vector open-input-file142 open-output-file call-with-input-file call-with-output-file close-input-port close-output-port143 values call-with-values vector procedure? memq memv member assq assv assoc list-tail144 list-ref abs char-ready? peek-char list->string string->list145 current-input-port current-output-port146 make-polar make-rectangular real-part imag-part147 load eval interaction-environment null-environment148 scheme-report-environment)))149150(define-constant +flonum-bindings+151 (map (lambda (x) (symbol-append 'chicken.flonum# x))152 '(fp/? fp+ fp- fp* fp/ fp> fp< fp= fp>= fp<= fpmin fpmax fpneg fpgcd fp*+153 fpfloor fpceiling fptruncate fpround fpsin fpcos fptan fpasin fpacos154 fpatan fpatan2 fpexp fpexpt fplog fpsqrt fpabs fpinteger?)))155156(define-constant +fixnum-bindings+157 (map (lambda (x) (symbol-append 'chicken.fixnum# x))158 '(fx* fx*? fx+ fx+? fx- fx-? fx/ fx/? fx< fx<= fx= fx> fx>= fxand159 fxeven? fxgcd fxior fxlen fxmax fxmin fxmod fxneg fxnot fxodd?160 fxrem fxshl fxshr fxxor)))161162(define-constant +extended-bindings+163 '(chicken.base#bignum? chicken.base#cplxnum? chicken.base#fixnum?164 chicken.base#flonum? chicken.base#ratnum?165 chicken.base#add1 chicken.base#sub1166 chicken.base#nan? chicken.base#finite? chicken.base#infinite?167 chicken.base#gensym168 chicken.base#void chicken.base#print chicken.base#print*169 chicken.base#error chicken.base#call/cc chicken.base#char-name170 chicken.base#current-error-port171 chicken.base#symbol-append chicken.base#foldl chicken.base#foldr172 chicken.base#setter chicken.base#getter-with-setter173 chicken.base#equal=? chicken.base#exact-integer?174 chicken.base#flush-output175176 chicken.base#weak-cons chicken.base#weak-pair? chicken.base#bwp-object?177178 chicken.base#identity chicken.base#o chicken.base#atom?179 chicken.base#alist-ref chicken.base#rassoc180181 chicken.bitwise#integer-length182 chicken.bitwise#bitwise-and chicken.bitwise#bitwise-not183 chicken.bitwise#bitwise-ior chicken.bitwise#bitwise-xor184 chicken.bitwise#arithmetic-shift chicken.bitwise#bit->boolean185186 chicken.blob#blob-size chicken.blob#blob=?187188 chicken.keyword#get-keyword189190 srfi-4#u8vector? srfi-4#s8vector?191 srfi-4#u16vector? srfi-4#s16vector?192 srfi-4#u32vector? srfi-4#u64vector?193 srfi-4#s32vector? srfi-4#s64vector?194 srfi-4#f32vector? srfi-4#f64vector?195196 srfi-4#u8vector-length srfi-4#s8vector-length197 srfi-4#u16vector-length srfi-4#s16vector-length198 srfi-4#u32vector-length srfi-4#u64vector-length199 srfi-4#s32vector-length srfi-4#s64vector-length200 srfi-4#f32vector-length srfi-4#f64vector-length201202 srfi-4#u8vector-ref srfi-4#s8vector-ref203 srfi-4#u16vector-ref srfi-4#s16vector-ref204 srfi-4#u32vector-ref srfi-4#u64vector-ref205 srfi-4#s32vector-ref srfi-4#s64vector-ref206 srfi-4#f32vector-ref srfi-4#f64vector-ref207208 srfi-4#u8vector-set! srfi-4#s8vector-set!209 srfi-4#u16vector-set! srfi-4#s16vector-set!210 srfi-4#u32vector-set! srfi-4#u64vector-set!211 srfi-4#s32vector-set! srfi-4#s64vector-set!212 srfi-4#f32vector-set! srfi-4#f64vector-set!213214 srfi-4#u8vector->blob/shared srfi-4#s8vector->blob/shared215 srfi-4#u16vector->blob/shared srfi-4#s16vector->blob/shared216 srfi-4#u32vector->blob/shared srfi-4#s32vector->blob/shared217 srfi-4#u64vector->blob/shared srfi-4#s64vector->blob/shared218 srfi-4#f32vector->blob/shared srfi-4#f64vector->blob/shared219 srfi-4#blob->u8vector/shared srfi-4#blob->s8vector/shared220 srfi-4#blob->u16vector/shared srfi-4#blob->s16vector/shared221 srfi-4#blob->u32vector/shared srfi-4#blob->s32vector/shared222 srfi-4#blob->u64vector/shared srfi-4#blob->s64vector/shared223 srfi-4#blob->f32vector/shared srfi-4#blob->f64vector/shared224225 chicken.memory#u8vector-ref chicken.memory#s8vector-ref226 chicken.memory#u16vector-ref chicken.memory#s16vector-ref227 chicken.memory#u32vector-ref chicken.memory#s32vector-ref228 chicken.memory#u64vector-ref chicken.memory#s64vector-ref229 chicken.memory#f32vector-ref chicken.memory#f64vector-ref230 chicken.memory#f32vector-set! chicken.memory#f64vector-set!231 chicken.memory#u8vector-set! chicken.memory#s8vector-set!232 chicken.memory#u16vector-set! chicken.memory#s16vector-set!233 chicken.memory#u32vector-set! chicken.memory#s32vector-set!234 chicken.memory#u64vector-set! chicken.memory#s64vector-set!235236 chicken.memory.representation#number-of-slots237 chicken.memory.representation#make-record-instance238 chicken.memory.representation#block-ref239 chicken.memory.representation#block-set!240241 chicken.locative#locative-ref chicken.locative#locative-set!242 chicken.locative#locative->object chicken.locative#locative?243 chicken.locative#locative-index244245 chicken.memory#pointer+ chicken.memory#pointer=?246 chicken.memory#address->pointer chicken.memory#pointer->address247 chicken.memory#pointer->object chicken.memory#object->pointer248 chicken.memory#pointer-u8-ref chicken.memory#pointer-s8-ref249 chicken.memory#pointer-u16-ref chicken.memory#pointer-s16-ref250 chicken.memory#pointer-u32-ref chicken.memory#pointer-s32-ref251 chicken.memory#pointer-f32-ref chicken.memory#pointer-f64-ref252 chicken.memory#pointer-u8-set! chicken.memory#pointer-s8-set!253 chicken.memory#pointer-u16-set! chicken.memory#pointer-s16-set!254 chicken.memory#pointer-u32-set! chicken.memory#pointer-s32-set!255 chicken.memory#pointer-f32-set! chicken.memory#pointer-f64-set!256257 chicken.string#substring-index chicken.string#substring-index-ci258 chicken.string#substring=? chicken.string#substring-ci=?259260 chicken.io#read-string261262 chicken.format#format263 chicken.format#printf chicken.format#sprintf chicken.format#fprintf))264265(set! default-extended-bindings266 (append +fixnum-bindings+ +flonum-bindings+ +extended-bindings+))267268(set! internal-bindings269 '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set! ##sys#/-2270 ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte271 ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure272 ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string273 ##sys#check-symbol ##sys#check-boolean ##sys#check-locative274 ##sys#check-port ##sys#check-input-port ##sys#check-output-port275 ##sys#check-open-port276 ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons277 ##sys#call-with-values ##sys#flonum-in-fixnum-range?278 ##sys#immediate? ##sys#context-switch279 ##sys#make-structure ##sys#apply ##sys#apply-values280 chicken.continuation#continuation-graft281 ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?282 ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#get-keyword283 ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument284 ##sys#foreign-block-argument ##sys#foreign-struct-wrapper-argument285 ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void286 ##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument287 ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double288 ##sys#intern-symbol ##sys#null-pointer? ##sys#peek-byte289 ##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd))290291(for-each292 (cut mark-variable <> '##compiler#pure '#t)293 '(##sys#slot ##sys#block-ref ##sys#size ##sys#byte294 ##sys#pointer? ##sys#generic-structure? ##sys#immediate?295 ##sys#bytevector? ##sys#pair? ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?296 ##sys#get-keyword ; ok it isn't, but this is only used for ext. llists297 ##sys#void ##sys#permanent?))298299300;;; Rewriting-definitions for this platform:301302(let ()303 ;; (add1 <x>) -> (##core#inline "C_fixnum_increase" <x>) [fixnum-mode]304 ;; (add1 <x>) -> (##core#inline "C_u_fixnum_increase" <x>) [fixnum-mode + unsafe]305 ;; (add1 <x>) -> (##core#inline_allocate ("C_s_a_i_plus" 36) <x> 1)306 ;; (sub1 <x>) -> (##core#inline "C_fixnum_decrease" <x>) [fixnum-mode]307 ;; (sub1 <x>) -> (##core#inline "C_u_fixnum_decrease" <x>) [fixnum-mode + unsafe]308 ;; (sub1 <x>) -> (##core#inline_allocate ("C_s_a_i_minus" 36) <x> 1)309 (define ((op1 fiop ufiop aiop) db classargs cont callargs)310 (and (= (length callargs) 1)311 (make-node312 '##core#call (list #t)313 (list314 cont315 (if (eq? 'fixnum number-type)316 (make-node '##core#inline (list (if unsafe ufiop fiop)) callargs)317 (make-node318 '##core#inline_allocate (list aiop 36)319 (list (car callargs) (qnode 1))))))))320 (rewrite 'chicken.base#add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_s_a_i_plus"))321 (rewrite 'chicken.base#sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_s_a_i_minus")))322323(let ()324 (define (eqv?-id db classargs cont callargs)325 ;; (eqv? <var> <var>) -> (quote #t) [two identical objects]326 ;; (eqv? ...) -> (##core#inline "C_eqp" ...)327 ;; [one argument is a constant and either immediate or not a number]328 (and (= (length callargs) 2)329 (let ((arg1 (first callargs))330 (arg2 (second callargs)) )331 (or (and (eq? '##core#variable (node-class arg1))332 (eq? '##core#variable (node-class arg2))333 (equal? (node-parameters arg1) (node-parameters arg2))334 (make-node '##core#call (list #t) (list cont (qnode #t))) )335 (and (or (and (eq? 'quote (node-class arg1))336 (let ((p1 (first (node-parameters arg1))))337 (or (immediate? p1) (not (number? p1)))) )338 (and (eq? 'quote (node-class arg2))339 (let ((p2 (first (node-parameters arg2))))340 (or (immediate? p2) (not (number? p2)))) ) )341 (make-node342 '##core#call (list #t)343 (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )344 (rewrite 'scheme#eqv? 8 eqv?-id)345 (rewrite '##sys#eqv? 8 eqv?-id))346347(rewrite348 'scheme#equal? 8349 (lambda (db classargs cont callargs)350 ;; (equal? <var> <var>) -> (quote #t)351 ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol]352 ;; (equal? ...) -> (##core#inline "C_i_equalp" ...)353 (and (= (length callargs) 2)354 (let ([arg1 (first callargs)]355 [arg2 (second callargs)] )356 (or (and (eq? '##core#variable (node-class arg1))357 (eq? '##core#variable (node-class arg2))358 (equal? (node-parameters arg1) (node-parameters arg2))359 (make-node '##core#call (list #t) (list cont (qnode #t))) )360 (and (or (and (eq? 'quote (node-class arg1))361 (let ([f (first (node-parameters arg1))])362 (or (immediate? f) (symbol? f)) ) )363 (and (eq? 'quote (node-class arg2))364 (let ([f (first (node-parameters arg2))])365 (or (immediate? f) (symbol? f)) ) ) )366 (make-node367 '##core#call (list #t)368 (list cont (make-node '##core#inline '("C_eqp") callargs)) ) )369 (make-node370 '##core#call (list #t)371 (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )372373(let ()374 (define (rewrite-apply db classargs cont callargs)375 ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...)376 ;; (apply ...) -> ((##core#proc "C_apply") ...)377 ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst)378 ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst)379 (and (pair? callargs)380 (let ([lastarg (last callargs)]381 [proc (car callargs)] )382 (if (eq? 'quote (node-class lastarg))383 (make-node384 '##core#call (list #f)385 (cons* (first callargs)386 cont387 (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )388 (or (and (eq? '##core#variable (node-class proc))389 (= 2 (length callargs))390 (let ([name (car (node-parameters proc))])391 (and (memq name '(values ##sys#values))392 (intrinsic? name)393 (make-node394 '##core#call (list #t)395 (list (make-node '##core#proc '("C_apply_values" #t) '())396 cont397 (cadr callargs) ) ) ) ) )398 (make-node399 '##core#call (list #t)400 (cons* (make-node '##core#proc '("C_apply" #t) '())401 cont callargs) ) ) ) ) ) )402 (rewrite 'scheme#apply 8 rewrite-apply)403 (rewrite '##sys#apply 8 rewrite-apply) )404405(let ()406 (define (rewrite-c..r op iop1 iop2)407 (rewrite408 op 8409 (lambda (db classargs cont callargs)410 ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe]411 ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe]412 (and (= (length callargs) 1)413 (call-with-current-continuation414 (lambda (return)415 (let ((arg (first callargs)))416 (make-node417 '##core#call (list #t)418 (list419 cont420 (cond [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]421 [iop1 (make-node '##core#inline (list iop1) callargs)]422 [else (return #f)] ) ) ) ) ) ) ) ) ) )423424 (rewrite-c..r 'scheme#car "C_i_car" "C_u_i_car")425 (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car")426 (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr")427 (rewrite-c..r 'scheme#cadr "C_i_cadr" "C_u_i_cadr")428 (rewrite-c..r 'scheme#caddr "C_i_caddr" "C_u_i_caddr")429 (rewrite-c..r 'scheme#cadddr "C_i_cadddr" "C_u_i_cadddr") )430431(let ((rvalues432 (lambda (db classargs cont callargs)433 ;; (values <x>) -> <x>434 (and (= (length callargs) 1)435 (make-node '##core#call (list #t) (cons cont callargs) ) ) ) ) )436 (rewrite 'scheme#values 8 rvalues)437 (rewrite '##sys#values 8 rvalues) )438439(let ()440 (define (rewrite-c-w-v db classargs cont callargs)441 ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) [<var2> <k0> r]))) [<var1> k])442 ;; - if <var2> is a known lambda of a single argument443 (and (= 2 (length callargs))444 (let ((arg1 (car callargs))445 (arg2 (cadr callargs)) )446 (and (eq? '##core#variable (node-class arg1)) ; probably not needed447 (eq? '##core#variable (node-class arg2))448 (and-let* ((sym (car (node-parameters arg2)))449 (val (db-get db sym 'value)) )450 (and (eq? '##core#lambda (node-class val))451 (let ((llist (third (node-parameters val))))452 (and (list? llist)453 (= 2 (length llist))454 (let ((tmp (gensym))455 (tmpk (gensym 'r)) )456 (debugging 'o "removing single-valued `call-with-values'" (node-parameters val))457 (make-node458 'let (list tmp)459 (list (make-node460 '##core#lambda461 (list (gensym 'f_) #f (list tmpk) 0)462 (list (make-node463 '##core#call (list #t)464 (list arg2 cont (varnode tmpk)) ) ) )465 (make-node466 '##core#call (list #t)467 (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )468 (rewrite 'scheme#call-with-values 8 rewrite-c-w-v)469 (rewrite '##sys#call-with-values 8 rewrite-c-w-v) )470471(rewrite 'scheme#values 13 #f "C_values" #t)472(rewrite '##sys#values 13 #f "C_values" #t)473(rewrite 'scheme#call-with-values 13 2 "C_u_call_with_values" #f)474(rewrite 'scheme#call-with-values 13 2 "C_call_with_values" #t)475(rewrite '##sys#call-with-values 13 2 "C_u_call_with_values" #f)476(rewrite '##sys#call-with-values 13 2 "C_call_with_values" #t)477(rewrite 'chicken.continuation#continuation-graft 13 2 "C_continuation_graft" #t)478479(rewrite 'scheme#caar 2 1 "C_u_i_caar" #f)480(rewrite 'scheme#cdar 2 1 "C_u_i_cdar" #f)481(rewrite 'scheme#cddr 2 1 "C_u_i_cddr" #f)482(rewrite 'scheme#caaar 2 1 "C_u_i_caaar" #f)483(rewrite 'scheme#cadar 2 1 "C_u_i_cadar" #f)484(rewrite 'scheme#caddr 2 1 "C_u_i_caddr" #f)485(rewrite 'scheme#cdaar 2 1 "C_u_i_cdaar" #f)486(rewrite 'scheme#cdadr 2 1 "C_u_i_cdadr" #f)487(rewrite 'scheme#cddar 2 1 "C_u_i_cddar" #f)488(rewrite 'scheme#cdddr 2 1 "C_u_i_cdddr" #f)489(rewrite 'scheme#caaaar 2 1 "C_u_i_caaaar" #f)490(rewrite 'scheme#caadar 2 1 "C_u_i_caadar" #f)491(rewrite 'scheme#caaddr 2 1 "C_u_i_caaddr" #f)492(rewrite 'scheme#cadaar 2 1 "C_u_i_cadaar" #f)493(rewrite 'scheme#cadadr 2 1 "C_u_i_cadadr" #f)494(rewrite 'scheme#caddar 2 1 "C_u_i_caddar" #f)495(rewrite 'scheme#cadddr 2 1 "C_u_i_cadddr" #f)496(rewrite 'scheme#cdaaar 2 1 "C_u_i_cdaaar" #f)497(rewrite 'scheme#cdaadr 2 1 "C_u_i_cdaadr" #f)498(rewrite 'scheme#cdadar 2 1 "C_u_i_cdadar" #f)499(rewrite 'scheme#cdaddr 2 1 "C_u_i_cdaddr" #f)500(rewrite 'scheme#cddaar 2 1 "C_u_i_cddaar" #f)501(rewrite 'scheme#cddadr 2 1 "C_u_i_cddadr" #f)502(rewrite 'scheme#cdddar 2 1 "C_u_i_cdddar" #f)503(rewrite 'scheme#cddddr 2 1 "C_u_i_cddddr" #f)504505(rewrite 'scheme#caar 2 1 "C_i_caar" #t)506(rewrite 'scheme#cdar 2 1 "C_i_cdar" #t)507(rewrite 'scheme#cddr 2 1 "C_i_cddr" #t)508(rewrite 'scheme#cdddr 2 1 "C_i_cdddr" #t)509(rewrite 'scheme#cddddr 2 1 "C_i_cddddr" #t)510511(rewrite 'scheme#cdr 2 1 "C_u_i_cdr" #f)512(rewrite 'scheme#cdr 2 1 "C_i_cdr" #t)513514(rewrite 'scheme#eq? 1 2 "C_eqp")515(rewrite '##sys#eq? 1 2 "C_eqp")516(rewrite 'scheme#eqv? 1 2 "C_i_eqvp")517(rewrite '##sys#eqv? 1 2 "C_i_eqvp")518519(rewrite 'scheme#list-ref 2 2 "C_u_i_list_ref" #f)520(rewrite 'scheme#list-ref 2 2 "C_i_list_ref" #t)521(rewrite 'scheme#null? 2 1 "C_i_nullp" #t)522(rewrite '##sys#null? 2 1 "C_i_nullp" #t)523(rewrite 'scheme#length 2 1 "C_i_length" #t)524(rewrite 'scheme#not 2 1 "C_i_not"#t )525(rewrite 'scheme#char? 2 1 "C_charp" #t)526(rewrite 'scheme#string? 2 1 "C_i_stringp" #t)527(rewrite 'chicken.locative#locative? 2 1 "C_i_locativep" #t)528(rewrite 'scheme#symbol? 2 1 "C_i_symbolp" #t)529(rewrite 'scheme#vector? 2 1 "C_i_vectorp" #t)530(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t)531(rewrite '##sys#srfi-4-vector? 2 1 "C_i_srfi_4_vectorp" #t)532(rewrite 'srfi-4#u8vector? 2 1 "C_i_u8vectorp" #t)533(rewrite 'srfi-4#s8vector? 2 1 "C_i_s8vectorp" #t)534(rewrite 'srfi-4#u16vector? 2 1 "C_i_u16vectorp" #t)535(rewrite 'srfi-4#s16vector? 2 1 "C_i_s16vectorp" #t)536(rewrite 'srfi-4#u32vector? 2 1 "C_i_u32vectorp" #t)537(rewrite 'srfi-4#s32vector? 2 1 "C_i_s32vectorp" #t)538(rewrite 'srfi-4#u64vector? 2 1 "C_i_u64vectorp" #t)539(rewrite 'srfi-4#s64vector? 2 1 "C_i_s64vectorp" #t)540(rewrite 'srfi-4#f32vector? 2 1 "C_i_f32vectorp" #t)541(rewrite 'srfi-4#f64vector? 2 1 "C_i_f64vectorp" #t)542(rewrite 'scheme#pair? 2 1 "C_i_pairp" #t)543(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)544(rewrite 'chicken.base#weak-pair? 2 1 "C_i_weak_pairp" #t)545(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t)546(rewrite 'chicken.base#port? 2 1 "C_i_portp" #t)547(rewrite 'scheme#boolean? 2 1 "C_booleanp" #t)548(rewrite 'scheme#number? 2 1 "C_i_numberp" #t)549(rewrite 'scheme#complex? 2 1 "C_i_numberp" #t)550(rewrite 'scheme#rational? 2 1 "C_i_rationalp" #t)551(rewrite 'scheme#real? 2 1 "C_i_realp" #t)552(rewrite 'scheme#integer? 2 1 "C_i_integerp" #t)553(rewrite 'chicken.base#exact-integer? 2 1 "C_i_exact_integerp" #t)554(rewrite 'chicken.base#flonum? 2 1 "C_i_flonump" #t)555(rewrite 'chicken.base#fixnum? 2 1 "C_fixnump" #t)556(rewrite 'chicken.base#bignum? 2 1 "C_i_bignump" #t)557(rewrite 'chicken.base#cplxnum? 2 1 "C_i_cplxnump" #t)558(rewrite 'chicken.base#ratnum? 2 1 "C_i_ratnump" #t)559(rewrite 'chicken.base#nan? 2 1 "C_i_nanp" #f)560(rewrite 'chicken.base#finite? 2 1 "C_i_finitep" #f)561(rewrite 'chicken.base#infinite? 2 1 "C_i_infinitep" #f)562(rewrite 'chicken.flonum#fpinteger? 2 1 "C_u_i_fpintegerp" #f)563(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t)564(rewrite 'pointer? 2 1 "C_i_safe_pointerp" #t)565(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t)566(rewrite 'scheme#exact? 2 1 "C_i_exactp" #t)567(rewrite 'scheme#exact? 2 1 "C_u_i_exactp" #f)568(rewrite 'scheme#inexact? 2 1 "C_i_inexactp" #t)569(rewrite 'scheme#inexact? 2 1 "C_u_i_inexactp" #f)570(rewrite 'scheme#list? 2 1 "C_i_listp" #t)571(rewrite 'scheme#eof-object? 2 1 "C_eofp" #t)572(rewrite 'chicken.base#bwp-object? 2 1 "C_bwpp" #t)573(rewrite 'scheme#string-ref 2 2 "C_subchar" #f)574(rewrite 'scheme#string-ref 2 2 "C_i_string_ref" #t)575(rewrite 'scheme#string-set! 2 3 "C_setsubchar" #f)576(rewrite 'scheme#string-set! 2 3 "C_i_string_set" #t)577(rewrite 'scheme#vector-ref 2 2 "C_slot" #f)578(rewrite 'scheme#vector-ref 2 2 "C_i_vector_ref" #t)579(rewrite 'scheme#char=? 2 2 "C_u_i_char_equalp" #f)580(rewrite 'scheme#char=? 2 2 "C_i_char_equalp" #t)581(rewrite 'scheme#char>? 2 2 "C_u_i_char_greaterp" #f)582(rewrite 'scheme#char>? 2 2 "C_i_char_greaterp" #t)583(rewrite 'scheme#char<? 2 2 "C_u_i_char_lessp" #f)584(rewrite 'scheme#char<? 2 2 "C_i_char_lessp" #t)585(rewrite 'scheme#char>=? 2 2 "C_u_i_char_greater_or_equal_p" #f)586(rewrite 'scheme#char>=? 2 2 "C_i_char_greater_or_equal_p" #t)587(rewrite 'scheme#char<=? 2 2 "C_u_i_char_less_or_equal_p" #f)588(rewrite 'scheme#char<=? 2 2 "C_i_char_less_or_equal_p" #t)589(rewrite '##sys#slot 2 2 "C_slot" #t) ; consider as safe, the primitive is unsafe anyway.590(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t) ;XXX must be safe for pattern matcher (anymore?)591(rewrite '##sys#size 2 1 "C_block_size" #t)592(rewrite 'chicken.fixnum#fxnot 2 1 "C_fixnum_not" #t)593(rewrite 'chicken.fixnum#fx* 2 2 "C_fixnum_times" #t)594(rewrite 'chicken.fixnum#fx+? 2 2 "C_i_o_fixnum_plus" #t)595(rewrite 'chicken.fixnum#fx-? 2 2 "C_i_o_fixnum_difference" #t)596(rewrite 'chicken.fixnum#fx*? 2 2 "C_i_o_fixnum_times" #t)597(rewrite 'chicken.fixnum#fx/? 2 2 "C_i_o_fixnum_quotient" #t)598(rewrite 'chicken.fixnum#fx= 2 2 "C_eqp" #t)599(rewrite 'chicken.fixnum#fx> 2 2 "C_fixnum_greaterp" #t)600(rewrite 'chicken.fixnum#fx< 2 2 "C_fixnum_lessp" #t)601(rewrite 'chicken.fixnum#fx>= 2 2 "C_fixnum_greater_or_equal_p" #t)602(rewrite 'chicken.fixnum#fx<= 2 2 "C_fixnum_less_or_equal_p" #t)603(rewrite 'chicken.flonum#fp= 2 2 "C_flonum_equalp" #f)604(rewrite 'chicken.flonum#fp> 2 2 "C_flonum_greaterp" #f)605(rewrite 'chicken.flonum#fp< 2 2 "C_flonum_lessp" #f)606(rewrite 'chicken.flonum#fp>= 2 2 "C_flonum_greater_or_equal_p" #f)607(rewrite 'chicken.flonum#fp<= 2 2 "C_flonum_less_or_equal_p" #f)608(rewrite 'chicken.fixnum#fxmax 2 2 "C_i_fixnum_max" #t)609(rewrite 'chicken.fixnum#fxmin 2 2 "C_i_fixnum_min" #t)610(rewrite 'chicken.flonum#fpmax 2 2 "C_i_flonum_max" #f)611(rewrite 'chicken.flonum#fpmin 2 2 "C_i_flonum_min" #f)612(rewrite 'chicken.fixnum#fxgcd 2 2 "C_i_fixnum_gcd" #t)613(rewrite 'chicken.fixnum#fxlen 2 1 "C_i_fixnum_length" #t)614(rewrite 'scheme#char-numeric? 2 1 "C_u_i_char_numericp" #t)615(rewrite 'scheme#char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)616(rewrite 'scheme#char-whitespace? 2 1 "C_u_i_char_whitespacep" #t)617(rewrite 'scheme#char-upper-case? 2 1 "C_u_i_char_upper_casep" #t)618(rewrite 'scheme#char-lower-case? 2 1 "C_u_i_char_lower_casep" #t)619(rewrite 'scheme#char-upcase 2 1 "C_u_i_char_upcase" #t)620(rewrite 'scheme#char-downcase 2 1 "C_u_i_char_downcase" #t)621(rewrite 'scheme#list-tail 2 2 "C_i_list_tail" #t)622(rewrite '##sys#structure? 2 2 "C_i_structurep" #t)623(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t)624(rewrite 'chicken.memory.representation#block-ref 2 2 "C_slot" #f) ; ok to be unsafe, lolevel is anyway625(rewrite 'chicken.memory.representation#number-of-slots 2 1 "C_block_size" #f)626627(rewrite 'scheme#assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")628(rewrite 'scheme#assv 2 2 "C_i_assv" #t)629(rewrite 'scheme#memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")630(rewrite 'scheme#memv 2 2 "C_i_memv" #t)631(rewrite 'scheme#assq 17 2 "C_i_assq" "C_u_i_assq")632(rewrite 'scheme#memq 17 2 "C_i_memq" "C_u_i_memq")633(rewrite 'scheme#assoc 2 2 "C_i_assoc" #t)634(rewrite 'scheme#member 2 2 "C_i_member" #t)635636(rewrite 'scheme#set-car! 4 '##sys#setslot 0)637(rewrite 'scheme#set-cdr! 4 '##sys#setslot 1)638(rewrite 'scheme#set-car! 17 2 "C_i_set_car" "C_u_i_set_car")639(rewrite 'scheme#set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr")640641(rewrite 'scheme#abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")642643(rewrite 'chicken.bitwise#bitwise-and 19)644(rewrite 'chicken.bitwise#bitwise-xor 19)645(rewrite 'chicken.bitwise#bitwise-ior 19)646647(rewrite 'chicken.bitwise#bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_s_a_i_bitwise_and" 5)648(rewrite 'chicken.bitwise#bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_s_a_i_bitwise_xor" 5)649(rewrite 'chicken.bitwise#bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_s_a_i_bitwise_ior" 5)650651(rewrite 'chicken.bitwise#bitwise-not 22 1 "C_s_a_i_bitwise_not" #t 5 "C_fixnum_not")652653(rewrite 'chicken.flonum#fp+ 16 2 "C_a_i_flonum_plus" #f words-per-flonum)654(rewrite 'chicken.flonum#fp- 16 2 "C_a_i_flonum_difference" #f words-per-flonum)655(rewrite 'chicken.flonum#fp* 16 2 "C_a_i_flonum_times" #f words-per-flonum)656(rewrite 'chicken.flonum#fp/ 16 2 "C_a_i_flonum_quotient" #f words-per-flonum)657(rewrite 'chicken.flonum#fp/? 16 2 "C_a_i_flonum_quotient_checked" #f words-per-flonum)658(rewrite 'chicken.flonum#fpneg 16 1 "C_a_i_flonum_negate" #f words-per-flonum)659(rewrite 'chicken.flonum#fpgcd 16 2 "C_a_i_flonum_gcd" #f words-per-flonum)660(rewrite 'chicken.flonum#fp*+ 16 3 "C_a_i_flonum_multiply_add" #f words-per-flonum)661662(rewrite 'scheme#zero? 5 "C_eqp" 0 'fixnum)663(rewrite 'scheme#zero? 2 1 "C_u_i_zerop2" #f)664(rewrite 'scheme#zero? 2 1 "C_i_zerop" #t)665(rewrite 'scheme#positive? 5 "C_fixnum_greaterp" 0 'fixnum)666(rewrite 'scheme#positive? 5 "C_flonum_greaterp" 0 'flonum)667(rewrite 'scheme#positive? 2 1 "C_i_positivep" #t)668(rewrite 'scheme#negative? 5 "C_fixnum_lessp" 0 'fixnum)669(rewrite 'scheme#negative? 5 "C_flonum_lessp" 0 'flonum)670(rewrite 'scheme#negative? 2 1 "C_i_negativep" #t)671672(rewrite 'scheme#vector-length 6 "C_fix" "C_header_size" #f)673(rewrite 'scheme#string-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" #t)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-byte-vector 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-byte-vector 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)705706(rewrite 'scheme#= 9 "C_eqp" "C_i_equalp" #t #t)707(rewrite 'scheme#> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f)708(rewrite 'scheme#< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f)709(rewrite 'scheme#>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f)710(rewrite 'scheme#<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f)711712(rewrite 'setter 11 1 '##sys#setter #t)713(rewrite 'scheme#for-each 11 2 '##sys#for-each #t)714(rewrite 'scheme#map 11 2 '##sys#map #t)715(rewrite 'chicken.memory.representation#block-set! 11 3 '##sys#setslot #t)716(rewrite '##sys#block-set! 11 3 '##sys#setslot #f)717(rewrite 'chicken.memory.representation#make-record-instance 11 #f '##sys#make-structure #f)718(rewrite 'scheme#substring 11 3 '##sys#substring #f)719(rewrite 'scheme#string-append 11 2 '##sys#string-append #f)720(rewrite 'scheme#string->list 11 1 '##sys#string->list #t)721(rewrite 'scheme#list->string 11 1 '##sys#list->string #t)722723(rewrite 'scheme#vector-set! 11 3 '##sys#setslot #f)724(rewrite 'scheme#vector-set! 2 3 "C_i_vector_set" #t)725726(rewrite 'scheme#gcd 12 '##sys#gcd #t 2)727(rewrite 'scheme#lcm 12 '##sys#lcm #t 2)728(rewrite 'chicken.base#identity 12 #f #t 1)729730(rewrite 'scheme#gcd 19)731(rewrite 'scheme#lcm 19)732733(rewrite 'scheme#gcd 18 0)734(rewrite 'scheme#lcm 18 1)735(rewrite 'scheme#list 18 '())736737(rewrite738 'scheme#* 8739 (lambda (db classargs cont callargs)740 ;; (*) -> 1741 ;; (* <x>) -> <x>742 ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]743 ;; - Remove "1" from arguments.744 ;; - Replace multiplications with 2 by shift left. [fixnum-mode]745 (let ((callargs746 (filter747 (lambda (x)748 (not (and (eq? 'quote (node-class x))749 (eq? 1 (first (node-parameters x))) ) ) )750 callargs) ) )751 (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode 0))))752 ((null? (cdr callargs))753 (make-node '##core#call (list #t) (list cont (first callargs))) )754 ((eq? number-type 'fixnum)755 (make-node756 '##core#call (list #t)757 (list758 cont759 (fold-inner760 (lambda (x y)761 (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))762 (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))763 (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )764 callargs) ) ) )765 (else #f) ) ) ) )766767(rewrite768 'scheme#+ 8769 (lambda (db classargs cont callargs)770 ;; (+ <x>) -> <x>771 ;; (+ <x1> ...) -> (##core#inline "C_fixnum_plus" <x1> (##core#inline "C_fixnum_plus" ...)) [fixnum-mode]772 ;; (+ <x1> ...) -> (##core#inline "C_u_fixnum_plus" <x1> (##core#inline "C_u_fixnum_plus" ...))773 ;; [fixnum-mode + unsafe]774 ;; - Remove "0" from arguments, if more than 1.775 (cond ((or (null? callargs) (not (eq? number-type 'fixnum))) #f)776 ((null? (cdr callargs))777 (make-node778 '##core#call (list #t)779 (list cont780 (make-node '##core#inline781 (if unsafe '("C_u_fixnum_plus") '("C_fixnum_plus"))782 callargs)) ) )783 (else784 (let ((callargs785 (cons (car callargs)786 (filter787 (lambda (x)788 (not (and (eq? 'quote (node-class x))789 (zero? (first (node-parameters x))) ) ) )790 (cdr callargs) ) ) ) )791 (and (>= (length callargs) 2)792 (make-node793 '##core#call (list #t)794 (list795 cont796 (fold-inner797 (lambda (x y)798 (make-node '##core#inline799 (if unsafe '("C_u_fixnum_plus") '("C_fixnum_plus"))800 (list x y) ) )801 callargs) ) ) ) ) ) ) ) )802803(rewrite804 'scheme#- 8805 (lambda (db classargs cont callargs)806 ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>) [fixnum-mode]807 ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>) [fixnum-mode + unsafe]808 ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]809 ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...))810 ;; [fixnum-mode + unsafe]811 ;; - Remove "0" from arguments, if more than 1.812 (cond ((or (null? callargs) (not (eq? number-type 'fixnum))) #f)813 ((null? (cdr callargs))814 (make-node815 '##core#call (list #t)816 (list cont817 (make-node '##core#inline818 (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))819 callargs)) ) )820 (else821 (let ((callargs822 (cons (car callargs)823 (filter824 (lambda (x)825 (not (and (eq? 'quote (node-class x))826 (zero? (first (node-parameters x))) ) ) )827 (cdr callargs) ) ) ) )828 (and (>= (length callargs) 2)829 (make-node830 '##core#call (list #t)831 (list832 cont833 (fold-inner834 (lambda (x y)835 (make-node '##core#inline836 (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))837 (list x y) ) )838 callargs) ) ) ) ) ) ) ) )839840(let ()841 (define (rewrite-div db classargs cont callargs)842 ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]843 ;; - Remove "1" from arguments, if more than 1.844 ;; - Replace divisions by 2 with shift right. [fixnum-mode]845 (and (eq? number-type 'fixnum)846 (>= (length callargs) 2)847 (let ((callargs848 (cons (car callargs)849 (filter850 (lambda (x)851 (not (and (eq? 'quote (node-class x))852 (eq? 1 (first (node-parameters x))) ) ) )853 (cdr callargs) ) ) ) )854 (and (>= (length callargs) 2)855 (make-node856 '##core#call (list #t)857 (list858 cont859 (fold-inner860 (lambda (x y)861 (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))862 (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))863 (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )864 callargs) ) ) ) ) ) )865 (rewrite 'scheme#/ 8 rewrite-div)866 (rewrite '##sys#/-2 8 rewrite-div))867868(rewrite869 'scheme#quotient 8870 (lambda (db classargs cont callargs)871 ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]872 ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]873 (and (eq? 'fixnum number-type)874 (= (length callargs) 2)875 (make-node876 '##core#call (list #t)877 (let ([arg2 (second callargs)])878 (list cont879 (if (and (eq? 'quote (node-class arg2))880 (eq? 2 (first (node-parameters arg2))) )881 (make-node882 '##core#inline '("C_fixnum_shift_right")883 (list (first callargs) (qnode 1)) )884 (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) ) ) ) )885886(rewrite 'scheme#+ 19)887(rewrite 'scheme#- 19)888(rewrite 'scheme#* 19)889(rewrite 'scheme#/ 19)890891(rewrite 'scheme#+ 16 2 "C_s_a_i_plus" #t 29)892(rewrite 'scheme#- 16 2 "C_s_a_i_minus" #t 29)893(rewrite 'scheme#* 16 2 "C_s_a_i_times" #t 33)894(rewrite 'scheme#quotient 16 2 "C_s_a_i_quotient" #t 5)895(rewrite 'scheme#remainder 16 2 "C_s_a_i_remainder" #t 5)896(rewrite 'scheme#modulo 16 2 "C_s_a_i_modulo" #t 5)897898(rewrite 'scheme#= 17 2 "C_i_nequalp")899(rewrite 'scheme#> 17 2 "C_i_greaterp")900(rewrite 'scheme#< 17 2 "C_i_lessp")901(rewrite 'scheme#>= 17 2 "C_i_greater_or_equalp")902(rewrite 'scheme#<= 17 2 "C_i_less_or_equalp")903904(rewrite 'scheme#= 13 #f "C_nequalp" #t)905(rewrite 'scheme#> 13 #f "C_greaterp" #t)906(rewrite 'scheme#< 13 #f "C_lessp" #t)907(rewrite 'scheme#>= 13 #f "C_greater_or_equal_p" #t)908(rewrite 'scheme#<= 13 #f "C_less_or_equal_p" #t)909910(rewrite 'scheme#* 13 #f "C_times" #t)911(rewrite 'scheme#+ 13 #f "C_plus" #t)912(rewrite 'scheme#- 13 '(1 . #f) "C_minus" #t)913914(rewrite 'scheme#number->string 13 '(1 . 2) "C_number_to_string" #t)915(rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t)916(rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t)917(rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t)918(rewrite 'chicken.platform#return-to-host 13 0 "C_return_to_host" #t)919(rewrite '##sys#context-switch 13 1 "C_context_switch" #t)920(rewrite '##sys#intern-symbol 13 1 "C_string_to_symbol" #t)921(rewrite '##sys#make-symbol 13 1 "C_make_symbol" #t)922923(rewrite 'scheme#even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")924(rewrite 'scheme#odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")925(rewrite 'scheme#remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")926927(rewrite 'scheme#even? 17 1 "C_i_evenp")928(rewrite 'scheme#odd? 17 1 "C_i_oddp")929930(rewrite 'chicken.fixnum#fxodd? 2 1 "C_i_fixnumoddp" #t)931(rewrite 'chicken.fixnum#fxeven? 2 1 "C_i_fixnumevenp" #t)932933(rewrite 'scheme#floor 15 'flonum 'fixnum 'chicken.flonum#fpfloor #f)934(rewrite 'scheme#ceiling 15 'flonum 'fixnum 'chicken.flonum#fpceiling #f)935(rewrite 'scheme#truncate 15 'flonum 'fixnum 'chicken.flonum#fptruncate #f)936937(rewrite 'chicken.flonum#fpsin 16 1 "C_a_i_flonum_sin" #f words-per-flonum)938(rewrite 'chicken.flonum#fpcos 16 1 "C_a_i_flonum_cos" #f words-per-flonum)939(rewrite 'chicken.flonum#fptan 16 1 "C_a_i_flonum_tan" #f words-per-flonum)940(rewrite 'chicken.flonum#fpasin 16 1 "C_a_i_flonum_asin" #f words-per-flonum)941(rewrite 'chicken.flonum#fpacos 16 1 "C_a_i_flonum_acos" #f words-per-flonum)942(rewrite 'chicken.flonum#fpatan 16 1 "C_a_i_flonum_atan" #f words-per-flonum)943(rewrite 'chicken.flonum#fpatan2 16 2 "C_a_i_flonum_atan2" #f words-per-flonum)944(rewrite 'chicken.flonum#fpexp 16 1 "C_a_i_flonum_exp" #f words-per-flonum)945(rewrite 'chicken.flonum#fpexpt 16 2 "C_a_i_flonum_expt" #f words-per-flonum)946(rewrite 'chicken.flonum#fplog 16 1 "C_a_i_flonum_log" #f words-per-flonum)947(rewrite 'chicken.flonum#fpsqrt 16 1 "C_a_i_flonum_sqrt" #f words-per-flonum)948(rewrite 'chicken.flonum#fpabs 16 1 "C_a_i_flonum_abs" #f words-per-flonum)949(rewrite 'chicken.flonum#fptruncate 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)950(rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_round" #f words-per-flonum)951(rewrite 'chicken.flonum#fpceiling 16 1 "C_a_i_flonum_ceiling" #f words-per-flonum)952(rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_floor" #f words-per-flonum)953954(rewrite 'scheme#cons 16 2 "C_a_i_cons" #t 3)955(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)956(rewrite 'chicken.base#weak-cons 16 2 "C_a_i_weak_cons" #t 3)957(rewrite 'scheme#list 16 #f "C_a_i_list" #t '(0 3) #t)958(rewrite '##sys#list 16 #f "C_a_i_list" #t '(0 3))959(rewrite 'scheme#vector 16 #f "C_a_i_vector" #t #t #t)960(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)961(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t #t)962(rewrite 'scheme#string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care963(rewrite 'chicken.memory#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)964(rewrite 'chicken.memory#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)965(rewrite 'chicken.memory#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)966(rewrite 'chicken.locative#locative-ref 16 1 "C_a_i_locative_ref" #t 6)967968(rewrite 'chicken.memory#pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)969(rewrite 'chicken.memory#pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)970(rewrite 'chicken.memory#pointer-u16-ref 2 1 "C_u_i_pointer_u16_ref" #f)971(rewrite 'chicken.memory#pointer-s16-ref 2 1 "C_u_i_pointer_s16_ref" #f)972(rewrite 'chicken.memory#pointer-u8-set! 2 2 "C_u_i_pointer_u8_set" #f)973(rewrite 'chicken.memory#pointer-s8-set! 2 2 "C_u_i_pointer_s8_set" #f)974(rewrite 'chicken.memory#pointer-u16-set! 2 2 "C_u_i_pointer_u16_set" #f)975(rewrite 'chicken.memory#pointer-s16-set! 2 2 "C_u_i_pointer_s16_set" #f)976(rewrite 'chicken.memory#pointer-u32-set! 2 2 "C_u_i_pointer_u32_set" #f)977(rewrite 'chicken.memory#pointer-s32-set! 2 2 "C_u_i_pointer_s32_set" #f)978(rewrite 'chicken.memory#pointer-f32-set! 2 2 "C_u_i_pointer_f32_set" #f)979(rewrite 'chicken.memory#pointer-f64-set! 2 2 "C_u_i_pointer_f64_set" #f)980981;; on 32-bit platforms, 32-bit integers do not always fit in a word,982;; bignum1 and bignum wrapper (5 words) may be used instead983(rewrite 'chicken.memory#pointer-u32-ref 16 1 "C_a_u_i_pointer_u32_ref" #f min-words-per-bignum)984(rewrite 'chicken.memory#pointer-s32-ref 16 1 "C_a_u_i_pointer_s32_ref" #f min-words-per-bignum)985986(rewrite 'chicken.memory#pointer-f32-ref 16 1 "C_a_u_i_pointer_f32_ref" #f words-per-flonum)987(rewrite 'chicken.memory#pointer-f64-ref 16 1 "C_a_u_i_pointer_f64_ref" #f words-per-flonum)988989(rewrite990 '##sys#setslot 8991 (lambda (db classargs cont callargs)992 ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>)993 ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)994 (and (= (length callargs) 3)995 (make-node996 '##core#call (list #t)997 (list cont998 (make-node999 '##core#inline1000 (let ([val (third callargs)])1001 (if (and (eq? 'quote (node-class val))1002 (immediate? (first (node-parameters val))) )1003 '("C_i_set_i_slot")1004 '("C_i_setslot") ) )1005 callargs) ) ) ) ) )10061007(rewrite 'chicken.fixnum#fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus")1008(rewrite 'chicken.fixnum#fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference")1009(rewrite 'chicken.fixnum#fxshl 17 2 "C_fixnum_shift_left")1010(rewrite 'chicken.fixnum#fxshr 17 2 "C_fixnum_shift_right")1011(rewrite 'chicken.fixnum#fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate")1012(rewrite 'chicken.fixnum#fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor")1013(rewrite 'chicken.fixnum#fxand 17 2 "C_fixnum_and" "C_u_fixnum_and")1014(rewrite 'chicken.fixnum#fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")1015(rewrite 'chicken.fixnum#fx/ 17 2 "C_fixnum_divide" "C_u_fixnum_divide")1016(rewrite 'chicken.fixnum#fxmod 17 2 "C_fixnum_modulo" "C_u_fixnum_modulo")1017(rewrite 'chicken.fixnum#fxrem 17 2 "C_i_fixnum_remainder_checked")10181019(rewrite1020 'chicken.bitwise#arithmetic-shift 81021 (lambda (db classargs cont callargs)1022 ;; (arithmetic-shift <x> <-int>)1023 ;; -> (##core#inline "C_fixnum_shift_right" <x> -<int>)1024 ;; (arithmetic-shift <x> <+int>)1025 ;; -> (##core#inline "C_fixnum_shift_left" <x> <int>)1026 ;; _ -> (##core#inline "C_i_fixnum_arithmetic_shift" <x> <y>)1027 ;;1028 ;; not in fixnum-mode:1029 ;; _ -> (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 6) <x> <y>)1030 (and (= 2 (length callargs))1031 (let ((val (second callargs)))1032 (make-node1033 '##core#call (list #t)1034 (list cont1035 (or (and-let* (((eq? 'quote (node-class val)))1036 ((eq? number-type 'fixnum))1037 (n (first (node-parameters val)))1038 ((and (fixnum? n) (not (big-fixnum? n)))) )1039 (if (negative? n)1040 (make-node1041 '##core#inline '("C_fixnum_shift_right")1042 (list (first callargs) (qnode (- n))) )1043 (make-node1044 '##core#inline '("C_fixnum_shift_left")1045 (list (first callargs) val) ) ) )1046 (if (eq? number-type 'fixnum)1047 (make-node '##core#inline1048 '("C_i_fixnum_arithmetic_shift") callargs)1049 (make-node '##core#inline_allocate1050 (list "C_s_a_i_arithmetic_shift" 5)1051 callargs) ) ) ) ) ) ) ) )10521053(rewrite '##sys#byte 17 2 "C_subbyte")1054(rewrite '##sys#setbyte 17 3 "C_setbyte")1055(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")1056(rewrite '##sys#peek-byte 17 2 "C_peek_byte")1057(rewrite 'chicken.memory#pointer->object 17 2 "C_pointer_to_object")1058(rewrite '##sys#setislot 17 3 "C_i_set_i_slot")1059(rewrite '##sys#poke-integer 17 3 "C_poke_integer")1060(rewrite '##sys#poke-double 17 3 "C_poke_double")1061(rewrite 'scheme#string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p")1062(rewrite 'scheme#string-ci=? 17 2 "C_i_string_ci_equal_p")1063(rewrite '##sys#permanent? 17 1 "C_permanentp")1064(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp")1065(rewrite '##sys#immediate? 17 1 "C_immp")1066(rewrite 'chicken.locative#locative->object 17 1 "C_i_locative_to_object")1067(rewrite 'chicken.locative#locative->object 17 1 "C_i_locative_to_object")1068(rewrite 'chicken.locative#locative-index 17 1 "C_i_locative_index")1069(rewrite 'chicken.locative#locative-set! 17 2 "C_i_locative_set")1070(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp")1071(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")1072(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")1073(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")1074(rewrite '##sys#foreign-struct-wrapper-argument 17 2 "C_i_foreign_struct_wrapper_argumentp")1075(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")1076(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")1077(rewrite '##sys#foreign-ranged-integer-argument 17 2 "C_i_foreign_ranged_integer_argumentp")1078(rewrite '##sys#foreign-unsigned-ranged-integer-argument 17 2 "C_i_foreign_unsigned_ranged_integer_argumentp")10791080(rewrite 'chicken.blob#blob-size 2 1 "C_block_size" #f)10811082;; TODO: Move this stuff to types.db1083(rewrite 'srfi-4#u8vector-ref 2 2 "C_u_i_u8vector_ref" #f)1084(rewrite 'srfi-4#u8vector-ref 2 2 "C_i_u8vector_ref" #t)1085(rewrite 'srfi-4#s8vector-ref 2 2 "C_u_i_s8vector_ref" #f)1086(rewrite 'srfi-4#s8vector-ref 2 2 "C_i_s8vector_ref" #t)1087(rewrite 'srfi-4#u16vector-ref 2 2 "C_u_i_u16vector_ref" #f)1088(rewrite 'srfi-4#u16vector-ref 2 2 "C_i_u16vector_ref" #t)1089(rewrite 'srfi-4#s16vector-ref 2 2 "C_u_i_s16vector_ref" #f)1090(rewrite 'srfi-4#s16vector-ref 2 2 "C_i_s16vector_ref" #t)10911092(rewrite 'srfi-4#u32vector-ref 16 2 "C_a_i_u32vector_ref" #t min-words-per-bignum)1093(rewrite 'srfi-4#s32vector-ref 16 2 "C_a_i_s32vector_ref" #t min-words-per-bignum)10941095(rewrite 'srfi-4#f32vector-ref 16 2 "C_a_u_i_f32vector_ref" #f words-per-flonum)1096(rewrite 'srfi-4#f32vector-ref 16 2 "C_a_i_f32vector_ref" #t words-per-flonum)1097(rewrite 'srfi-4#f64vector-ref 16 2 "C_a_u_i_f64vector_ref" #f words-per-flonum)1098(rewrite 'srfi-4#f64vector-ref 16 2 "C_a_i_f64vector_ref" #t words-per-flonum)10991100(rewrite 'srfi-4#u8vector-set! 2 3 "C_u_i_u8vector_set" #f)1101(rewrite 'srfi-4#u8vector-set! 2 3 "C_i_u8vector_set" #t)1102(rewrite 'srfi-4#s8vector-set! 2 3 "C_u_i_s8vector_set" #f)1103(rewrite 'srfi-4#s8vector-set! 2 3 "C_i_s8vector_set" #t)1104(rewrite 'srfi-4#u16vector-set! 2 3 "C_u_i_u16vector_set" #f)1105(rewrite 'srfi-4#u16vector-set! 2 3 "C_i_u16vector_set" #t)1106(rewrite 'srfi-4#s16vector-set! 2 3 "C_u_i_s16vector_set" #f)1107(rewrite 'srfi-4#s16vector-set! 2 3 "C_i_s16vector_set" #t)1108(rewrite 'srfi-4#u32vector-set! 2 3 "C_u_i_u32vector_set" #f)1109(rewrite 'srfi-4#u32vector-set! 2 3 "C_i_u32vector_set" #t)1110(rewrite 'srfi-4#s32vector-set! 2 3 "C_u_i_s32vector_set" #f)1111(rewrite 'srfi-4#s32vector-set! 2 3 "C_i_s32vector_set" #t)1112(rewrite 'srfi-4#u64vector-set! 2 3 "C_u_i_u64vector_set" #f)1113(rewrite 'srfi-4#u64vector-set! 2 3 "C_i_u64vector_set" #t)1114(rewrite 'srfi-4#s64vector-set! 2 3 "C_u_i_s64vector_set" #f)1115(rewrite 'srfi-4#s64vector-set! 2 3 "C_i_s64vector_set" #t)1116(rewrite 'srfi-4#f32vector-set! 2 3 "C_u_i_f32vector_set" #f)1117(rewrite 'srfi-4#f32vector-set! 2 3 "C_i_f32vector_set" #t)1118(rewrite 'srfi-4#f64vector-set! 2 3 "C_u_i_f64vector_set" #f)1119(rewrite 'srfi-4#f64vector-set! 2 3 "C_i_f64vector_set" #t)11201121(rewrite 'srfi-4#u8vector-length 2 1 "C_u_i_u8vector_length" #f)1122(rewrite 'srfi-4#u8vector-length 2 1 "C_i_u8vector_length" #t)1123(rewrite 'srfi-4#s8vector-length 2 1 "C_u_i_s8vector_length" #f)1124(rewrite 'srfi-4#s8vector-length 2 1 "C_i_s8vector_length" #t)1125(rewrite 'srfi-4#u16vector-length 2 1 "C_u_i_u16vector_length" #f)1126(rewrite 'srfi-4#u16vector-length 2 1 "C_i_u16vector_length" #t)1127(rewrite 'srfi-4#s16vector-length 2 1 "C_u_i_s16vector_length" #f)1128(rewrite 'srfi-4#s16vector-length 2 1 "C_i_s16vector_length" #t)1129(rewrite 'srfi-4#u32vector-length 2 1 "C_u_i_u32vector_length" #f)1130(rewrite 'srfi-4#u32vector-length 2 1 "C_i_u32vector_length" #t)1131(rewrite 'srfi-4#s32vector-length 2 1 "C_u_i_s32vector_length" #f)1132(rewrite 'srfi-4#s32vector-length 2 1 "C_i_s32vector_length" #t)1133(rewrite 'srfi-4#u64vector-length 2 1 "C_u_i_u64vector_length" #f)1134(rewrite 'srfi-4#u64vector-length 2 1 "C_i_u64vector_length" #t)1135(rewrite 'srfi-4#s64vector-length 2 1 "C_u_i_s64vector_length" #f)1136(rewrite 'srfi-4#s64vector-length 2 1 "C_i_s64vector_length" #t)1137(rewrite 'srfi-4#f32vector-length 2 1 "C_u_i_f32vector_length" #f)1138(rewrite 'srfi-4#f32vector-length 2 1 "C_i_f32vector_length" #t)1139(rewrite 'srfi-4#f64vector-length 2 1 "C_u_i_f64vector_length" #f)1140(rewrite 'srfi-4#f64vector-length 2 1 "C_i_f64vector_length" #t)11411142(rewrite 'chicken.base#atom? 17 1 "C_i_not_pair_p")11431144(rewrite 'srfi-4#u8vector->blob/shared 7 1 "C_slot" 1 #f)1145(rewrite 'srfi-4#s8vector->blob/shared 7 1 "C_slot" 1 #f)1146(rewrite 'srfi-4#u16vector->blob/shared 7 1 "C_slot" 1 #f)1147(rewrite 'srfi-4#s16vector->blob/shared 7 1 "C_slot" 1 #f)1148(rewrite 'srfi-4#u32vector->blob/shared 7 1 "C_slot" 1 #f)1149(rewrite 'srfi-4#s32vector->blob/shared 7 1 "C_slot" 1 #f)1150(rewrite 'srfi-4#u64vector->blob/shared 7 1 "C_slot" 1 #f)1151(rewrite 'srfi-4#s64vector->blob/shared 7 1 "C_slot" 1 #f)1152(rewrite 'srfi-4#f32vector->blob/shared 7 1 "C_slot" 1 #f)1153(rewrite 'srfi-4#f64vector->blob/shared 7 1 "C_slot" 1 #f)11541155(let ()1156 (define (rewrite-make-vector db classargs cont callargs)1157 ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>))1158 ;; - <n> should be less or equal to 32.1159 (let ([argc (length callargs)])1160 (and (pair? callargs)1161 (let ([n (first callargs)])1162 (and (eq? 'quote (node-class n))1163 (let ([tmp (gensym)]1164 [c (first (node-parameters n))] )1165 (and (fixnum? c)1166 (<= 0 c 32)1167 (let ([val (if (pair? (cdr callargs))1168 (second callargs)1169 (make-node '##core#undefined '() '()) ) ] )1170 (make-node1171 'let1172 (list tmp)1173 (list val1174 (make-node1175 '##core#call (list #t)1176 (list cont1177 (make-node1178 '##core#inline_allocate1179 (list "C_a_i_vector" (add1 c))1180 (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) )1181 (rewrite 'scheme#make-vector 8 rewrite-make-vector)1182 (rewrite '##sys#make-vector 8 rewrite-make-vector) )11831184(let ()1185 (define (rewrite-call/cc db classargs cont callargs)1186 ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)1187 (and (= 1 (length callargs))1188 (let ((val (first callargs)))1189 (and (eq? '##core#variable (node-class val))1190 (and-let* ((proc (db-get db (first (node-parameters val)) 'value))1191 ((eq? '##core#lambda (node-class proc))) )1192 (let ((llist (third (node-parameters proc))))1193 (##sys#decompose-lambda-list1194 llist1195 (lambda (vars argc rest)1196 (and (= argc 2)1197 (let ((var (or rest (second llist))))1198 (and (not (db-get db var 'references))1199 (not (db-get db var 'assigned))1200 (not (db-get db var 'inline-transient))1201 (make-node1202 '##core#call (list #t)1203 (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )1204 (rewrite 'scheme#call-with-current-continuation 8 rewrite-call/cc)1205 (rewrite 'chicken.base#call/cc 8 rewrite-call/cc))12061207(define setter-map1208 '((scheme#car . scheme#set-car!)1209 (scheme#cdr . scheme#set-cdr!)1210 (scheme#string-ref . scheme#string-set!)1211 (scheme#vector-ref . scheme#vector-set!)1212 (srfi-4#u8vector-ref . srfi-4#u8vector-set!)1213 (srfi-4#s8vector-ref . srfi-4#s8vector-set!)1214 (srfi-4#u16vector-ref . srfi-4#u16vector-set!)1215 (srfi-4#s16vector-ref . srfi-4#s16vector-set!)1216 (srfi-4#u32vector-ref . srfi-4#u32vector-set!)1217 (srfi-4#s32vector-ref . srfi-4#s32vector-set!)1218 (srfi-4#u64vector-ref . srfi-4#u64vector-set!)1219 (srfi-4#s64vector-ref . srfi-4#s64vector-set!)1220 (srfi-4#f32vector-ref . srfi-4#f32vector-set!)1221 (srfi-4#f64vector-ref . srfi-4#f64vector-set!)1222 (chicken.locative#locative-ref . chicken.locative#locative-set!)1223 (chicken.memory#pointer-u8-ref . chicken.memory#pointer-u8-set!)1224 (chicken.memory#pointer-s8-ref . chicken.memory#pointer-s8-set!)1225 (chicken.memory#pointer-u16-ref . chicken.memory#pointer-u16-set!)1226 (chicken.memory#pointer-s16-ref . chicken.memory#pointer-s16-set!)1227 (chicken.memory#pointer-u32-ref . chicken.memory#pointer-u32-set!)1228 (chicken.memory#pointer-s32-ref . chicken.memory#pointer-s32-set!)1229 (chicken.memory#pointer-f32-ref . chicken.memory#pointer-f32-set!)1230 (chicken.memory#pointer-f64-ref . chicken.memory#pointer-f64-set!)1231 (chicken.memory.representation#block-ref . chicken.memory.representation#block-set!) ))12321233(rewrite1234 '##sys#setter 81235 (lambda (db classargs cont callargs)1236 ;; (setter <known-getter>) -> <known-setter>1237 (and (= 1 (length callargs))1238 (let ((arg (car callargs)))1239 (and (eq? '##core#variable (node-class arg))1240 (let ((sym (car (node-parameters arg))))1241 (and (intrinsic? sym)1242 (and-let* ((a (assq sym setter-map)))1243 (make-node1244 '##core#call (list #t)1245 (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) )12461247(rewrite 'chicken.base#void 3 '##sys#undefined-value 0)1248(rewrite '##sys#void 3 '##sys#undefined-value #f)1249(rewrite 'scheme#current-input-port 3 '##sys#standard-input 0)1250(rewrite 'scheme#current-output-port 3 '##sys#standard-output 0)1251(rewrite 'chicken.base#current-error-port 3 '##sys#standard-error 0)12521253(rewrite1254 'chicken.bitwise#bit->boolean 81255 (lambda (db classargs cont callargs)1256 (and (= 2 (length callargs))1257 (make-node1258 '##core#call (list #t)1259 (list cont1260 (make-node1261 '##core#inline1262 (list (if (eq? number-type 'fixnum) "C_u_i_bit_to_bool" "C_i_bit_to_bool"))1263 callargs) ) ) ) ) )12641265(rewrite1266 'chicken.bitwise#integer-length 81267 (lambda (db classargs cont callargs)1268 (and (= 1 (length callargs))1269 (make-node1270 '##core#call (list #t)1271 (list cont1272 (make-node1273 '##core#inline1274 (list (if (eq? number-type 'fixnum) "C_i_fixnum_length" "C_i_integer_length"))1275 callargs) ) ) ) ) )12761277(rewrite 'scheme#read-char 23 0 '##sys#read-char/port '##sys#standard-input)1278(rewrite 'scheme#write-char 23 1 '##sys#write-char/port '##sys#standard-output)1279(rewrite 'chicken.string#substring=? 23 2 '##sys#substring=? 0 0 #f)1280(rewrite 'chicken.string#substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)1281(rewrite 'chicken.string#substring-index 23 2 '##sys#substring-index 0)1282(rewrite 'chicken.string#substring-index-ci 23 2 '##sys#substring-index-ci 0)12831284(rewrite 'chicken.keyword#get-keyword 7 2 "C_i_get_keyword" #f #t)1285(rewrite '##sys#get-keyword 7 2 "C_i_get_keyword" #f #t)12861287)