~ 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 clustering lfa2 debug-info110 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?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? 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=? chicken.base#exact-integer?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.number-vectoru8vector? chicken.number-vectors8vector?193 chicken.number-vectoru16vector? chicken.number-vectors16vector?194 chicken.number-vectoru32vector? chicken.number-vectoru64vector?195 chicken.number-vectors32vector? chicken.number-vectors64vector?196 chicken.number-vectorf32vector? chicken.number-vectorf64vector?197 chicken.number-vectorc64vector? chicken.number-vectorf128vector?198199 chicken.number-vectoru8vector-length chicken.number-vectors8vector-length200 chicken.number-vectoru16vector-length chicken.number-vectors16vector-length201 chicken.number-vectoru32vector-length chicken.number-vectoru64vector-length202 chicken.number-vectors32vector-length chicken.number-vectors64vector-length203 chicken.number-vectorf32vector-length chicken.number-vectorf64vector-length204 chicken.number-vectorc64vector-length chicken.number-vectorc128vector-length205206 chicken.number-vectoru8vector-ref chicken.number-vectors8vector-ref207 chicken.number-vectoru16vector-ref chicken.number-vectors16vector-ref208 chicken.number-vectoru32vector-ref chicken.number-vectoru64vector-ref209 chicken.number-vectors32vector-ref chicken.number-vectors64vector-ref210 chicken.number-vectorf32vector-ref chicken.number-vectorf64vector-ref211 chicken.number-vectorc64vector-ref chicken.number-vectorc128vector-ref212213 chicken.number-vectoru8vector-set! chicken.number-vectors8vector-set!214 chicken.number-vectoru16vector-set! chicken.number-vectors16vector-set!215 chicken.number-vectoru32vector-set! chicken.number-vectoru64vector-set!216 chicken.number-vectors32vector-set! chicken.number-vectors64vector-set!217 chicken.number-vectorf32vector-set! chicken.number-vectorf64vector-set!218 chicken.number-vectorc64vector-set! chicken.number-vectorc128vector-set!219220 chicken.number-vectoru16vector->bytevector/shared chicken.number-vectors16vector->bytevector/shared221 chicken.number-vectoru32vector->bytevector/shared chicken.number-vectors32vector->bytevector/shared222 chicken.number-vectoru64vector->bytevector/shared chicken.number-vectors64vector->bytevector/shared223 chicken.number-vectorf32vector->bytevector/shared chicken.number-vectorf64vector->bytevector/shared224 chicken.number-vectorbytevector->u16vector/shared chicken.number-vectorbytevector->s16vector/shared225 chicken.number-vectorbytevector->u32vector/shared chicken.number-vectorbytevector->s32vector/shared226 chicken.number-vectorbytevector->u64vector/shared chicken.number-vectorbytevector->s64vector/shared227 chicken.number-vectorbytevector->f32vector/shared chicken.number-vectorbytevector->f64vector/shared228 chicken.number-vectorbytevector->c64vector/shared chicken.number-vectorbytevector->c128vector/shared229230 chicken.memory.representation#number-of-slots231 chicken.memory.representation#make-record-instance232 chicken.memory.representation#block-ref233 chicken.memory.representation#block-set!234235 chicken.locative#locative-ref chicken.locative#locative-set!236 chicken.locative#locative->object chicken.locative#locative?237 chicken.locative#locative-index238239 chicken.memory#pointer+ chicken.memory#pointer=?240 chicken.memory#address->pointer chicken.memory#pointer->address241 chicken.memory#pointer->object chicken.memory#object->pointer242 chicken.memory#pointer-u8-ref chicken.memory#pointer-s8-ref243 chicken.memory#pointer-u16-ref chicken.memory#pointer-s16-ref244 chicken.memory#pointer-u32-ref chicken.memory#pointer-s32-ref245 chicken.memory#pointer-f32-ref chicken.memory#pointer-f64-ref246 chicken.memory#pointer-u8-set! chicken.memory#pointer-s8-set!247 chicken.memory#pointer-u16-set! chicken.memory#pointer-s16-set!248 chicken.memory#pointer-u32-set! chicken.memory#pointer-s32-set!249 chicken.memory#pointer-f32-set! chicken.memory#pointer-f64-set!250251 chicken.string#substring-index chicken.string#substring-index-ci252 chicken.string#substring=? chicken.string#substring-ci=?253254 chicken.io#read-string255256 chicken.format#format257 chicken.format#printf chicken.format#sprintf chicken.format#fprintf))258259(set! default-extended-bindings260 (append +fixnum-bindings+ +flonum-bindings+ +extended-bindings+))261262(set! internal-bindings263 '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set! ##sys#/-2264 ##sys#call-with-current-continuation ##sys#size ##sys#byte265 ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure266 ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string267 ##sys#check-symbol ##sys#check-boolean ##sys#check-locative268 ##sys#check-fixnum ##sys#check-range ##sys#check-range/internal269 ##sys#check-port ##sys#check-input-port ##sys#check-output-port270 ##sys#check-open-port ##sys#check-bytevector ##sys#signal-hook271 ##sys#check-char ##sys#check-vector ##sys#check-bytevector ##sys#list ##sys#cons272 ##sys#call-with-values ##sys#flonum-in-fixnum-range?273 ##sys#immediate? ##sys#context-switch274 ##sys#make-structure ##sys#apply ##sys#apply-values275 chicken.continuation#continuation-graft276 ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?277 ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#get-keyword278 ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument279 ##sys#foreign-block-argument ##sys#foreign-struct-wrapper-argument280 ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void281 ##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument282 ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double283 ##sys#intern-symbol ##sys#intern-keyword ##sys#null-pointer? ##sys#peek-byte284 ##sys#foreign-symbol-argument285 ##sys#symbol->string/shared ##sys#buffer->string ##sys#string->symbol-name286 ##sys#bytevector->list ##sys#list->bytevector ##sys#make-bytevector287 ##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd))288289(for-each290 (cut mark-variable <> '##compiler#pure '#t)291 '(##sys#slot ##sys#block-ref ##sys#size ##sys#byte292 ##sys#pointer? ##sys#generic-structure? ##sys#immediate?293 ##sys#bytevector? ##sys#pair? ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?294 ##sys#get-keyword ; ok it isn't, but this is only used for ext. llists295 ##sys#void ##sys#permanent?))296297298;;; Rewriting-definitions for this platform:299300(let ()301 ;; (add1 <x>) -> (##core#inline "C_fixnum_increase" <x>) [fixnum-mode]302 ;; (add1 <x>) -> (##core#inline "C_u_fixnum_increase" <x>) [fixnum-mode + unsafe]303 ;; (add1 <x>) -> (##core#inline_allocate ("C_s_a_i_plus" 36) <x> 1)304 ;; (sub1 <x>) -> (##core#inline "C_fixnum_decrease" <x>) [fixnum-mode]305 ;; (sub1 <x>) -> (##core#inline "C_u_fixnum_decrease" <x>) [fixnum-mode + unsafe]306 ;; (sub1 <x>) -> (##core#inline_allocate ("C_s_a_i_minus" 36) <x> 1)307 (define ((op1 fiop ufiop aiop) db classargs cont callargs)308 (and (= (length callargs) 1)309 (make-node310 '##core#call (list #t)311 (list312 cont313 (if (eq? 'fixnum number-type)314 (make-node '##core#inline (list (if unsafe ufiop fiop)) callargs)315 (make-node316 '##core#inline_allocate (list aiop 36)317 (list (car callargs) (qnode 1))))))))318 (rewrite 'chicken.base#add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_s_a_i_plus"))319 (rewrite 'chicken.base#sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_s_a_i_minus")))320321(let ()322 (define (eqv?-id db classargs cont callargs)323 ;; (eqv? <var> <var>) -> (quote #t) [two identical objects]324 ;; (eqv? ...) -> (##core#inline "C_eqp" ...)325 ;; [one argument is a constant and either immediate or not a number]326 (and (= (length callargs) 2)327 (let ((arg1 (first callargs))328 (arg2 (second callargs)) )329 (or (and (eq? '##core#variable (node-class arg1))330 (eq? '##core#variable (node-class arg2))331 (equal? (node-parameters arg1) (node-parameters arg2))332 (make-node '##core#call (list #t) (list cont (qnode #t))) )333 (and (or (and (eq? 'quote (node-class arg1))334 (let ((p1 (first (node-parameters arg1))))335 (or (immediate? p1) (not (number? p1)))) )336 (and (eq? 'quote (node-class arg2))337 (let ((p2 (first (node-parameters arg2))))338 (or (immediate? p2) (not (number? p2)))) ) )339 (make-node340 '##core#call (list #t)341 (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )342 (rewrite 'scheme#eqv? 8 eqv?-id)343 (rewrite '##sys#eqv? 8 eqv?-id))344345(rewrite346 'scheme#equal? 8347 (lambda (db classargs cont callargs)348 ;; (equal? <var> <var>) -> (quote #t)349 ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol]350 ;; (equal? ...) -> (##core#inline "C_i_equalp" ...)351 (and (= (length callargs) 2)352 (let ([arg1 (first callargs)]353 [arg2 (second callargs)] )354 (or (and (eq? '##core#variable (node-class arg1))355 (eq? '##core#variable (node-class arg2))356 (equal? (node-parameters arg1) (node-parameters arg2))357 (make-node '##core#call (list #t) (list cont (qnode #t))) )358 (and (or (and (eq? 'quote (node-class arg1))359 (let ([f (first (node-parameters arg1))])360 (or (immediate? f) (symbol? f)) ) )361 (and (eq? 'quote (node-class arg2))362 (let ([f (first (node-parameters arg2))])363 (or (immediate? f) (symbol? f)) ) ) )364 (make-node365 '##core#call (list #t)366 (list cont (make-node '##core#inline '("C_eqp") callargs)) ) )367 (make-node368 '##core#call (list #t)369 (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )370371(let ()372 (define (rewrite-apply db classargs cont callargs)373 ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...)374 ;; (apply ...) -> ((##core#proc "C_apply") ...)375 ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst)376 ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst)377 (and (pair? callargs)378 (let ([lastarg (last callargs)]379 [proc (car callargs)] )380 (if (eq? 'quote (node-class lastarg))381 (make-node382 '##core#call (list #f)383 (cons* (first callargs)384 cont385 (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )386 (or (and (eq? '##core#variable (node-class proc))387 (= 2 (length callargs))388 (let ([name (car (node-parameters proc))])389 (and (memq name '(values ##sys#values))390 (intrinsic? name)391 (make-node392 '##core#call (list #t)393 (list (make-node '##core#proc '("C_apply_values" #t) '())394 cont395 (cadr callargs) ) ) ) ) )396 (make-node397 '##core#call (list #t)398 (cons* (make-node '##core#proc '("C_apply" #t) '())399 cont callargs) ) ) ) ) ) )400 (rewrite 'scheme#apply 8 rewrite-apply)401 (rewrite '##sys#apply 8 rewrite-apply) )402403(let ()404 (define (rewrite-c..r op iop1 iop2)405 (rewrite406 op 8407 (lambda (db classargs cont callargs)408 ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe]409 ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe]410 (and (= (length callargs) 1)411 (call-with-current-continuation412 (lambda (return)413 (let ((arg (first callargs)))414 (make-node415 '##core#call (list #t)416 (list417 cont418 (cond [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]419 [iop1 (make-node '##core#inline (list iop1) callargs)]420 [else (return #f)] ) ) ) ) ) ) ) ) ) )421422 (rewrite-c..r 'scheme#car "C_i_car" "C_u_i_car")423 (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car")424 (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr")425 (rewrite-c..r 'scheme#cadr "C_i_cadr" "C_u_i_cadr")426 (rewrite-c..r 'scheme#caddr "C_i_caddr" "C_u_i_caddr")427 (rewrite-c..r 'scheme#cadddr "C_i_cadddr" "C_u_i_cadddr") )428429(let ((rvalues430 (lambda (db classargs cont callargs)431 ;; (values <x>) -> <x>432 (and (= (length callargs) 1)433 (make-node '##core#call (list #t) (cons cont callargs) ) ) ) ) )434 (rewrite 'scheme#values 8 rvalues)435 (rewrite '##sys#values 8 rvalues) )436437(let ()438 (define (rewrite-c-w-v db classargs cont callargs)439 ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) [<var2> <k0> r]))) [<var1> k])440 ;; - if <var2> is a known lambda of a single argument441 (and (= 2 (length callargs))442 (let ((arg1 (car callargs))443 (arg2 (cadr callargs)) )444 (and (eq? '##core#variable (node-class arg1)) ; probably not needed445 (eq? '##core#variable (node-class arg2))446 (and-let* ((sym (car (node-parameters arg2)))447 (val (db-get db sym 'value)) )448 (and (eq? '##core#lambda (node-class val))449 (let ((llist (third (node-parameters val))))450 (and (list? llist)451 (= 2 (length llist))452 (let ((tmp (gensym))453 (tmpk (gensym 'r)) )454 (debugging 'o "removing single-valued `call-with-values'" (node-parameters val))455 (make-node456 'let (list tmp)457 (list (make-node458 '##core#lambda459 (list (gensym 'f_) #f (list tmpk) 0)460 (list (make-node461 '##core#call (list #t)462 (list arg2 cont (varnode tmpk)) ) ) )463 (make-node464 '##core#call (list #t)465 (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )466 (rewrite 'scheme#call-with-values 8 rewrite-c-w-v)467 (rewrite '##sys#call-with-values 8 rewrite-c-w-v) )468469(rewrite 'scheme#values 13 #f "C_values" #t)470(rewrite '##sys#values 13 #f "C_values" #t)471(rewrite 'scheme#call-with-values 13 2 "C_u_call_with_values" #f)472(rewrite 'scheme#call-with-values 13 2 "C_call_with_values" #t)473(rewrite '##sys#call-with-values 13 2 "C_u_call_with_values" #f)474(rewrite '##sys#call-with-values 13 2 "C_call_with_values" #t)475(rewrite 'chicken.continuation#continuation-graft 13 2 "C_continuation_graft" #t)476477(rewrite 'scheme#caar 2 1 "C_u_i_caar" #f)478(rewrite 'scheme#cdar 2 1 "C_u_i_cdar" #f)479(rewrite 'scheme#cddr 2 1 "C_u_i_cddr" #f)480(rewrite 'scheme#caaar 2 1 "C_u_i_caaar" #f)481(rewrite 'scheme#cadar 2 1 "C_u_i_cadar" #f)482(rewrite 'scheme#caddr 2 1 "C_u_i_caddr" #f)483(rewrite 'scheme#cdaar 2 1 "C_u_i_cdaar" #f)484(rewrite 'scheme#cdadr 2 1 "C_u_i_cdadr" #f)485(rewrite 'scheme#cddar 2 1 "C_u_i_cddar" #f)486(rewrite 'scheme#cdddr 2 1 "C_u_i_cdddr" #f)487(rewrite 'scheme#caaaar 2 1 "C_u_i_caaaar" #f)488(rewrite 'scheme#caadar 2 1 "C_u_i_caadar" #f)489(rewrite 'scheme#caaddr 2 1 "C_u_i_caaddr" #f)490(rewrite 'scheme#cadaar 2 1 "C_u_i_cadaar" #f)491(rewrite 'scheme#cadadr 2 1 "C_u_i_cadadr" #f)492(rewrite 'scheme#caddar 2 1 "C_u_i_caddar" #f)493(rewrite 'scheme#cadddr 2 1 "C_u_i_cadddr" #f)494(rewrite 'scheme#cdaaar 2 1 "C_u_i_cdaaar" #f)495(rewrite 'scheme#cdaadr 2 1 "C_u_i_cdaadr" #f)496(rewrite 'scheme#cdadar 2 1 "C_u_i_cdadar" #f)497(rewrite 'scheme#cdaddr 2 1 "C_u_i_cdaddr" #f)498(rewrite 'scheme#cddaar 2 1 "C_u_i_cddaar" #f)499(rewrite 'scheme#cddadr 2 1 "C_u_i_cddadr" #f)500(rewrite 'scheme#cdddar 2 1 "C_u_i_cdddar" #f)501(rewrite 'scheme#cddddr 2 1 "C_u_i_cddddr" #f)502503(rewrite 'scheme#caar 2 1 "C_i_caar" #t)504(rewrite 'scheme#cdar 2 1 "C_i_cdar" #t)505(rewrite 'scheme#cddr 2 1 "C_i_cddr" #t)506(rewrite 'scheme#cdddr 2 1 "C_i_cdddr" #t)507(rewrite 'scheme#cddddr 2 1 "C_i_cddddr" #t)508509(rewrite 'scheme#cdr 2 1 "C_u_i_cdr" #f)510(rewrite 'scheme#cdr 2 1 "C_i_cdr" #t)511512(rewrite 'scheme#eq? 1 2 "C_eqp")513(rewrite '##sys#eq? 1 2 "C_eqp")514(rewrite 'scheme#eqv? 1 2 "C_i_eqvp")515(rewrite '##sys#eqv? 1 2 "C_i_eqvp")516517(rewrite 'scheme#list-ref 2 2 "C_u_i_list_ref" #f)518(rewrite 'scheme#list-ref 2 2 "C_i_list_ref" #t)519(rewrite 'scheme#null? 2 1 "C_i_nullp" #t)520(rewrite '##sys#null? 2 1 "C_i_nullp" #t)521(rewrite 'scheme#length 2 1 "C_i_length" #t)522(rewrite 'scheme#not 2 1 "C_i_not"#t )523(rewrite 'scheme#char? 2 1 "C_charp" #t)524(rewrite 'scheme#string? 2 1 "C_i_stringp" #t)525(rewrite 'chicken.locative#locative? 2 1 "C_i_locativep" #t)526(rewrite 'scheme#symbol? 2 1 "C_i_symbolp" #t)527(rewrite 'scheme#vector? 2 1 "C_i_vectorp" #t)528(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t)529(rewrite 'chicken.number-vectoru8vector? 2 1 "C_bytevectorp" #t)530(rewrite 'chicken.number-vectors8vector? 2 1 "C_i_s8vectorp" #t)531(rewrite 'chicken.number-vectoru16vector? 2 1 "C_i_u16vectorp" #t)532(rewrite 'chicken.number-vectors16vector? 2 1 "C_i_s16vectorp" #t)533(rewrite 'chicken.number-vectoru32vector? 2 1 "C_i_u32vectorp" #t)534(rewrite 'chicken.number-vectors32vector? 2 1 "C_i_s32vectorp" #t)535(rewrite 'chicken.number-vectoru64vector? 2 1 "C_i_u64vectorp" #t)536(rewrite 'chicken.number-vectors64vector? 2 1 "C_i_s64vectorp" #t)537(rewrite 'chicken.number-vectorf32vector? 2 1 "C_i_f32vectorp" #t)538(rewrite 'chicken.number-vectorf64vector? 2 1 "C_i_f64vectorp" #t)539(rewrite 'scheme#pair? 2 1 "C_i_pairp" #t)540(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)541(rewrite 'chicken.base#weak-pair? 2 1 "C_i_weak_pairp" #t)542(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t)543(rewrite 'scheme#port? 2 1 "C_i_portp" #t)544(rewrite 'scheme#boolean? 2 1 "C_booleanp" #t)545(rewrite 'scheme#number? 2 1 "C_i_numberp" #t)546(rewrite 'scheme#complex? 2 1 "C_i_numberp" #t)547(rewrite 'scheme#rational? 2 1 "C_i_rationalp" #t)548(rewrite 'scheme#real? 2 1 "C_i_realp" #t)549(rewrite 'scheme#integer? 2 1 "C_i_integerp" #t)550(rewrite 'chicken.base#exact-integer? 2 1 "C_i_exact_integerp" #t)551(rewrite 'chicken.base#flonum? 2 1 "C_i_flonump" #t)552(rewrite 'chicken.base#fixnum? 2 1 "C_fixnump" #t)553(rewrite 'chicken.base#bignum? 2 1 "C_i_bignump" #t)554(rewrite 'chicken.base#cplxnum? 2 1 "C_i_cplxnump" #t)555(rewrite 'chicken.base#ratnum? 2 1 "C_i_ratnump" #t)556(rewrite 'chicken.base#nan? 2 1 "C_i_nanp" #f)557(rewrite 'chicken.base#finite? 2 1 "C_i_finitep" #f)558(rewrite 'chicken.base#infinite? 2 1 "C_i_infinitep" #f)559(rewrite 'chicken.flonum#fpinteger? 2 1 "C_u_i_fpintegerp" #f)560(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t)561(rewrite 'pointer? 2 1 "C_i_safe_pointerp" #t)562(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t)563(rewrite 'scheme#exact? 2 1 "C_i_exactp" #t)564(rewrite 'scheme#exact? 2 1 "C_u_i_exactp" #f)565(rewrite 'scheme#inexact? 2 1 "C_i_inexactp" #t)566(rewrite 'scheme#inexact? 2 1 "C_u_i_inexactp" #f)567(rewrite 'scheme#list? 2 1 "C_i_listp" #t)568(rewrite 'scheme#eof-object? 2 1 "C_eofp" #t)569(rewrite 'scheme#string-ref 2 2 "C_utf_subchar" #f)570(rewrite 'chicken.base#bwp-object? 2 1 "C_bwpp" #t)571(rewrite 'scheme#string-ref 2 2 "C_i_string_ref" #t)572(rewrite 'scheme#string-set! 2 3 "C_utf_setsubchar" #f)573(rewrite 'scheme#string-set! 2 3 "C_i_string_set" #t)574(rewrite 'scheme#vector-ref 2 2 "C_slot" #f)575(rewrite 'scheme#vector-ref 2 2 "C_i_vector_ref" #t)576(rewrite 'scheme#char=? 2 2 "C_u_i_char_equalp" #f)577(rewrite 'scheme#char=? 2 2 "C_i_char_equalp" #t)578(rewrite 'scheme#char>? 2 2 "C_u_i_char_greaterp" #f)579(rewrite 'scheme#char>? 2 2 "C_i_char_greaterp" #t)580(rewrite 'scheme#char<? 2 2 "C_u_i_char_lessp" #f)581(rewrite 'scheme#char<? 2 2 "C_i_char_lessp" #t)582(rewrite 'scheme#char>=? 2 2 "C_u_i_char_greater_or_equal_p" #f)583(rewrite 'scheme#char>=? 2 2 "C_i_char_greater_or_equal_p" #t)584(rewrite 'scheme#char<=? 2 2 "C_u_i_char_less_or_equal_p" #f)585(rewrite 'scheme#char<=? 2 2 "C_i_char_less_or_equal_p" #t)586(rewrite '##sys#slot 2 2 "C_slot" #t) ; consider as safe, the primitive is unsafe anyway.587(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t) ;XXX must be safe for pattern matcher (anymore?)588(rewrite '##sys#size 2 1 "C_block_size" #t)589(rewrite 'chicken.fixnum#fxnot 2 1 "C_fixnum_not" #t)590(rewrite 'chicken.fixnum#fx* 2 2 "C_fixnum_times" #t)591(rewrite 'chicken.fixnum#fx+? 2 2 "C_i_o_fixnum_plus" #t)592(rewrite 'chicken.fixnum#fx-? 2 2 "C_i_o_fixnum_difference" #t)593(rewrite 'chicken.fixnum#fx*? 2 2 "C_i_o_fixnum_times" #t)594(rewrite 'chicken.fixnum#fx/? 2 2 "C_i_o_fixnum_quotient" #t)595(rewrite 'chicken.fixnum#fx= 2 2 "C_eqp" #t)596(rewrite 'chicken.fixnum#fx> 2 2 "C_fixnum_greaterp" #t)597(rewrite 'chicken.fixnum#fx< 2 2 "C_fixnum_lessp" #t)598(rewrite 'chicken.fixnum#fx>= 2 2 "C_fixnum_greater_or_equal_p" #t)599(rewrite 'chicken.fixnum#fx<= 2 2 "C_fixnum_less_or_equal_p" #t)600(rewrite 'chicken.flonum#fp= 2 2 "C_flonum_equalp" #f)601(rewrite 'chicken.flonum#fp> 2 2 "C_flonum_greaterp" #f)602(rewrite 'chicken.flonum#fp< 2 2 "C_flonum_lessp" #f)603(rewrite 'chicken.flonum#fp>= 2 2 "C_flonum_greater_or_equal_p" #f)604(rewrite 'chicken.flonum#fp<= 2 2 "C_flonum_less_or_equal_p" #f)605(rewrite 'chicken.fixnum#fxmax 2 2 "C_i_fixnum_max" #t)606(rewrite 'chicken.fixnum#fxmin 2 2 "C_i_fixnum_min" #t)607(rewrite 'chicken.flonum#fpmax 2 2 "C_i_flonum_max" #f)608(rewrite 'chicken.flonum#fpmin 2 2 "C_i_flonum_min" #f)609(rewrite 'chicken.fixnum#fxgcd 2 2 "C_i_fixnum_gcd" #t)610(rewrite 'chicken.fixnum#fxlen 2 1 "C_i_fixnum_length" #t)611(rewrite 'scheme#char-numeric? 2 1 "C_u_i_char_numericp" #t)612(rewrite 'scheme#char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t)613(rewrite 'scheme#char-whitespace? 2 1 "C_u_i_char_whitespacep" #t)614(rewrite 'scheme#char-upper-case? 2 1 "C_u_i_char_upper_casep" #t)615(rewrite 'scheme#char-lower-case? 2 1 "C_u_i_char_lower_casep" #t)616(rewrite 'scheme#char-upcase 2 1 "C_u_i_char_upcase" #t)617(rewrite 'scheme#char-downcase 2 1 "C_u_i_char_downcase" #t)618(rewrite 'scheme#list-tail 2 2 "C_i_list_tail" #t)619(rewrite '##sys#structure? 2 2 "C_i_structurep" #t)620(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t)621(rewrite 'chicken.memory.representation#block-ref 2 2 "C_slot" #f) ; ok to be unsafe, lolevel is anyway622(rewrite 'chicken.memory.representation#number-of-slots 2 1 "C_block_size" #f)623624(rewrite 'scheme#assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")625(rewrite 'scheme#assv 2 2 "C_i_assv" #t)626(rewrite 'scheme#memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")627(rewrite 'scheme#memv 2 2 "C_i_memv" #t)628(rewrite 'scheme#assq 17 2 "C_i_assq" "C_u_i_assq")629(rewrite 'scheme#memq 17 2 "C_i_memq" "C_u_i_memq")630(rewrite 'scheme#assoc 2 2 "C_i_assoc" #t)631(rewrite 'scheme#member 2 2 "C_i_member" #t)632633(rewrite 'scheme#set-car! 4 '##sys#setslot 0)634(rewrite 'scheme#set-cdr! 4 '##sys#setslot 1)635(rewrite 'scheme#set-car! 17 2 "C_i_set_car" "C_u_i_set_car")636(rewrite 'scheme#set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr")637638(rewrite 'scheme#abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")639640(rewrite 'chicken.bitwise#bitwise-and 19)641(rewrite 'chicken.bitwise#bitwise-xor 19)642(rewrite 'chicken.bitwise#bitwise-ior 19)643644(rewrite 'chicken.bitwise#bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_s_a_i_bitwise_and" 5)645(rewrite 'chicken.bitwise#bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_s_a_i_bitwise_xor" 5)646(rewrite 'chicken.bitwise#bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_s_a_i_bitwise_ior" 5)647648(rewrite 'chicken.bitwise#bitwise-not 22 1 "C_s_a_i_bitwise_not" #t 5 "C_fixnum_not")649650(rewrite 'chicken.flonum#fp+ 16 2 "C_a_i_flonum_plus" #f words-per-flonum)651(rewrite 'chicken.flonum#fp- 16 2 "C_a_i_flonum_difference" #f words-per-flonum)652(rewrite 'chicken.flonum#fp* 16 2 "C_a_i_flonum_times" #f words-per-flonum)653(rewrite 'chicken.flonum#fp/ 16 2 "C_a_i_flonum_quotient" #f words-per-flonum)654(rewrite 'chicken.flonum#fp/? 16 2 "C_a_i_flonum_quotient_checked" #f words-per-flonum)655(rewrite 'chicken.flonum#fpneg 16 1 "C_a_i_flonum_negate" #f words-per-flonum)656(rewrite 'chicken.flonum#fpgcd 16 2 "C_a_i_flonum_gcd" #f words-per-flonum)657(rewrite 'chicken.flonum#fp*+ 16 3 "C_a_i_flonum_multiply_add" #f words-per-flonum)658659(rewrite 'scheme#zero? 5 "C_eqp" 0 'fixnum)660(rewrite 'scheme#zero? 2 1 "C_u_i_zerop2" #f)661(rewrite 'scheme#zero? 2 1 "C_i_zerop" #t)662(rewrite 'scheme#positive? 5 "C_fixnum_greaterp" 0 'fixnum)663(rewrite 'scheme#positive? 5 "C_flonum_greaterp" 0 'flonum)664(rewrite 'scheme#positive? 2 1 "C_i_positivep" #t)665(rewrite 'scheme#negative? 5 "C_fixnum_lessp" 0 'fixnum)666(rewrite 'scheme#negative? 5 "C_flonum_lessp" 0 'flonum)667(rewrite 'scheme#negative? 2 1 "C_i_negativep" #t)668669(rewrite 'scheme#vector-length 6 "C_fix" "C_header_size" #f)670(rewrite 'scheme#char->integer 6 "C_fix" "C_character_code" #t)671(rewrite 'scheme#integer->char 6 "C_make_character" "C_unfix" #t)672673(rewrite 'scheme#vector-length 2 1 "C_i_vector_length" #t)674(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t)675(rewrite 'scheme#string-length 2 1 "C_i_string_length" #t)676677(rewrite '##sys#check-fixnum 2 1 "C_i_check_fixnum" #t)678(rewrite '##sys#check-number 2 1 "C_i_check_number" #t)679(rewrite '##sys#check-list 2 1 "C_i_check_list" #t)680(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t)681(rewrite '##sys#check-boolean 2 1 "C_i_check_boolean" #t)682(rewrite '##sys#check-locative 2 1 "C_i_check_locative" #t)683(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t)684(rewrite '##sys#check-string 2 1 "C_i_check_string" #t)685(rewrite '##sys#check-bytevector 2 1 "C_i_check_bytevector" #t)686(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t)687(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t)688(rewrite '##sys#check-char 2 1 "C_i_check_char" #t)689(rewrite '##sys#check-fixnum 2 2 "C_i_check_fixnum_2" #t)690(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t)691(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t)692(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t)693(rewrite '##sys#check-boolean 2 2 "C_i_check_boolean_2" #t)694(rewrite '##sys#check-locative 2 2 "C_i_check_locative_2" #t)695(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t)696(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t)697(rewrite '##sys#check-bytevector 2 2 "C_i_check_bytevector_2" #t)698(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t)699(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t)700(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t)701(rewrite '##sys#check-range 2 3 "C_i_check_range" #t)702(rewrite '##sys#check-range 2 4 "C_i_check_range_2" #t)703(rewrite '##sys#check-range/including 2 3 "C_i_check_range_including" #t)704(rewrite '##sys#check-range/including 2 4 "C_i_check_range_including_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#allocate-bytevector 13 4 "C_allocate_bytevector" #t)918(rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t)919(rewrite 'chicken.platform#return-to-host 13 0 "C_return_to_host" #t)920(rewrite '##sys#context-switch 13 1 "C_context_switch" #t)921922(rewrite 'scheme#even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")923(rewrite 'scheme#odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")924(rewrite 'scheme#remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")925926(rewrite 'scheme#even? 17 1 "C_i_evenp")927(rewrite 'scheme#odd? 17 1 "C_i_oddp")928929(rewrite 'chicken.fixnum#fxodd? 2 1 "C_i_fixnumoddp" #t)930(rewrite 'chicken.fixnum#fxeven? 2 1 "C_i_fixnumevenp" #t)931932(rewrite 'scheme#floor 15 'flonum 'fixnum 'chicken.flonum#fpfloor #f)933(rewrite 'scheme#ceiling 15 'flonum 'fixnum 'chicken.flonum#fpceiling #f)934(rewrite 'scheme#truncate 15 'flonum 'fixnum 'chicken.flonum#fptruncate #f)935936(rewrite 'chicken.flonum#fpsin 16 1 "C_a_i_flonum_sin" #f words-per-flonum)937(rewrite 'chicken.flonum#fpcos 16 1 "C_a_i_flonum_cos" #f words-per-flonum)938(rewrite 'chicken.flonum#fptan 16 1 "C_a_i_flonum_tan" #f words-per-flonum)939(rewrite 'chicken.flonum#fpasin 16 1 "C_a_i_flonum_asin" #f words-per-flonum)940(rewrite 'chicken.flonum#fpacos 16 1 "C_a_i_flonum_acos" #f words-per-flonum)941(rewrite 'chicken.flonum#fpatan 16 1 "C_a_i_flonum_atan" #f words-per-flonum)942(rewrite 'chicken.flonum#fpatan2 16 2 "C_a_i_flonum_atan2" #f words-per-flonum)943(rewrite 'chicken.flonum#fpexp 16 1 "C_a_i_flonum_exp" #f words-per-flonum)944(rewrite 'chicken.flonum#fpexpt 16 2 "C_a_i_flonum_expt" #f words-per-flonum)945(rewrite 'chicken.flonum#fplog 16 1 "C_a_i_flonum_log" #f words-per-flonum)946(rewrite 'chicken.flonum#fpsqrt 16 1 "C_a_i_flonum_sqrt" #f words-per-flonum)947(rewrite 'chicken.flonum#fpabs 16 1 "C_a_i_flonum_abs" #f words-per-flonum)948(rewrite 'chicken.flonum#fptruncate 16 1 "C_a_i_flonum_truncate" #f words-per-flonum)949(rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_round" #f words-per-flonum)950(rewrite 'chicken.flonum#fpceiling 16 1 "C_a_i_flonum_ceiling" #f words-per-flonum)951(rewrite 'chicken.flonum#fpround 16 1 "C_a_i_flonum_floor" #f words-per-flonum)952953(rewrite 'scheme#cons 16 2 "C_a_i_cons" #t 3)954(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)955(rewrite 'chicken.base#weak-cons 16 2 "C_a_i_weak_cons" #t 3)956(rewrite 'scheme#list 16 #f "C_a_i_list" #t '(0 3) #t)957(rewrite '##sys#list 16 #f "C_a_i_list" #t '(0 3))958(rewrite 'scheme#vector 16 #f "C_a_i_vector" #t #t #t)959(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)960(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t #t)961(rewrite 'scheme#string 16 #f "C_a_i_string" #t '(7 1))962(rewrite 'chicken.memory#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)963(rewrite 'chicken.memory#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)964(rewrite 'chicken.memory#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)965(rewrite 'chicken.locative#locative-ref 16 1 "C_a_i_locative_ref" #t 6)966967(rewrite 'chicken.memory#pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)968(rewrite 'chicken.memory#pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)969(rewrite 'chicken.memory#pointer-u16-ref 2 1 "C_u_i_pointer_u16_ref" #f)970(rewrite 'chicken.memory#pointer-s16-ref 2 1 "C_u_i_pointer_s16_ref" #f)971(rewrite 'chicken.memory#pointer-u8-set! 2 2 "C_u_i_pointer_u8_set" #f)972(rewrite 'chicken.memory#pointer-s8-set! 2 2 "C_u_i_pointer_s8_set" #f)973(rewrite 'chicken.memory#pointer-u16-set! 2 2 "C_u_i_pointer_u16_set" #f)974(rewrite 'chicken.memory#pointer-s16-set! 2 2 "C_u_i_pointer_s16_set" #f)975(rewrite 'chicken.memory#pointer-u32-set! 2 2 "C_u_i_pointer_u32_set" #f)976(rewrite 'chicken.memory#pointer-s32-set! 2 2 "C_u_i_pointer_s32_set" #f)977(rewrite 'chicken.memory#pointer-f32-set! 2 2 "C_u_i_pointer_f32_set" #f)978(rewrite 'chicken.memory#pointer-f64-set! 2 2 "C_u_i_pointer_f64_set" #f)979980;; on 32-bit platforms, 32-bit integers do not always fit in a word,981;; bignum1 and bignum wrapper (5 words) may be used instead982(rewrite 'chicken.memory#pointer-u32-ref 16 1 "C_a_u_i_pointer_u32_ref" #f min-words-per-bignum)983(rewrite 'chicken.memory#pointer-s32-ref 16 1 "C_a_u_i_pointer_s32_ref" #f min-words-per-bignum)984985(rewrite 'chicken.memory#pointer-f32-ref 16 1 "C_a_u_i_pointer_f32_ref" #f words-per-flonum)986(rewrite 'chicken.memory#pointer-f64-ref 16 1 "C_a_u_i_pointer_f64_ref" #f words-per-flonum)987988(rewrite989 '##sys#setslot 8990 (lambda (db classargs cont callargs)991 ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>)992 ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)993 (and (= (length callargs) 3)994 (make-node995 '##core#call (list #t)996 (list cont997 (make-node998 '##core#inline999 (let ([val (third callargs)])1000 (if (and (eq? 'quote (node-class val))1001 (immediate? (first (node-parameters val))) )1002 '("C_i_set_i_slot")1003 '("C_i_setslot") ) )1004 callargs) ) ) ) ) )10051006(rewrite 'chicken.fixnum#fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus")1007(rewrite 'chicken.fixnum#fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference")1008(rewrite 'chicken.fixnum#fxshl 17 2 "C_fixnum_shift_left")1009(rewrite 'chicken.fixnum#fxshr 17 2 "C_fixnum_shift_right")1010(rewrite 'chicken.fixnum#fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate")1011(rewrite 'chicken.fixnum#fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor")1012(rewrite 'chicken.fixnum#fxand 17 2 "C_fixnum_and" "C_u_fixnum_and")1013(rewrite 'chicken.fixnum#fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")1014(rewrite 'chicken.fixnum#fx/ 17 2 "C_fixnum_divide" "C_u_fixnum_divide")1015(rewrite 'chicken.fixnum#fxmod 17 2 "C_fixnum_modulo" "C_u_fixnum_modulo")1016(rewrite 'chicken.fixnum#fxrem 17 2 "C_i_fixnum_remainder_checked")10171018(rewrite1019 'chicken.bitwise#arithmetic-shift 81020 (lambda (db classargs cont callargs)1021 ;; (arithmetic-shift <x> <-int>)1022 ;; -> (##core#inline "C_fixnum_shift_right" <x> -<int>)1023 ;; (arithmetic-shift <x> <+int>)1024 ;; -> (##core#inline "C_fixnum_shift_left" <x> <int>)1025 ;; _ -> (##core#inline "C_i_fixnum_arithmetic_shift" <x> <y>)1026 ;;1027 ;; not in fixnum-mode:1028 ;; _ -> (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 6) <x> <y>)1029 (and (= 2 (length callargs))1030 (let ((val (second callargs)))1031 (make-node1032 '##core#call (list #t)1033 (list cont1034 (or (and-let* (((eq? 'quote (node-class val)))1035 ((eq? number-type 'fixnum))1036 (n (first (node-parameters val)))1037 ((and (fixnum? n) (not (big-fixnum? n)))) )1038 (if (negative? n)1039 (make-node1040 '##core#inline '("C_fixnum_shift_right")1041 (list (first callargs) (qnode (- n))) )1042 (make-node1043 '##core#inline '("C_fixnum_shift_left")1044 (list (first callargs) val) ) ) )1045 (if (eq? number-type 'fixnum)1046 (make-node '##core#inline1047 '("C_i_fixnum_arithmetic_shift") callargs)1048 (make-node '##core#inline_allocate1049 (list "C_s_a_i_arithmetic_shift" 5)1050 callargs) ) ) ) ) ) ) ) )10511052(rewrite '##sys#byte 17 2 "C_subbyte")1053(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")1054(rewrite '##sys#peek-byte 17 2 "C_peek_byte")1055(rewrite 'chicken.memory#pointer->object 17 2 "C_pointer_to_object")1056(rewrite '##sys#setislot 17 3 "C_i_set_i_slot")1057(rewrite '##sys#poke-integer 17 3 "C_poke_integer")1058(rewrite '##sys#poke-double 17 3 "C_poke_double")1059(rewrite 'scheme#string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p")1060(rewrite 'scheme#string-ci=? 17 2 "C_i_string_ci_equal_p")1061(rewrite '##sys#permanent? 17 1 "C_permanentp")1062(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp")1063(rewrite '##sys#immediate? 17 1 "C_immp")1064(rewrite 'chicken.locative#locative->object 17 1 "C_i_locative_to_object")1065(rewrite 'chicken.locative#locative->object 17 1 "C_i_locative_to_object")1066(rewrite 'chicken.locative#locative-index 17 1 "C_i_locative_index")1067(rewrite 'chicken.locative#locative-set! 17 2 "C_i_locative_set")1068(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp")1069(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")1070(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")1071(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")1072(rewrite '##sys#foreign-symbol-argument 17 1 "C_i_foreign_symbol_argumentp")1073(rewrite '##sys#foreign-struct-wrapper-argument 17 2 "C_i_foreign_struct_wrapper_argumentp")1074(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")1075(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")1076(rewrite '##sys#foreign-ranged-integer-argument 17 2 "C_i_foreign_ranged_integer_argumentp")1077(rewrite '##sys#foreign-unsigned-ranged-integer-argument 17 2 "C_i_foreign_unsigned_ranged_integer_argumentp")10781079(rewrite 'chicken.bytevector#bytevector-length 2 1 "C_block_size" #f)10801081;; TODO: Move this stuff to types.db1082(rewrite 'chicken.number-vectors8vector-ref 2 2 "C_u_i_s8vector_ref" #f)1083(rewrite 'chicken.number-vectors8vector-ref 2 2 "C_i_s8vector_ref" #t)1084(rewrite 'chicken.number-vectoru16vector-ref 2 2 "C_u_i_u16vector_ref" #f)1085(rewrite 'chicken.number-vectoru16vector-ref 2 2 "C_i_u16vector_ref" #t)1086(rewrite 'chicken.number-vectors16vector-ref 2 2 "C_u_i_s16vector_ref" #f)1087(rewrite 'chicken.number-vectors16vector-ref 2 2 "C_i_s16vector_ref" #t)10881089(rewrite 'chicken.number-vectoru32vector-ref 16 2 "C_a_i_u32vector_ref" #t min-words-per-bignum)1090(rewrite 'chicken.number-vectors32vector-ref 16 2 "C_a_i_s32vector_ref" #t min-words-per-bignum)10911092(rewrite 'chicken.number-vectorf32vector-ref 16 2 "C_a_u_i_f32vector_ref" #f words-per-flonum)1093(rewrite 'chicken.number-vectorf32vector-ref 16 2 "C_a_i_f32vector_ref" #t words-per-flonum)1094(rewrite 'chicken.number-vectorf64vector-ref 16 2 "C_a_u_i_f64vector_ref" #f words-per-flonum)1095(rewrite 'chicken.number-vectorf64vector-ref 16 2 "C_a_i_f64vector_ref" #t words-per-flonum)10961097(rewrite 'chicken.number-vectoru8vector-set! 2 3 "C_u_i_u8vector_set" #f)1098(rewrite 'chicken.number-vectoru8vector-set! 2 3 "C_i_u8vector_set" #t)1099(rewrite 'chicken.number-vectors8vector-set! 2 3 "C_u_i_s8vector_set" #f)1100(rewrite 'chicken.number-vectors8vector-set! 2 3 "C_i_s8vector_set" #t)1101(rewrite 'chicken.number-vectoru16vector-set! 2 3 "C_u_i_u16vector_set" #f)1102(rewrite 'chicken.number-vectoru16vector-set! 2 3 "C_i_u16vector_set" #t)1103(rewrite 'chicken.number-vectors16vector-set! 2 3 "C_u_i_s16vector_set" #f)1104(rewrite 'chicken.number-vectors16vector-set! 2 3 "C_i_s16vector_set" #t)1105(rewrite 'chicken.number-vectoru32vector-set! 2 3 "C_u_i_u32vector_set" #f)1106(rewrite 'chicken.number-vectoru32vector-set! 2 3 "C_i_u32vector_set" #t)1107(rewrite 'chicken.number-vectors32vector-set! 2 3 "C_u_i_s32vector_set" #f)1108(rewrite 'chicken.number-vectors32vector-set! 2 3 "C_i_s32vector_set" #t)1109(rewrite 'chicken.number-vectoru64vector-set! 2 3 "C_u_i_u64vector_set" #f)1110(rewrite 'chicken.number-vectoru64vector-set! 2 3 "C_i_u64vector_set" #t)1111(rewrite 'chicken.number-vectors64vector-set! 2 3 "C_u_i_s64vector_set" #f)1112(rewrite 'chicken.number-vectors64vector-set! 2 3 "C_i_s64vector_set" #t)1113(rewrite 'chicken.number-vectorf32vector-set! 2 3 "C_u_i_f32vector_set" #f)1114(rewrite 'chicken.number-vectorf32vector-set! 2 3 "C_i_f32vector_set" #t)1115(rewrite 'chicken.number-vectorf64vector-set! 2 3 "C_u_i_f64vector_set" #f)1116(rewrite 'chicken.number-vectorf64vector-set! 2 3 "C_i_f64vector_set" #t)11171118(rewrite 'chicken.number-vectoru8vector-length 2 1 "C_u_i_bytevector_length" #f)1119(rewrite 'chicken.number-vectoru8vector-length 2 1 "C_i_bytevector_length" #t)1120(rewrite 'chicken.number-vectors8vector-length 2 1 "C_u_i_s8vector_length" #f)1121(rewrite 'chicken.number-vectors8vector-length 2 1 "C_i_s8vector_length" #t)1122(rewrite 'chicken.number-vectoru16vector-length 2 1 "C_u_i_u16vector_length" #f)1123(rewrite 'chicken.number-vectoru16vector-length 2 1 "C_i_u16vector_length" #t)1124(rewrite 'chicken.number-vectors16vector-length 2 1 "C_u_i_s16vector_length" #f)1125(rewrite 'chicken.number-vectors16vector-length 2 1 "C_i_s16vector_length" #t)1126(rewrite 'chicken.number-vectoru32vector-length 2 1 "C_u_i_u32vector_length" #f)1127(rewrite 'chicken.number-vectoru32vector-length 2 1 "C_i_u32vector_length" #t)1128(rewrite 'chicken.number-vectors32vector-length 2 1 "C_u_i_s32vector_length" #f)1129(rewrite 'chicken.number-vectors32vector-length 2 1 "C_i_s32vector_length" #t)1130(rewrite 'chicken.number-vectoru64vector-length 2 1 "C_u_i_u64vector_length" #f)1131(rewrite 'chicken.number-vectoru64vector-length 2 1 "C_i_u64vector_length" #t)1132(rewrite 'chicken.number-vectors64vector-length 2 1 "C_u_i_s64vector_length" #f)1133(rewrite 'chicken.number-vectors64vector-length 2 1 "C_i_s64vector_length" #t)1134(rewrite 'chicken.number-vectorf32vector-length 2 1 "C_u_i_f32vector_length" #f)1135(rewrite 'chicken.number-vectorf32vector-length 2 1 "C_i_f32vector_length" #t)1136(rewrite 'chicken.number-vectorf64vector-length 2 1 "C_u_i_f64vector_length" #f)1137(rewrite 'chicken.number-vectorf64vector-length 2 1 "C_i_f64vector_length" #t)11381139(rewrite 'chicken.base#atom? 17 1 "C_i_not_pair_p")11401141(rewrite 'chicken.number-vectors8vector->bytevector/shared 7 1 "C_slot" 1 #f)1142(rewrite 'chicken.number-vectoru16vector->bytevector/shared 7 1 "C_slot" 1 #f)1143(rewrite 'chicken.number-vectors16vector->bytevector/shared 7 1 "C_slot" 1 #f)1144(rewrite 'chicken.number-vectoru32vector->bytevector/shared 7 1 "C_slot" 1 #f)1145(rewrite 'chicken.number-vectors32vector->bytevector/shared 7 1 "C_slot" 1 #f)1146(rewrite 'chicken.number-vectoru64vector->bytevector/shared 7 1 "C_slot" 1 #f)1147(rewrite 'chicken.number-vectors64vector->bytevector/shared 7 1 "C_slot" 1 #f)1148(rewrite 'chicken.number-vectorf32vector->bytevector/shared 7 1 "C_slot" 1 #f)1149(rewrite 'chicken.number-vectorf64vector->bytevector/shared 7 1 "C_slot" 1 #f)1150(rewrite 'chicken.number-vectorc64vector->bytevector/shared 7 1 "C_slot" 1 #f)1151(rewrite 'chicken.number-vectorc128vector->bytevector/shared 7 1 "C_slot" 1 #f)11521153(let ()1154 (define (rewrite-make-vector db classargs cont callargs)1155 ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>))1156 ;; - <n> should be less or equal to 32.1157 (let ([argc (length callargs)])1158 (and (pair? callargs)1159 (let ([n (first callargs)])1160 (and (eq? 'quote (node-class n))1161 (let ([tmp (gensym)]1162 [c (first (node-parameters n))] )1163 (and (fixnum? c)1164 (<= 0 c 32)1165 (let ([val (if (pair? (cdr callargs))1166 (second callargs)1167 (make-node '##core#undefined '() '()) ) ] )1168 (make-node1169 'let1170 (list tmp)1171 (list val1172 (make-node1173 '##core#call (list #t)1174 (list cont1175 (make-node1176 '##core#inline_allocate1177 (list "C_a_i_vector" (add1 c))1178 (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) )1179 (rewrite 'scheme#make-vector 8 rewrite-make-vector)1180 (rewrite '##sys#make-vector 8 rewrite-make-vector) )11811182(let ()1183 (define (rewrite-call/cc db classargs cont callargs)1184 ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)1185 (and (= 1 (length callargs))1186 (let ((val (first callargs)))1187 (and (eq? '##core#variable (node-class val))1188 (and-let* ((proc (db-get db (first (node-parameters val)) 'value))1189 ((eq? '##core#lambda (node-class proc))) )1190 (let ((llist (third (node-parameters proc))))1191 (##sys#decompose-lambda-list1192 llist1193 (lambda (vars argc rest)1194 (and (= argc 2)1195 (let ((var (or rest (second llist))))1196 (and (not (db-get db var 'references))1197 (not (db-get db var 'assigned))1198 (not (db-get db var 'inline-transient))1199 (make-node1200 '##core#call (list #t)1201 (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )1202 (rewrite 'scheme#call-with-current-continuation 8 rewrite-call/cc)1203 (rewrite 'scheme#call/cc 8 rewrite-call/cc))12041205(define setter-map1206 '((scheme#car . scheme#set-car!)1207 (scheme#cdr . scheme#set-cdr!)1208 (scheme#string-ref . scheme#string-set!)1209 (scheme#vector-ref . scheme#vector-set!)1210 (chicken.number-vectoru8vector-ref . chicken.number-vectoru8vector-set!)1211 (chicken.number-vectors8vector-ref . chicken.number-vectors8vector-set!)1212 (chicken.number-vectoru16vector-ref . chicken.number-vectoru16vector-set!)1213 (chicken.number-vectors16vector-ref . chicken.number-vectors16vector-set!)1214 (chicken.number-vectoru32vector-ref . chicken.number-vectoru32vector-set!)1215 (chicken.number-vectors32vector-ref . chicken.number-vectors32vector-set!)1216 (chicken.number-vectoru64vector-ref . chicken.number-vectoru64vector-set!)1217 (chicken.number-vectors64vector-ref . chicken.number-vectors64vector-set!)1218 (chicken.number-vectorf32vector-ref . chicken.number-vectorf32vector-set!)1219 (chicken.number-vectorf64vector-ref . chicken.number-vectorf64vector-set!)1220 (chicken.number-vectorc64vector-ref . chicken.number-vectorc64vector-set!)1221 (chicken.number-vectorc128vector-ref . chicken.number-vectorc128vector-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)