~ chicken-core (chicken-5) /support.scm
Trap1;;;; support.scm - Miscellaneous support code for the CHICKEN compiler2;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(declare (unit support)29 (not inline ##sys#user-read-hook) ; XXX: Is this needed?30 (uses data-structures extras file internal pathname port))3132(module chicken.compiler.support33 (compiler-cleanup-hook bomb collected-debugging-output debugging34 debugging-chicken with-debugging-output quit-compiling35 emit-syntax-trace-info check-signature build-lambda-list36 c-ify-string valid-c-identifier? read-expressions37 bytes->words words->bytes replace-rest-op-with-list-ops38 check-and-open-input-file close-checked-input-file fold-inner39 constant? collapsable-literal? immediate? basic-literal?40 canonicalize-begin-body string->expr llist-length llist-match?41 expand-profile-lambda reset-profile-info-vector-name!42 profiling-prelude-exps db-get db-get-all db-put! collect! db-get-list43 make-node node? node-class node-class-set! node-parameters node-parameters-set!44 node-subexpressions node-subexpressions-set! varnode qnode45 build-node-graph build-expression-tree fold-boolean inline-lambda-bindings46 tree-copy copy-node! copy-node emit-global-inline-file load-inline-file47 match-node expression-has-side-effects? simple-lambda-node?48 dump-undefined-globals dump-defined-globals dump-global-refs49 make-foreign-callback-stub foreign-callback-stub?50 foreign-callback-stub-id foreign-callback-stub-name51 foreign-callback-stub-qualifiers foreign-callback-stub-return-type52 foreign-callback-stub-argument-types register-foreign-callback-stub!53 foreign-callback-stubs ; should not be exported54 foreign-type-check foreign-type-convert-result55 foreign-type-convert-argument final-foreign-type56 register-foreign-type! lookup-foreign-type clear-foreign-type-table!57 estimate-foreign-result-size estimate-foreign-result-location-size58 finish-foreign-result foreign-type->scrutiny-type scan-used-variables59 scan-free-variables60 make-block-variable-literal block-variable-literal?61 block-variable-literal-name make-random-name62 clear-real-name-table! get-real-name set-real-name!63 real-name real-name2 display-real-name-table64 source-info->string source-info->line source-info->name65 call-info constant-form-eval maybe-constant-fold-call66 dump-nodes read/source-info big-fixnum? small-bignum?67 hide-variable export-variable variable-hidden? variable-visible?68 mark-variable variable-mark intrinsic? predicate? foldable?69 load-identifier-database70 print-version print-usage print-debug-options7172 ;; XXX: These are evil globals that were too hairy to get rid of.73 ;; These values are set! by compiler and batch-driver, and read74 ;; in a lot of other places.75 number-type unsafe)7677(import scheme78 chicken.base79 chicken.bitwise80 chicken.blob81 chicken.condition82 chicken.file83 chicken.fixnum84 chicken.foreign85 chicken.format86 chicken.internal87 chicken.io88 chicken.keyword89 chicken.pathname90 chicken.platform91 chicken.plist92 chicken.port93 chicken.pretty-print94 chicken.sort95 chicken.string96 chicken.syntax97 chicken.time)9899(include "tweaks")100(include "mini-srfi-1.scm")101(include "banner")102103;; Evil globals104(define number-type 'generic)105(define unsafe #f)106107;;; Debugging and error-handling stuff:108109(define (compiler-cleanup-hook) #f)110111(define debugging-chicken '())112113(define (bomb . msg-and-args)114 (if (pair? msg-and-args)115 (apply error (string-append "[internal compiler error] " (car msg-and-args)) (cdr msg-and-args))116 (error "[internal compiler error]") ) )117118(define collected-debugging-output119 (open-output-string))120121(define +logged-debugging-modes+ '(o x S))122123(define (test-debugging-mode mode enabled)124 (if (symbol? mode)125 (memq mode enabled)126 (any (lambda (m) (memq m enabled)) mode)))127128(define (debugging mode msg . args)129 (define (text)130 (with-output-to-string131 (lambda ()132 (display msg)133 (when (pair? args)134 (display ": ")135 (for-each136 (lambda (x) (printf "~s " (force x)))137 args) )138 (newline))))139 (define (dump txt)140 (fprintf collected-debugging-output "~a|~a" mode txt))141 (cond ((test-debugging-mode mode debugging-chicken)142 (let ((txt (text)))143 (display txt)144 (flush-output)145 (when (test-debugging-mode mode +logged-debugging-modes+)146 (dump txt))147 #t))148 (else149 (when (test-debugging-mode mode +logged-debugging-modes+)150 (dump (text)))151 #f)))152153(define (with-debugging-output mode thunk)154 (define (collect text)155 (for-each156 (lambda (ln)157 (fprintf collected-debugging-output "~a|~a~%"158 (if (pair? mode) (car mode) mode)159 ln))160 (string-split text "\n")))161 (cond ((test-debugging-mode mode debugging-chicken)162 (let ((txt (with-output-to-string thunk)))163 (display txt)164 (flush-output)165 (when (test-debugging-mode mode +logged-debugging-modes+)166 (collect txt))))167 ((test-debugging-mode mode +logged-debugging-modes+)168 (collect (with-output-to-string thunk)))))169170(define (quit-compiling msg . args)171 (let ([out (current-error-port)])172 (apply fprintf out (string-append "\nError: " msg) args)173 (newline out)174 (exit 1) ) )175176(set! ##sys#syntax-error-hook177 (lambda (msg . args)178 (let ((out (current-error-port))179 (loc (and (symbol? msg)180 (let ((loc msg))181 (set! msg (car args))182 (set! args (cdr args))183 loc))))184 (if loc185 (fprintf out "\nSyntax error (~a): ~a~%~%" loc msg)186 (fprintf out "\nSyntax error: ~a~%~%" msg) )187 (for-each (cut fprintf out "\t~s~%" <>) args)188 (print-call-chain out 0 ##sys#current-thread "\n\tExpansion history:\n")189 (exit 70) ) ) )190191(set! syntax-error ##sys#syntax-error-hook)192193(define (emit-syntax-trace-info info cntr)194 (define (thread-id t) (##sys#slot t 14))195 (##core#inline "C_emit_syntax_trace_info" info cntr196 (thread-id ##sys#current-thread)))197198(define (map-llist proc llist)199 (let loop ([llist llist])200 (cond [(null? llist) '()]201 [(symbol? llist) (proc llist)]202 [else (cons (proc (car llist)) (loop (cdr llist)))] ) ) )203204(define (check-signature var args llist)205 (let loop ((as args) (ll llist))206 (cond ((null? ll) (null? as))207 ((symbol? ll))208 ((null? as) #f)209 (else (loop (cdr as) (cdr ll))) ) ) )210211212;;; Generic utility routines:213214(define (build-lambda-list vars argc rest)215 (let loop ((vars vars) (n argc))216 (cond ((or (zero? n) (null? vars)) (or rest '()))217 (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )218219;; XXX: Put this too in c-platform or c-backend?220(define (c-ify-string str)221 (list->string222 (cons223 #\"224 (let loop ((chars (string->list str)))225 (if (null? chars)226 '(#\")227 (let* ((c (car chars))228 (code (char->integer c)) )229 (if (or (< code 32) (>= code 127) (memq c '(#\" #\' #\\ #\? #\*)))230 (append '(#\\)231 (cond ((< code 8) '(#\0 #\0))232 ((< code 64) '(#\0))233 (else '()) )234 (string->list (number->string code 8))235 (loop (cdr chars)) )236 (cons c (loop (cdr chars))) ) ) ) ) ) ) )237238;; XXX: This too, but it's used only in core.scm, WTF?239(define (valid-c-identifier? name)240 (let ([str (string->list (->string name))])241 (and (pair? str)242 (let ([c0 (car str)])243 (and (or (char-alphabetic? c0) (char=? #\_ c0))244 (every (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))245 (cdr str)))))))246247;; TODO: Move these to (chicken memory)?248(define bytes->words (foreign-lambda int "C_bytestowords" int))249(define words->bytes (foreign-lambda int "C_wordstobytes" int))250251;; Used only in batch-driver; move it there?252(define (check-and-open-input-file fname . line)253 (cond ((string=? fname "-") (current-input-port))254 ((file-exists? fname) (open-input-file fname))255 ((or (null? line) (not (car line)))256 (quit-compiling "Can not open file ~s" fname))257 (else (quit-compiling "(~a) can not open file ~s" (car line) fname)) ) )258259(define (close-checked-input-file port fname)260 (unless (string=? fname "-") (close-input-port port)) )261262(define (fold-inner proc lst)263 (if (null? (cdr lst))264 lst265 (let fold ((xs (reverse lst)))266 (apply267 proc268 (if (null? (cddr xs))269 (list (cadr xs) (car xs))270 (list (fold (cdr xs)) (car xs)) ) ) ) ) )271272(define (follow-without-loop seed proc abort)273 (let loop ([x seed] [done '()])274 (if (member x done)275 (abort)276 (proc x (lambda (x2) (loop x2 (cons x done)))) ) ) )277278(define (sort-symbols lst)279 (sort lst (lambda (s1 s2) (string<? (symbol->string s1) (symbol->string s2)))))280281(define (read-expressions #!optional (port (current-input-port)))282 (do ((x (read port) (read port))283 (i 0 (add1 i))284 (xs '() (cons x xs)))285 ((eof-object? x) (reverse xs))))286287288;;; Predicates on expressions and literals:289290;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?291(define (bwp-object? x) (##core#inline "C_bwpp" x))292293(define (constant? x)294 (or (number? x)295 (char? x)296 (string? x)297 (boolean? x)298 (eof-object? x)299 (bwp-object? x)300 (blob? x)301 (vector? x)302 (##sys#srfi-4-vector? x)303 (and (pair? x) (eq? 'quote (car x))) ) )304305(define (collapsable-literal? x)306 (or (boolean? x)307 (char? x)308 (eof-object? x)309 (bwp-object? x)310 (number? x)311 (symbol? x) ) )312313(define (immediate? x)314 (or (and (fixnum? x) (not (big-fixnum? x))) ; 64-bit fixnums would result in platform-dependent .c files315 (eq? (##core#undefined) x)316 (null? x)317 (eof-object? x)318 (bwp-object? x)319 (char? x)320 (boolean? x) ) )321322(define (basic-literal? x)323 (or (null? x)324 (symbol? x)325 (constant? x)326 (and (vector? x) (every basic-literal? (vector->list x)))327 (and (pair? x)328 (basic-literal? (car x))329 (basic-literal? (cdr x)) ) ) )330331332;;; Expression manipulation:333334(define (canonicalize-begin-body body)335 (let loop ((xs body))336 (cond ((null? xs) '(##core#undefined))337 ((null? (cdr xs)) (car xs))338 ((let ([h (car xs)])339 (or (equal? h '(##core#undefined))340 (constant? h)341 (equal? h '(##sys#void)) ) )342 (loop (cdr xs)) )343 (else `(let ((,(gensym 't) ,(car xs)))344 ,(loop (cdr xs))) ) ) ) )345346;; Only used in batch-driver: move it there?347(define string->expr348 (let ([exn? (condition-predicate 'exn)]349 [exn-msg (condition-property-accessor 'exn 'message)] )350 (lambda (str)351 (handle-exceptions ex352 (quit-compiling "cannot parse expression: ~s [~a]~%"353 str354 (if (exn? ex)355 (exn-msg ex)356 (->string ex) ) )357 (let ((xs (with-input-from-string358 str359 (lambda ()360 (let loop ((lst '()))361 (let ((x (read)))362 (if (eof-object? x)363 (reverse lst)364 (loop (cons x lst)))))))))365 (cond [(null? xs) '(##core#undefined)]366 [(null? (cdr xs)) (car xs)]367 [else `(begin ,@xs)] ) ) ) ) ) )368369;; Only used in optimizer; move it there? But it's a C function call, so370;; it may be better in c-platform371(define (llist-length llist)372 (##core#inline "C_u_i_length" llist)) ; stops at non-pair node373374(define (llist-match? llist args) ; assumes #!optional/#!rest/#!key have been expanded375 (let loop ((llist llist) (args args))376 (cond ((null? llist) (null? args))377 ((symbol? llist))378 ((null? args) (atom? llist))379 (else (loop (cdr llist) (cdr args))))))380381382;;; Profiling instrumentation:383(define profile-info-vector-name #f)384(define (reset-profile-info-vector-name!)385 (set! profile-info-vector-name (make-random-name 'profile-info)))386387(define profile-lambda-list '())388(define profile-lambda-index 0)389390(define (expand-profile-lambda name llist body)391 (let ([index profile-lambda-index]392 [args (gensym)] )393 (set! profile-lambda-list (alist-cons index name profile-lambda-list))394 (set! profile-lambda-index (add1 index))395 `(##core#lambda ,args396 (##sys#dynamic-wind397 (##core#lambda () (##sys#profile-entry ',index ,profile-info-vector-name))398 (##core#lambda () (##sys#apply (##core#lambda ,llist ,body) ,args))399 (##core#lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )400401;; Get expressions which initialize and populate the profiling vector402(define (profiling-prelude-exps profile-name)403 `((set! ,profile-info-vector-name404 (##sys#register-profile-info405 ',(length profile-lambda-list)406 ',profile-name))407 ,@(map (lambda (pl)408 `(##sys#set-profile-info-vector!409 ,profile-info-vector-name410 ',(car pl)411 ',(cdr pl) ) )412 profile-lambda-list)))413414;;; Database operations:415416(define (db-get db key prop)417 (let ((plist (hash-table-ref db key)))418 (and plist419 (let ([a (assq prop plist)])420 (and a (##sys#slot a 1)) ) ) ) )421422(define (db-get-all db key . props)423 (let ((plist (hash-table-ref db key)))424 (if plist425 (filter-map (lambda (prop) (assq prop plist)) props)426 '() ) ) )427428(define (db-put! db key prop val)429 (let ((plist (hash-table-ref db key)))430 (if plist431 (let ([a (assq prop plist)])432 (cond [a (##sys#setslot a 1 val)]433 [val (##sys#setslot plist 1 (alist-cons prop val (##sys#slot plist 1)))] ) )434 (when val (hash-table-set! db key (list (cons prop val)))))))435436(define (collect! db key prop val)437 (let ((plist (hash-table-ref db key)))438 (if plist439 (let ([a (assq prop plist)])440 (cond [a (##sys#setslot a 1 (cons val (##sys#slot a 1)))]441 [else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) )442 (hash-table-set! db key (list (list prop val))))))443444(define (db-get-list db key prop) ; returns '() if not set445 (let ((x (db-get db key prop)))446 (or x '())))447448449;;; Node creation and -manipulation:450451;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".452453(define-record-type node454 (make-node class parameters subexpressions)455 node?456 (class node-class node-class-set!) ; symbol457 (parameters node-parameters node-parameters-set!) ; (value...)458 (subexpressions node-subexpressions node-subexpressions-set!)) ; (node...)459460(set-record-printer! node461 (lambda (n out)462 (fprintf out "#<node ~a ~a>" (node-class n) (node-parameters n))))463464(define (make-node c p s)465 (##sys#make-structure 'chicken.compiler.support#node c p s))466467(define (varnode var) (make-node '##core#variable (list var) '()))468(define (qnode const) (make-node 'quote (list const) '()))469470(define (build-node-graph exp)471 (let ((count 0))472 (define (walk x)473 (cond ((symbol? x) (varnode x))474 ((node? x) x)475 ((not (pair? x)) (bomb "bad expression" x))476 ((symbol? (car x))477 (case (car x)478 ((if ##core#undefined) (make-node (car x) '() (map walk (cdr x))))479 ((quote)480 (let ((c (cadr x)))481 (qnode (if (and (number? c)482 (eq? 'fixnum number-type)483 (not (integer? c)) )484 (begin485 (warning486 "literal is out of range - will be truncated to integer" c)487 (inexact->exact (truncate c)) )488 c) ) ) )489 ((let)490 (let ([bs (cadr x)]491 [body (caddr x)] )492 (if (null? bs)493 (walk body)494 (make-node495 'let (unzip1 bs)496 (append (map (lambda (b) (walk (cadr b))) (cadr x))497 (list (walk body)) ) ) ) ) )498 ((lambda ##core#lambda)499 (make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))500 ((##core#the)501 (make-node '##core#the502 (list (second x) (third x))503 (list (walk (fourth x)))))504 ((##core#typecase)505 ;; clause-head is already stripped506 (let loop ((cls (cdddr x)) (types '()) (exps (list (walk (caddr x)))))507 (cond ((null? cls) ; no "else" clause given508 (make-node509 '##core#typecase510 (cons (cadr x) (reverse types))511 (reverse512 (cons (make-node '##core#undefined '() '()) exps))))513 ((eq? 'else (caar cls))514 (make-node515 '##core#typecase516 (cons (cadr x) (reverse (cons '* types)))517 (reverse (cons (walk (cadar cls)) exps))))518 (else (loop (cdr cls)519 (cons (caar cls) types)520 (cons (walk (cadar cls)) exps))))))521 ((##core#primitive)522 (let ((arg (cadr x)))523 (make-node524 (car x)525 (list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))526 (map walk (cddr x)) ) ) )527 ((##core#inline ##core#provide ##core#callunit)528 (make-node (car x) (list (cadr x)) (map walk (cddr x))) )529 ((##core#debug-event) ; 2nd argument is provided by canonicalization phase530 (make-node (car x) (cdr x) '()))531 ((##core#proc)532 (make-node '##core#proc (list (cadr x) #t) '()) )533 ((set! ##core#set!)534 (make-node535 'set! (list (cadr x))536 (map walk (cddr x))))537 ((##core#foreign-callback-wrapper)538 (let ([name (cadr (second x))])539 (make-node540 '##core#foreign-callback-wrapper541 (list name (cadr (third x)) (cadr (fourth x)) (cadr (fifth x)))542 (list (walk (list-ref x 5))) ) ) )543 ((##core#inline_allocate ##core#inline_ref ##core#inline_update544 ##core#inline_loc_ref ##core#inline_loc_update)545 (make-node (first x) (second x) (map walk (cddr x))) )546 ((##core#app)547 (make-node '##core#call (list #t) (map walk (cdr x))) )548 (else549 (receive (name ln) (##sys#get-line-2 x)550 (make-node551 '##core#call552 (list (cond [(variable-mark name '##compiler#always-bound-to-procedure)553 (set! count (add1 count))554 #t]555 [else #f] )556 (if ln557 (let ([rn (real-name name)])558 (list ln559 (or rn (##sys#symbol->string name))) )560 (##sys#symbol->string name) ) )561 (map walk x) ) ) ) ) )562 (else (make-node '##core#call (list #f) (map walk x))) ) )563 (let ([exp2 (walk exp)])564 (when (positive? count)565 (debugging 'o "eliminated procedure checks" count)) ;XXX perhaps throw this out566 exp2) ) )567568(define (build-expression-tree node)569 (let walk ((n node))570 (let ((subs (node-subexpressions n))571 (params (node-parameters n))572 (class (node-class n)) )573 (case class574 ((if ##core#box ##core#cond) (cons class (map walk subs)))575 ((##core#closure)576 `(##core#closure ,params ,@(map walk subs)) )577 ((##core#variable) (car params))578 ((quote)579 (let ((c (car params)))580 (if (or (boolean? c) (string? c) (number? c) (char? c))581 c582 `(quote ,(car params)))))583 ((let)584 `(let ,(map list params (map walk (butlast subs)))585 ,(walk (last subs)) ) )586 ((##core#lambda)587 (list (if (second params)588 'lambda589 '##core#lambda)590 (third params)591 (walk (car subs)) ) )592 ((##core#the)593 `(the ,(first params) ,(walk (first subs))))594 ((##core#the/result)595 (walk (first subs)))596 ((##core#typecase)597 `(compiler-typecase598 ,(walk (first subs))599 ,@(let loop ((types (cdr params)) (bodies (cdr subs)))600 (if (null? types)601 (if (null? bodies)602 '()603 `((else ,(walk (car bodies)))))604 (cons (list (car types) (walk (car bodies)))605 (loop (cdr types) (cdr bodies)))))))606 ((##core#call)607 (map walk subs))608 ((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))609 ((##core#undefined) (list class))610 ((##core#bind)611 (let loop ((n (car params)) (vals subs) (bindings '()))612 (if (zero? n)613 `(##core#bind ,(reverse bindings) ,(walk (car vals)))614 (loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )615 ((##core#unbox ##core#ref ##core#update ##core#update_i)616 (cons* class (walk (car subs)) params (map walk (cdr subs))) )617 ((##core#inline_allocate)618 (cons* class params (map walk subs)))619 (else (cons class (append params (map walk subs)))) ) ) ) )620621(define (fold-boolean proc lst)622 (let fold ([vars lst])623 (if (null? (cddr vars))624 (apply proc vars)625 (make-node626 '##core#inline '("C_and")627 (list (proc (first vars) (second vars))628 (fold (cdr vars)) ) ) ) ) )629630;; Move to optimizer.scm?631(define (inline-lambda-bindings llist args body copy? db cfk)632 (##sys#decompose-lambda-list633 llist634 (lambda (vars argc rest)635 (receive (largs rargs) (split-at args argc)636 (let* ((rlist (if copy? (map gensym vars) vars))637 (body (if copy?638 (copy-node-tree-and-rename body vars rlist db cfk)639 body) )640 (rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )641 (replace-rest-ops-in-known-call! db body rest (last rlist) rarg-aliases)642643 ;; Make sure rest ops aren't replaced after inlining (#1658)644 ;; argvector does not belong to the same procedure anymore.645 (when rest646 (for-each (lambda (v)647 (db-put! db v 'rest-cdr #f)648 (db-put! db v 'rest-null? #f) )649 (db-get-list db rest 'derived-rest-vars) )650 (db-put! db rest 'rest-cdr #f)651 (db-put! db rest 'derived-rest-vars '()) )652653 (let loop ((vars (take rlist argc))654 (vals largs))655 (if (null? vars)656 (if rest657 ;; NOTE: If contraction happens before rest-op658 ;; detection, we might needlessly build a list.659 (let loop2 ((rarg-values rargs)660 (rarg-aliases rarg-aliases))661 (if (null? rarg-aliases)662 (if (null? (db-get-list db rest 'references))663 body664 (make-node665 'let (list (last rlist))666 (list (if (null? rargs)667 (qnode '())668 (make-node669 '##core#inline_allocate670 (list "C_a_i_list" (* 3 (length rargs)))671 rargs) )672 body) ))673 (make-node 'let (list (car rarg-aliases))674 (list (car rarg-values)675 (loop2 (cdr rarg-values) (cdr rarg-aliases))))))676 body)677 (make-node 'let (list (car vars))678 (list (car vals)679 (loop (cdr vars) (cdr vals)))))))))))680681;; Copy along with the above682(define (copy-node-tree-and-rename node vars aliases db cfk)683 (let ((rlist (map cons vars aliases)))684 (define (rename v rl) (alist-ref v rl eq? v))685 (define (walk n rl)686 (let ((subs (node-subexpressions n))687 (params (node-parameters n))688 (class (node-class n)) )689 (case class690 ((quote)691 (make-node class params '()))692 ((##core#variable)693 (let ((var (first params)))694 (when (db-get db var 'contractable)695 (cfk var))696 (varnode (rename var rl))) )697 ((set!)698 (make-node699 'set! (list (rename (first params) rl))700 (list (walk (first subs) rl)) ) )701 ((let)702 (let* ((v (first params))703 (val1 (walk (first subs) rl))704 (a (gensym v))705 (rl2 (alist-cons v a rl)) )706 (db-put! db a 'inline-transient #t)707 (make-node708 'let (list a)709 (list val1 (walk (second subs) rl2)))) )710 ((##core#lambda)711 (##sys#decompose-lambda-list712 (third params)713 (lambda (vars argc rest)714 (let* ((as (map (lambda (v)715 (let ((a (gensym v)))716 (db-put! db v 'inline-transient #t)717 a))718 vars) )719 (rl2 (append (map cons vars as) rl)) )720 (make-node721 '##core#lambda722 (list (gensym 'f) (second params) ; new function-id723 (build-lambda-list as argc (and rest (rename rest rl2)))724 (fourth params) )725 (map (cut walk <> rl2) subs) ) ) ) ) )726 (else (make-node class (tree-copy params)727 (map (cut walk <> rl) subs))) ) ) )728 (walk node rlist) ) )729730;; Replace rest-{car,cdr,null?} with equivalent code which accesses731;; the rest argument directly.732(define (replace-rest-ops-in-known-call! db node rest-var rest-alias rest-args)733 (define (walk n)734 (let ((subs (node-subexpressions n))735 (params (node-parameters n))736 (class (node-class n)) )737 (case class738 ((##core#rest-null?)739 (if (eq? rest-var (first params))740 (copy-node! (qnode (<= (length rest-args) (second params))) n)741 n))742 ((##core#rest-car)743 (if (eq? rest-var (first params))744 (let ((depth (second params))745 (len (length rest-args)))746 (if (> len depth)747 (copy-node! (varnode (list-ref rest-args depth)) n)748 (copy-node! (make-node '##core#inline749 (list "C_rest_arg_out_of_bounds_error_value")750 (list (qnode len) (qnode depth) (qnode 0)))751 n)))752 n))753 ((##core#rest-cdr)754 (cond ((eq? rest-var (first params))755 (collect! db rest-var 'references n) ; Restore this reference756 (let lp ((i (add1 (second params)))757 (new-node (varnode rest-alias)))758 (if (zero? i)759 (copy-node! new-node n)760 (lp (sub1 i)761 (make-node '##core#inline (list "C_i_cdr") (list new-node))))))762 (else n)))763 (else (for-each walk subs)) ) ) )764765 (walk node) )766767(define (replace-rest-op-with-list-ops class rest-var-node params)768 (case class769 ((##core#rest-car)770 (make-node '##core#inline771 (list "C_i_list_ref")772 (list rest-var-node (qnode (second params)))))773 ((##core#rest-cdr)774 (let lp ((cdr-calls (add1 (second params)))775 (var rest-var-node))776 (if (zero? cdr-calls)777 var778 (lp (sub1 cdr-calls)779 (make-node '##core#inline (list "C_i_cdr") (list var))))))780 ((##core#rest-null?)781 (make-node '##core#inline782 (list "C_i_greater_or_equalp")783 (list (qnode (second params))784 (make-node '##core#inline (list "C_i_length") (list rest-var-node)))))785 ((##core#rest-length)786 (make-node '##core#inline787 (list "C_i_length")788 (list rest-var-node (qnode (second params)))))789 (else (bomb "Unknown rest op node class while undoing rest op for explicitly consed rest arg. This shouldn't happen!" class))))790791;; Maybe move to scrutinizer. It's generic enough to keep it here though792(define (tree-copy t)793 (let rec ([t t])794 (if (pair? t)795 (cons (rec (car t)) (rec (cdr t)))796 t) ) )797798(define (copy-node n)799 (make-node (node-class n)800 (node-parameters n)801 (node-subexpressions n)))802803(define (copy-node! from to)804 (node-class-set! to (node-class from))805 (node-parameters-set! to (node-parameters from))806 (node-subexpressions-set! to (node-subexpressions from))807 to)808809(define (node->sexpr n)810 (let walk ((n n))811 `(,(node-class n)812 ,(node-parameters n)813 ,@(map walk (node-subexpressions n)))))814815(define (sexpr->node x)816 (let walk ((x x))817 (make-node (car x) (cadr x) (map walk (cddr x)))))818819;; Only used in batch-driver.scm820(define (emit-global-inline-file source-file inline-file db821 block-compilation inline-limit822 foreign-stubs)823 (define (uses-foreign-stubs? node)824 (let walk ((n node))825 (case (node-class n)826 ((##core#inline)827 (memq (car (node-parameters n)) foreign-stubs))828 (else829 (any walk (node-subexpressions n))))))830 (let ((lst '())831 (out '()))832 (hash-table-for-each833 (lambda (sym plist)834 (when (variable-visible? sym block-compilation)835 (and-let* ((val (assq 'local-value plist))836 ((not (node? (variable-mark sym '##compiler#inline-global))))837 ((let ((val (assq 'value plist)))838 (or (not val)839 (not (eq? 'unknown (cdr val))))))840 ((assq 'inlinable plist))841 (lparams (node-parameters (cdr val)))842 ((not (db-get db sym 'hidden-refs)))843 ((case (variable-mark sym '##compiler#inline)844 ((yes) #t)845 ((no) #f)846 (else847 (< (fourth lparams) inline-limit))))848 ;; See #1440849 ((not (uses-foreign-stubs? (cdr val)))))850 (set! lst (cons sym lst))851 (set! out (cons (list sym (node->sexpr (cdr val))) out)))))852 db)853 (with-output-to-file inline-file854 (lambda ()855 (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "856 source-file "\n")857 (for-each858 (lambda (x)859 (pp x)860 (newline))861 (reverse out))862 (print "; END OF FILE")))863 (when (and (pair? lst)864 (debugging 'i "the following procedures can be globally inlined:"))865 (for-each (cut print " " <>) (sort-symbols lst)))))866867;; Used only in batch-driver.scm868(define (load-inline-file fname)869 (with-input-from-file fname870 (lambda ()871 (let loop ()872 (let ((x (read)))873 (unless (eof-object? x)874 (mark-variable875 (car x)876 '##compiler#inline-global877 (sexpr->node (cadr x)))878 (loop)))))))879880881;;; Match node-structure with pattern:882883(define (match-node node pat vars) ; Only used in optimizer.scm884 (let ((env '()))885886 (define (resolve v x)887 (cond ((assq v env) => (lambda (a) (equal? x (cdr a))))888 ((memq v vars)889 (set! env (alist-cons v x env))890 #t)891 (else (eq? v x)) ) )892893 (define (match1 x p)894 (cond ((not (pair? p)) (resolve p x))895 ((not (pair? x)) #f)896 ((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))897 (else #f) ) )898899 (define (matchn n p)900 (if (not (pair? p))901 (resolve p n)902 (and (eq? (node-class n) (first p))903 (match1 (node-parameters n) (second p))904 (let loop ((ns (node-subexpressions n))905 (ps (cddr p)) )906 (cond ((null? ps) (null? ns))907 ((not (pair? ps)) (resolve ps ns))908 ((null? ns) #f)909 (else (and (matchn (car ns) (car ps))910 (loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )911912 (let ((r (matchn node pat)))913 (and r914 (begin915 (debugging 'a "matched" (node-class node) (node-parameters node) pat)916 env) ) ) ) )917918919;;; Test nodes for certain properties:920921(define (expression-has-side-effects? node db)922 (let walk ([n node])923 (let ([subs (node-subexpressions n)])924 (case (node-class n)925 [(##core#variable quote ##core#undefined ##core#proc) #f]926 [(##core#lambda)927 (let ([id (first (node-parameters n))])928 (find (lambda (fs)929 (eq? id (foreign-callback-stub-id fs)))930 foreign-callback-stubs) ) ]931 [(if let) (any walk subs)]932 [else #t] ) ) ) )933934(define (simple-lambda-node? node) ; Used only in compiler.scm935 (let* ([params (node-parameters node)]936 [llist (third params)]937 [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument938 (and k939 (second params)940 (let rec ([n node])941 (case (node-class n)942 [(##core#call)943 (let* ([subs (node-subexpressions n)]944 [f (first subs)] )945 (and (eq? '##core#variable (node-class f))946 (eq? k (first (node-parameters f)))947 (every rec (cdr subs)) ) ) ]948 [(##core#callunit) #f]949 [else (every rec (node-subexpressions n))] ) ) ) ) )950951952;;; Some safety checks and database dumping:953954(define (dump-undefined-globals db) ; Used only in batch-driver.scm955 (hash-table-for-each956 (lambda (sym plist)957 (when (and (not (keyword? sym))958 (assq 'global plist)959 (not (assq 'assigned plist)) )960 (write sym)961 (newline) ) )962 db) )963964(define (dump-defined-globals db) ; Used only in batch-driver.scm965 (hash-table-for-each966 (lambda (sym plist)967 (when (and (not (keyword? sym))968 (assq 'global plist)969 (assq 'assigned plist))970 (write sym)971 (newline) ) )972 db) )973974(define (dump-global-refs db) ; Used only in batch-driver.scm975 (hash-table-for-each976 (lambda (sym plist)977 (when (and (not (keyword? sym)) (assq 'global plist))978 (let ((a (assq 'references plist)))979 (write (list sym (if a (length (cdr a)) 0)))980 (newline) ) ) )981 db) )982983984;;; change hook function to hide non-exported module bindings985986(set! ##sys#toplevel-definition-hook987 (lambda (sym renamed exported?)988 (cond ((namespaced-symbol? sym)989 (unhide-variable sym))990 ((not exported?)991 (debugging 'o "hiding unexported module binding" renamed)992 (hide-variable renamed)))))993994995;;; Foreign callback stub and type tables:996997(define foreign-callback-stubs '())998999(define-record-type foreign-callback-stub1000 (make-foreign-callback-stub id name qualifiers return-type argument-types)1001 foreign-callback-stub?1002 (id foreign-callback-stub-id) ; symbol1003 (name foreign-callback-stub-name) ; string1004 (qualifiers foreign-callback-stub-qualifiers) ; string1005 (return-type foreign-callback-stub-return-type) ; type-specifier1006 (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)10071008(define (register-foreign-callback-stub! id params)1009 (set! foreign-callback-stubs1010 (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )1011 ;; mark to avoid leaf-routine optimization1012 (mark-variable id '##compiler#callback-lambda))10131014(define-constant foreign-type-table-size 301)10151016(define foreign-type-table #f)10171018(define (clear-foreign-type-table!)1019 (if foreign-type-table1020 (vector-fill! foreign-type-table '())1021 (set! foreign-type-table (make-vector foreign-type-table-size '())) ))10221023;; Register a foreign type under the given alias. type is the foreign1024;; type's name, arg and ret are the *names* of conversion procedures1025;; when this type is used as argument or return value, respectively.1026;; The latter two must either both be supplied, or neither.1027;; TODO: Maybe create a separate record type for foreign types?1028(define (register-foreign-type! alias type #!optional arg ret)1029 (hash-table-set! foreign-type-table alias1030 (vector type (and ret arg) (and arg ret))))10311032;; Returns either #f (if t does not exist) or a vector with the type,1033;; the *name* of the argument conversion procedure and the *name* of1034;; the return value conversion procedure. If no conversion procedures1035;; have been supplied, the corresponding slots will be #f.1036(define (lookup-foreign-type t)1037 (hash-table-ref foreign-type-table t))10381039;;; Create foreign type checking expression:10401041(define foreign-type-check ; Used only in compiler.scm1042 (let ((tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)1043 (nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)1044 (nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)1045 (nonnull-u64vector . u64vector) (nonnull-s64vector . s64vector)1046 (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector)))1047 (ftmap '((integer . "int") (unsigned-integer . "unsigned int")1048 (integer32 . "C_s32") (unsigned-integer32 . "C_u32")1049 (integer64 . "C_s64") (unsigned-integer64 . "C_u64")1050 (short . "short") (unsigned-short . "unsigned short")1051 (long . "long") (unsigned-long . "unsigned long")1052 (ssize_t . "ssize_t") (size_t . "size_t"))))1053 (lambda (param type)1054 (follow-without-loop1055 type1056 (lambda (t next)1057 (let repeat ((t t))1058 (case t1059 ((char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param)))1060 ;; TODO: Should "[unsigned-]byte" be range checked?1061 ((int unsigned-int byte unsigned-byte int32 unsigned-int32)1062 (if unsafe param `(##sys#foreign-fixnum-argument ,param)))1063 ((float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param)))1064 ((blob scheme-pointer)1065 (let ((tmp (gensym)))1066 `(##core#let ((,tmp ,param))1067 (##core#if ,tmp1068 ,(if unsafe1069 tmp1070 `(##sys#foreign-block-argument ,tmp) )1071 (##core#quote #f)) ) ) )1072 ((nonnull-scheme-pointer nonnull-blob)1073 (if unsafe1074 param1075 `(##sys#foreign-block-argument ,param) ) )1076 ((pointer-vector)1077 (let ((tmp (gensym)))1078 `(##core#let ((,tmp ,param))1079 (##core#if ,tmp1080 ,(if unsafe1081 tmp1082 `(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,tmp) )1083 (##core#quote #f)) ) ) )1084 ((nonnull-pointer-vector)1085 (if unsafe1086 param1087 `(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,param) ) )1088 ((u8vector u16vector s8vector s16vector u32vector s32vector1089 u64vector s64vector f32vector f64vector)1090 (let ((tmp (gensym)))1091 `(##core#let ((,tmp ,param))1092 (##core#if ,tmp1093 ,(if unsafe1094 tmp1095 `(##sys#foreign-struct-wrapper-argument (##core#quote ,t) ,tmp) )1096 (##core#quote #f)) ) ) )1097 ((nonnull-u8vector nonnull-u16vector1098 nonnull-s8vector nonnull-s16vector1099 nonnull-u32vector nonnull-s32vector1100 nonnull-u64vector nonnull-s64vector1101 nonnull-f32vector nonnull-f64vector)1102 (if unsafe1103 param1104 `(##sys#foreign-struct-wrapper-argument1105 (##core#quote ,(##sys#slot (assq t tmap) 1))1106 ,param) ) )1107 ((integer32 integer64 integer short long ssize_t)1108 (let* ((foreign-type (##sys#slot (assq t ftmap) 1))1109 (size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))1110 (if unsafe1111 param1112 `(##sys#foreign-ranged-integer-argument1113 ,param (foreign-value ,size-expr int)))))1114 ((unsigned-short unsigned-long unsigned-integer size_t1115 unsigned-integer32 unsigned-integer64)1116 (let* ((foreign-type (##sys#slot (assq t ftmap) 1))1117 (size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))1118 (if unsafe1119 param1120 `(##sys#foreign-unsigned-ranged-integer-argument1121 ,param (foreign-value ,size-expr int)))))1122 ((c-pointer c-string-list c-string-list*)1123 (let ((tmp (gensym)))1124 `(##core#let ((,tmp ,param))1125 (##core#if ,tmp1126 (##sys#foreign-pointer-argument ,tmp)1127 (##core#quote #f)) ) ) )1128 ((nonnull-c-pointer)1129 `(##sys#foreign-pointer-argument ,param) )1130 ((c-string c-string* unsigned-c-string unsigned-c-string*)1131 (let ((tmp (gensym)))1132 `(##core#let ((,tmp ,param))1133 (##core#if ,tmp1134 ,(if unsafe1135 `(##sys#make-c-string ,tmp)1136 `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )1137 (##core#quote #f)) ) ) )1138 ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)1139 (if unsafe1140 `(##sys#make-c-string ,param)1141 `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) )1142 ((symbol)1143 (if unsafe1144 `(##sys#make-c-string (##sys#symbol->string ,param))1145 `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) )1146 (else1147 (cond ((and (symbol? t) (lookup-foreign-type t))1148 => (lambda (t) (next (vector-ref t 0)) ) )1149 ((pair? t)1150 (case (car t)1151 ((ref pointer function c-pointer)1152 (let ((tmp (gensym)))1153 `(##core#let ((,tmp ,param))1154 (##core#if ,tmp1155 (##sys#foreign-pointer-argument ,tmp)1156 (##core#quote #f)) ) ) )1157 ((instance instance-ref)1158 (let ((tmp (gensym)))1159 `(##core#let ((,tmp ,param))1160 (##core#if ,tmp1161 (slot-ref ,param (##core#quote this))1162 (##core#quote #f)) ) ) )1163 ((scheme-pointer)1164 (let ((tmp (gensym)))1165 `(##core#let ((,tmp ,param))1166 (##core#if ,tmp1167 ,(if unsafe1168 tmp1169 `(##sys#foreign-block-argument ,tmp) )1170 (##core#quote #f)) ) ) )1171 ((nonnull-scheme-pointer)1172 (if unsafe1173 param1174 `(##sys#foreign-block-argument ,param) ) )1175 ((nonnull-instance)1176 `(slot-ref ,param (##core#quote this)) )1177 ((const) (repeat (cadr t)))1178 ((enum)1179 (if unsafe1180 param1181 `(##sys#foreign-ranged-integer-argument1182 ;; enums are integer size, according to the C standard.1183 ,param (foreign-value "sizeof(int) * CHAR_BIT" int))))1184 ((nonnull-pointer nonnull-c-pointer)1185 `(##sys#foreign-pointer-argument ,param) )1186 (else param) ) )1187 (else param) ) ) ) ) )1188 (lambda ()1189 (quit-compiling "foreign type `~S' refers to itself" type)) ) ) ) )119011911192;;; Compute foreign-type conversions:11931194(define (foreign-type-result-converter t)1195 (and-let* (((symbol? t))1196 (ft (lookup-foreign-type t))1197 (retconv (vector-ref ft 2)) )1198 retconv))11991200(define (foreign-type-argument-converter t)1201 (and-let* (((symbol? t))1202 (ft (lookup-foreign-type t))1203 (argconv (vector-ref ft 1)) )1204 argconv))12051206(define (foreign-type-convert-result r t) ; Used only in compiler.scm1207 (or (and-let* ((retconv (foreign-type-result-converter t)))1208 (list retconv r) )1209 r) )12101211(define (foreign-type-convert-argument a t) ; Used only in compiler.scm1212 (or (and-let* ((argconv (foreign-type-argument-converter t)) )1213 (list argconv a) )1214 a) )12151216(define (final-foreign-type t0) ; Used here and in compiler.scm1217 (follow-without-loop1218 t01219 (lambda (t next)1220 (cond ((and (symbol? t) (lookup-foreign-type t))1221 => (lambda (t2) (next (vector-ref t2 0)) ) )1222 (else t) ) )1223 (lambda () (quit-compiling "foreign type `~S' refers to itself" t0)) ) )122412251226;;; Compute foreign result size:12271228(define (estimate-foreign-result-size type)1229 (define (err t)1230 (quit-compiling "cannot compute size for unknown foreign type `~S' result" type))1231 (follow-without-loop1232 type1233 (lambda (t next)1234 (case t1235 ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte1236 int32 unsigned-int32)1237 0)1238 ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*1239 unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*1240 c-string-list c-string-list*)1241 (words->bytes 3) )1242 ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)1243 (words->bytes 6) ) ; 1 bignum digit on 32-bit (overallocs on 64-bit)1244 ((float double number)1245 (words->bytes 4) ) ; possibly 8-byte aligned 64-bit double1246 ((integer64 unsigned-integer64 size_t ssize_t)1247 (words->bytes 7)) ; 2 bignum digits on 32-bit (overallocs on 64-bit)1248 (else1249 (cond ((and (symbol? t) (lookup-foreign-type t))1250 => (lambda (t2) (next (vector-ref t2 0)) ) )1251 ((pair? t)1252 (case (car t)1253 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)1254 (words->bytes 3) )1255 ((const) (next (cadr t)))1256 ((enum) (words->bytes 6)) ; 1 bignum digit on 32-bit (overallocs on 64-bit)1257 (else (err t))))1258 (else (err t))))))1259 (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )12601261(define (estimate-foreign-result-location-size type) ; Used only in compiler.scm1262 (define (err t)1263 (quit-compiling "cannot compute size of location for foreign type `~S'" t) )1264 (follow-without-loop1265 type1266 (lambda (t next)1267 (case t1268 ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte1269 unsigned-byte c-pointer nonnull-c-pointer unsigned-integer integer float c-string symbol1270 scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer321271 unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*1272 nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*)1273 (words->bytes 1) )1274 ((double integer64 unsigned-integer64 size_t ssize_t)1275 (words->bytes 2) )1276 (else1277 (cond ((and (symbol? t) (lookup-foreign-type t))1278 => (lambda (t2) (next (vector-ref t2 0)) ) )1279 ((pair? t)1280 (case (car t)1281 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function1282 scheme-pointer nonnull-scheme-pointer enum)1283 (words->bytes 1))1284 ((const) (next (cadr t)))1285 (else (err t)) ) )1286 (else (err t)) ) ) ) )1287 (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )128812891290;;; Convert result value, if a string:12911292(define (finish-foreign-result type body) ; Used only in compiler.scm1293 (let ((type (strip-syntax type)))1294 (case type1295 ((c-string unsigned-c-string) `(##sys#peek-c-string ,body (##core#quote 0)))1296 ((nonnull-c-string) `(##sys#peek-nonnull-c-string ,body (##core#quote 0)))1297 ((c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body (##core#quote 0)))1298 ((nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body (##core#quote 0)))1299 ((symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body (##core#quote 0))))1300 ((c-string-list) `(##sys#peek-c-string-list ,body (##core#quote #f)))1301 ((c-string-list*) `(##sys#peek-and-free-c-string-list ,body (##core#quote #f)))1302 (else1303 (if (list? type)1304 (if (and (eq? (car type) 'const)1305 (= 2 (length type))1306 (memq (cadr type) '(c-string c-string* unsigned-c-string1307 unsigned-c-string* nonnull-c-string1308 nonnull-c-string*1309 nonnull-unsigned-string*)))1310 (finish-foreign-result (cadr type) body)1311 (if (= 3 (length type))1312 (case (car type)1313 ((instance instance-ref)1314 (let ((tmp (gensym)))1315 `(let ((,tmp ,body))1316 (and ,tmp1317 (not (##sys#null-pointer? ,tmp))1318 (make ,(caddr type)1319 (##core#quote this) ,tmp) ) ) ) )1320 ((nonnull-instance)1321 `(make ,(caddr type) (##core#quote this) ,body) )1322 (else body))1323 body))1324 body)))))132513261327;;; Translate foreign-type into scrutinizer type:13281329;; Used in chicken-ffi-syntax.scm and scrutinizer.scm1330(define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result1331 ;; If the foreign type has a converter, it can return a different1332 ;; type from the native type matching the foreign type (see #1649)1333 (if (or (and (eq? mode 'arg) (foreign-type-argument-converter t))1334 (and (eq? mode 'result) (foreign-type-result-converter t)))1335 ;; Here we just punt on the type, but it would be better to1336 ;; find out the result type of the converter procedure.1337 '*1338 (let ((ft (final-foreign-type t)))1339 (case ft1340 ((void) 'undefined)1341 ((char unsigned-char) 'char)1342 ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)1343 'fixnum)1344 ((float double)1345 (case mode1346 ((arg) 'number)1347 (else 'float)))1348 ((scheme-pointer nonnull-scheme-pointer) '*)1349 ((blob)1350 (case mode1351 ((arg) '(or false blob))1352 (else 'blob)))1353 ((nonnull-blob) 'blob)1354 ((pointer-vector)1355 (case mode1356 ((arg) '(or false pointer-vector))1357 (else 'pointer-vector)))1358 ((nonnull-pointer-vector) 'pointer-vector)1359 ((u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)1360 (case mode1361 ((arg) `(or false (struct ,ft)))1362 (else `(struct ,ft))))1363 ((nonnull-u8vector) '(struct u8vector))1364 ((nonnull-s8vector) '(struct s8vector))1365 ((nonnull-u16vector) '(struct u16vector))1366 ((nonnull-s16vector) '(struct s16vector))1367 ((nonnull-u32vector) '(struct u32vector))1368 ((nonnull-s32vector) '(struct s32vector))1369 ((nonnull-u64vector) '(struct u64vector))1370 ((nonnull-s64vector) '(struct s64vector))1371 ((nonnull-f32vector) '(struct f32vector))1372 ((nonnull-f64vector) '(struct f64vector))1373 ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer641374 unsigned-long)1375 'integer)1376 ((c-pointer)1377 (if (eq? 'arg mode)1378 '(or false pointer locative)1379 '(or false pointer)))1380 ((nonnull-c-pointer)1381 (if (eq? 'arg mode)1382 '(or pointer locative)1383 'pointer))1384 ((c-string c-string* unsigned-c-string unsigned-c-string*)1385 '(or false string))1386 ((c-string-list c-string-list*)1387 '(list-of string))1388 ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string)1389 ((symbol) 'symbol)1390 (else1391 (cond ((pair? t)1392 (case (car t)1393 ((ref pointer function c-pointer)1394 (if (eq? 'arg mode)1395 '(or false pointer locative)1396 '(or false pointer)))1397 ((const) (foreign-type->scrutiny-type (cadr t) mode))1398 ((enum) 'integer)1399 ((nonnull-pointer nonnull-c-pointer)1400 (if (eq? 'arg mode)1401 '(or pointer locative)1402 'pointer))1403 (else '*)))1404 (else '*)))))))140514061407;;; Scan expression-node for variable usage:14081409(define (scan-used-variables node vars)1410 (let ([used '()])1411 (let walk ([n node])1412 (let ([subs (node-subexpressions n)])1413 (case (node-class n)1414 [(##core#variable set!)1415 (let ([var (first (node-parameters n))])1416 (when (and (memq var vars) (not (memq var used)))1417 (set! used (cons var used)) )1418 (for-each walk subs) ) ]1419 [(quote ##core#undefined ##core#primitive) #f]1420 [else (for-each walk subs)] ) ) )1421 used) )142214231424;;; Scan expression-node for free variables (that are not in env):14251426(define (scan-free-variables node block-compilation)1427 (let ((vars '())1428 (hvars '()))14291430 (define (walk n e)1431 (let ([subs (node-subexpressions n)]1432 [params (node-parameters n)] )1433 (case (node-class n)1434 ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)1435 ((##core#variable)1436 (let ((var (first params)))1437 (unless (memq var e)1438 (set! vars (lset-adjoin/eq? vars var))1439 (unless (variable-visible? var block-compilation)1440 (set! hvars (lset-adjoin/eq? hvars var))))))1441 ((set!)1442 (let ((var (first params)))1443 (unless (memq var e) (set! vars (lset-adjoin/eq? vars var)))1444 (walk (car subs) e) ) )1445 ((let)1446 (walk (first subs) e)1447 (walk (second subs) (append params e)) )1448 ((##core#lambda)1449 (##sys#decompose-lambda-list1450 (third params)1451 (lambda (vars argc rest)1452 (walk (first subs) (append vars e)) ) ) )1453 (else (walkeach subs e)) ) ) )14541455 (define (walkeach ns e)1456 (for-each (lambda (n) (walk n e)) ns) )14571458 (walk node '())1459 (values vars hvars) ) ) ; => freevars hiddenvars146014611462;;; Special block-variable literal type:14631464(define-record-type block-variable-literal1465 (make-block-variable-literal name)1466 block-variable-literal?1467 (name block-variable-literal-name)) ; symbol146814691470;;; Generation of random names:14711472;; This one looks iffy. It's also used only in compiler.scm1473(define (make-random-name . prefix)1474 (string->symbol1475 (sprintf "~A-~A~A"1476 (optional prefix (gensym))1477 (current-seconds)1478 (##core#inline "C_random_fixnum" 1000))))147914801481;;; Register/lookup real names:1482;1483; - The real-name-table contains the following mappings:1484;1485; <variable-alias> -> <variable>1486; <lambda-id> -> <variable> or <variable-alias>14871488(define-constant real-name-table-size 997)14891490(define real-name-table #f)14911492(define (clear-real-name-table!)1493 (set! real-name-table (make-vector real-name-table-size '())))14941495(define (set-real-name! name rname) ; Used only in compiler.scm1496 (hash-table-set! real-name-table name rname))14971498;; TODO: Find out why there are so many lookup functions for this and1499;; reduce them to the minimum.1500(define (get-real-name name)1501 (hash-table-ref real-name-table name))15021503;; Arbitrary limit to prevent runoff into exponential behavior1504(define real-name-max-depth 20)15051506(define (real-name var . db)1507 (define (resolve n)1508 (let ((n2 (hash-table-ref real-name-table n)))1509 (if n21510 (or (hash-table-ref real-name-table n2)1511 n2)1512 n) ) )1513 (let ((rn (resolve var)))1514 (cond ((not rn) (##sys#symbol->string var))1515 ((pair? db)1516 (let ((db (car db)))1517 (let loop ((nesting (list (##sys#symbol->string rn)))1518 (depth 0)1519 (container (db-get db var 'contained-in)) )1520 (cond1521 ((> depth real-name-max-depth)1522 (string-intersperse (reverse (cons "..." nesting)) " in "))1523 (container1524 (let ((rc (resolve container)))1525 (if (eq? rc container)1526 (string-intersperse (reverse nesting) " in ")1527 (loop (cons (symbol->string rc) nesting)1528 (fx+ depth 1)1529 (db-get db container 'contained-in) ) ) ))1530 (else (string-intersperse (reverse nesting) " in "))) ) ) )1531 (else (##sys#symbol->string rn)) ) ) )15321533(define (real-name2 var db) ; Used only in c-backend.scm1534 (and-let* ((rn (hash-table-ref real-name-table var)))1535 (real-name rn db) ) )15361537(define (display-real-name-table)1538 (hash-table-for-each1539 (lambda (key val)1540 (printf "~S\t~S~%" key val) )1541 real-name-table) )15421543(define (source-info->string info) ; Used only in c-backend.scm1544 (if (list? info)1545 (let ((ln (car info))1546 (name (cadr info)))1547 (conc ln ":" (make-string (max 0 (- 4 (string-length ln))) #\space) " " name) )1548 (->string info)))15491550(define (source-info->name info)1551 (if (list? info) (cadr info) (->string info)))15521553(define (source-info->line info)1554 (and (list? info) (car info)))15551556(define (call-info params var) ; Used only in optimizer.scm1557 (or (and-let* ((info (and (pair? (cdr params)) (second params))))1558 (and (list? info)1559 (let ((ln (car info))1560 (name (cadr info)))1561 (conc "(" ln ") " var))))1562 var))156315641565;;; constant folding support:15661567(define (constant-form-eval op argnodes k) ; Used only in optimizer.scm1568 (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes))1569 (form (cons op (map (lambda (arg) `(quote ,arg)) args))))1570 ;; op must have toplevel binding, result must be single-valued1571 (let ((proc (##sys#slot op 0)))1572 (if (procedure? proc)1573 (let ((results (handle-exceptions ex ex (receive (apply proc args)))))1574 (cond ((condition? results) (k #f #f))1575 ((and (= 1 (length results))1576 (encodeable-literal? (car results)))1577 (debugging 'o "folded constant expression" form)1578 (k #t (car results)))1579 ((= 1 (length results)) ; not encodeable; don't fold1580 (k #f #f))1581 (else1582 (bomb "attempt to constant-fold call to procedure that has multiple results" form))))1583 (bomb "attempt to constant-fold call to non-procedure" form)))))15841585(define (maybe-constant-fold-call n subs k)1586 (define (constant-node? n2) (eq? 'quote (node-class n2)))1587 (if (eq? '##core#variable (node-class (car subs)))1588 (let ((var (first (node-parameters (car subs)))))1589 (if (and (intrinsic? var)1590 (or (foldable? var)1591 (predicate? var))1592 (every constant-node? (cdr subs)) )1593 (constant-form-eval var (cdr subs) (lambda (ok res) (k ok res #t)))1594 (k #f #f #f)))1595 (k #f #f #f)))15961597;; Is the literal small enough to be encoded? Otherwise, it should1598;; not be constant-folded.1599(define (encodeable-literal? lit)1600 (define getsize1601 (foreign-lambda* int ((scheme-object lit))1602 "return(C_header_size(lit));"))1603 (define (fits? n)1604 (fx<= (integer-length n) 24))1605 (cond ((immediate? lit))1606 ((exact-integer? lit)1607 ;; Could use integer-length, but that's trickier (minus1608 ;; symbol etc). If the string is too large to allocate,1609 ;; we'll also get an exception!1610 (let ((str (handle-exceptions ex #f (number->string lit 16))))1611 (and str (fits? (string-length str)))))1612 ((flonum? lit))1613 ((symbol? lit)1614 (let ((str (##sys#slot lit 1)))1615 (fits? (string-length str))))1616 ((##core#inline "C_byteblockp" lit)1617 (fits? (getsize lit)))1618 (else1619 (let ((len (getsize lit)))1620 (and (fits? len)1621 (every1622 encodeable-literal?1623 (list-tabulate len (lambda (i)1624 (##sys#slot lit i)))))))))162516261627;;; Dump node structure:16281629(define (dump-nodes n) ; Used only in batch-driver.scm1630 (let loop ([i 0] [n n])1631 (let ([class (node-class n)]1632 [params (node-parameters n)]1633 [subs (node-subexpressions n)]1634 [ind (make-string i #\space)]1635 [i2 (+ i 2)] )1636 (printf "~%~A<~A ~S" ind class params)1637 (for-each (cut loop i2 <>) subs)1638 (let ([len (##sys#size n)])1639 (when (fx> len 4)1640 (printf "[~S" (##sys#slot n 4))1641 (do ([i 5 (fx+ i 1)])1642 ((fx>= i len))1643 (printf " ~S" (##sys#slot n i)) )1644 (write-char #\]) ) )1645 (write-char #\>) ) )1646 (newline) )164716481649;; DEPRECATED1650(define (read/source-info in)1651 (chicken.syntax#read-with-source-info in) )16521653;;; "#> ... <#" syntax:16541655(set! ##sys#user-read-hook1656 (let ([old-hook ##sys#user-read-hook])1657 (lambda (char port)1658 (if (char=? #\> char)1659 (let* ((_ (read-char port)) ; swallow #\>1660 (text (scan-sharp-greater-string port)))1661 `(declare (foreign-declare ,text)) )1662 (old-hook char port) ) ) ) )16631664(define (scan-sharp-greater-string port)1665 (let ([out (open-output-string)])1666 (let loop ()1667 (let ((c (read-char port)))1668 (cond ((eof-object? c)1669 (quit-compiling "unexpected end of `#> ... <#' sequence"))1670 ((char=? c #\newline)1671 (newline out)1672 (loop) )1673 ((char=? c #\<)1674 (let ([c (read-char port)])1675 (if (eqv? #\# c)1676 (get-output-string out)1677 (begin1678 (write-char #\< out)1679 (write-char c out)1680 (loop) ) ) ) )1681 (else1682 (write-char c out)1683 (loop) ) ) ) ) ) )168416851686;;; 64-bit fixnum?16871688(define (big-fixnum? x) ;; XXX: This should probably be in c-platform1689 (and (fixnum? x)1690 (feature? #:64bit)1691 (or (fx> x 1073741823)1692 (fx< x -1073741824) ) ) )16931694(define (small-bignum? x) ;; XXX: This should probably be in c-platform1695 (and (bignum? x)1696 (not (feature? #:64bit))1697 (fx<= (integer-length x) 62) ) )169816991700;;; symbol visibility and other global variable properties17011702(define (hide-variable sym) ; Used in compiler.scm and here1703 (mark-variable sym '##compiler#visibility 'hidden))17041705(define (export-variable sym) ; Used only in compiler.scm1706 (mark-variable sym '##compiler#visibility 'exported))17071708(define (variable-hidden? sym)1709 (eq? (##sys#get sym '##compiler#visibility) 'hidden))17101711(define (unhide-variable sym)1712 (when (variable-hidden? sym) (remprop! sym '##compiler#visibility)))17131714(define (variable-visible? sym block-compilation)1715 (let ((p (##sys#get sym '##compiler#visibility)))1716 (case p1717 ((hidden) #f)1718 ((exported) #t)1719 (else (not block-compilation)))))17201721;; These two have somewhat confusing names. Maybe mark-variable could1722;; be renamed to "variable-mark-set!"? Also, in some other situations,1723;; put!/get are used directly.1724(define (mark-variable var mark #!optional (val #t))1725 (##sys#put! var mark val) )17261727(define (variable-mark var mark)1728 (##sys#get var mark) )17291730(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))1731;; Used only in optimizer.scm1732(define foldable? (cut variable-mark <> '##compiler#foldable))1733(define predicate? (cut variable-mark <> '##compiler#predicate))173417351736;;; Load support files17371738(define (load-identifier-database name) ; Used only in batch-driver.scm1739 (and-let* ((dbfile (chicken.load#find-file name (repository-path))))1740 (debugging 'p (sprintf "loading identifier database ~a ...~%" dbfile))1741 (for-each1742 (lambda (e)1743 (let ((id (car e)))1744 (##sys#put!1745 id '##core#db1746 (append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))1747 (call-with-input-file dbfile read-expressions))))174817491750;;; Print version/usage information:17511752(define (print-version #!optional b) ; Used only in batch-driver.scm1753 (when b (print* +banner+))1754 (print (chicken-version #t)) )17551756;; Used only in batch-driver.scm, but it seems to me this should be moved1757;; to chicken.scm, as that's the only place this belongs.1758(define (print-usage)1759 (print-version)1760 (newline)1761 (display #<<EOF1762Usage: chicken FILENAME [OPTION ...]17631764 `chicken' is the CHICKEN compiler.17651766 FILENAME should be a complete source file name with extension, or "-" for1767 standard input. OPTION may be one of the following:17681769 General options:17701771 -help display this text and exit1772 -version display compiler version and exit1773 -release print release number and exit1774 -verbose display information on compilation progress17751776 File and pathname options:17771778 -output-file FILENAME specifies output-filename, default is 'out.c'1779 -include-path PATHNAME specifies alternative path for included files1780 -to-stdout write compiled file to stdout instead of file17811782 Language options:17831784 -feature SYMBOL register feature identifier1785 -no-feature SYMBOL disable built-in feature identifier17861787 Syntax related options:17881789 -case-insensitive don't preserve case of read symbols1790 -keyword-style STYLE allow alternative keyword syntax1791 (prefix, suffix or none)1792 -no-parentheses-synonyms disables list delimiter synonyms1793 -no-symbol-escape disables support for escaped symbols1794 -r5rs-syntax disables the CHICKEN extensions to1795 R5RS syntax1796 -compile-syntax macros are made available at run-time1797 -emit-import-library MODULE write compile-time module information into1798 separate file1799 -emit-all-import-libraries emit import-libraries for all defined modules1800 -no-compiler-syntax disable expansion of compiler-macros1801 -module NAME wrap compiled code in a module1802 -module-registration always generate module registration code1803 -no-module-registration never generate module registration code1804 (overrides `-module-registration')18051806 Translation options:18071808 -explicit-use do not use units 'library' and 'eval' by1809 default1810 -check-syntax stop compilation after macro-expansion1811 -analyze-only stop compilation after first analysis pass18121813 Debugging options:18141815 -no-warnings disable warnings1816 -debug-level NUMBER set level of available debugging information1817 -no-trace disable tracing information1818 -debug-info enable debug-information in compiled code for use1819 with an external debugger1820 -profile executable emits profiling information1821 -profile-name FILENAME name of the generated profile information file1822 -accumulate-profile executable emits profiling information in1823 append mode1824 -no-lambda-info omit additional procedure-information1825 -emit-types-file FILENAME write type-declaration information into file1826 -consult-types-file FILENAME load additional type database18271828 Optimization options:18291830 -optimize-level NUMBER enable certain sets of optimization options1831 -optimize-leaf-routines enable leaf routine optimization1832 -no-usual-integrations standard procedures may be redefined1833 -unsafe disable all safety checks1834 -local assume globals are only modified in current1835 file1836 -block enable block-compilation1837 -disable-interrupts disable interrupts in compiled code1838 -fixnum-arithmetic assume all numbers are fixnums1839 -disable-stack-overflow-checks disables detection of stack-overflows1840 -inline enable inlining1841 -inline-limit LIMIT set inlining threshold1842 -inline-global enable cross-module inlining1843 -specialize perform type-based specialization of primitive calls1844 -emit-inline-file FILENAME generate file with globally inlinable1845 procedures (implies -inline -local)1846 -consult-inline-file FILENAME explicitly load inline file1847 -no-argc-checks disable argument count checks1848 -no-bound-checks disable bound variable checks1849 -no-procedure-checks disable procedure call checks1850 -no-procedure-checks-for-usual-bindings1851 disable procedure call checks only for usual1852 bindings1853 -no-procedure-checks-for-toplevel-bindings1854 disable procedure call checks for toplevel1855 bindings1856 -strict-types assume variable do not change their type1857 -clustering combine groups of local procedures into dispatch1858 loop1859 -lfa2 perform additional lightweight flow-analysis pass1860 -unroll-limit LIMIT specifies inlining limit for self-recursive calls18611862 Configuration options:18631864 -unit NAME compile file as a library unit1865 -uses NAME declare library unit as used.1866 -heap-size NUMBER specifies heap-size of compiled executable1867 -nursery NUMBER -stack-size NUMBER1868 specifies nursery size of compiled executable1869 -extend FILENAME load file before compilation commences1870 -prelude EXPRESSION add expression to front of source file1871 -postlude EXPRESSION add expression to end of source file1872 -prologue FILENAME include file before main source file1873 -epilogue FILENAME include file after main source file1874 -dynamic compile as dynamically loadable code1875 -require-extension NAME require and import extension NAME18761877 Obscure options:18781879 -debug MODES display debugging output for the given modes1880 -raw do not generate implicit init- and exit code1881 -emit-external-prototypes-first1882 emit prototypes for callbacks before foreign1883 declarations1884 -regenerate-import-libraries emit import libraries even when unchanged1885 -ignore-repository do not refer to repository for extensions1886 -setup-mode prefer the current directory when locating extensions18871888EOF1889) )18901891;; Same as above1892(define (print-debug-options)1893 (display #<<EOF18941895Available debugging options:18961897 a show node-matching during simplification1898 b show breakdown of time needed for each compiler pass1899 c print every expression before macro-expansion1900 d lists all assigned global variables1901 e show information about specializations1902 h you already figured that out1903 i show information about inlining1904 m show GC statistics during compilation1905 n print the line-number database1906 o show performed optimizations1907 p display information about what the compiler is currently doing1908 r show invocation parameters1909 s show program-size information and other statistics1910 t show time needed for compilation1911 u lists all unassigned global variable references1912 x display information about experimental features1913 D when printing nodes, use node-tree output1914 I show inferred type information for unexported globals1915 N show the real-name mapping table1916 P show expressions after specialization1917 S show applications of compiler syntax1918 T show expressions after converting to node tree1919 1 show source expressions1920 2 show canonicalized expressions1921 3 show expressions converted into CPS1922 4 show database after each analysis pass1923 5 show expressions after each optimization pass1924 6 show expressions after each inlining pass1925 7 show expressions after complete optimization1926 8 show database after final analysis1927 9 show expressions after closure conversion192819291930EOF1931))1932)