~ chicken-core (master) /scrutinizer.scm
Trap1;;;; scrutinizer.scm - The CHICKEN Scheme compiler (local flow analysis)2;3; Copyright (c) 2009-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; disclaimer in the documentation and/or other materials provided with the distribution.13; Neither the name of the author nor the names of its contributors may be used to endorse or promote14; products derived from this software without specific prior written permission.15;16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.252627(declare28 (unit scrutinizer)29 (uses data-structures expand extras pathname port support internal))3031(module chicken.compiler.scrutinizer32 (scrutinize load-type-database emit-types-file33 validate-type check-and-validate-type install-specializations34 ;; Exported for use in the tests:35 match-types refine-types type<=?)3637(import scheme38 chicken.base39 chicken.compiler.support40 chicken.fixnum41 chicken.format42 chicken.internal43 chicken.io44 chicken.keyword45 chicken.pathname46 chicken.platform47 chicken.plist48 chicken.sort49 chicken.port50 chicken.pretty-print51 chicken.string52 chicken.syntax)53(import (only (scheme base) call/cc))5455(include "tweaks")56(include "mini-srfi-1.scm")5758(define d-depth 0)59(define scrutiny-debug #t)60(define *complain?* #f)6162(define (d fstr . args)63 (when (and scrutiny-debug (##sys#debug-mode?))64 (printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) )6566(define dd d)67(define ddd d)6869(define-syntax d (syntax-rules () ((_ . _) (void))))70(define-syntax dd (syntax-rules () ((_ . _) (void))))71(define-syntax ddd (syntax-rules () ((_ . _) (void))))727374;;; Walk node tree, keeping type and binding information75;76; result specifiers:77;78; SPEC = * | (TYPE1 ...)79; TYPE = (or TYPE1 TYPE2 ...)80; | (not TYPE)81; | (struct NAME)82; | (procedure [NAME] (TYPE1 ... [#!optional TYPE1 ...] [#!rest [TYPE | values]]) . RESULTS)83; | VALUE84; | BASIC85; | COMPLEX86; | (forall (TVAR1 ...) TYPE)87; | (refine (SYMBOL ...) VALUE)88; | deprecated89; | (deprecated NAME)90; VALUE = string | symbol | keyword | char | number |91; boolean | true | false |92; null | eof | bwp | bytevector | pointer | port | locative | fixnum |93; float | bignum | ratnum | cplxnum | integer | pointer-vector94; BASIC = * | list | pair | procedure | vector | undefined | noreturn | values95; COMPLEX = (pair TYPE TYPE)96; | (vector-of TYPE)97; | (list-of TYPE)98; | (vector TYPE1 ...)99; | (list TYPE1 ...)100; RESULTS = *101; | (TYPE1 ...)102; TVAR = (VAR TYPE) | VAR103;104; global symbol properties:105;106; ##compiler#type -> TYPESPEC107; ##compiler#type-source -> 'db | 'local | 'inference108; ##compiler#predicate -> TYPESPEC109; ##compiler#specializations -> (SPECIALIZATION ...)110; ##compiler#local-specializations -> (SPECIALIZATION ...)111; ##compiler#enforce -> BOOL112; ##compiler#special-result-type -> PROCEDURE113; ##compiler#escape -> #f | 'yes | 'no114; ##compiler#type-abbreviation -> TYPESPEC115;; ##compiler#tv-root -> STRING116;117; specialization specifiers:118;119; SPECIALIZATION = ((TYPE ... [#!rest TYPE]) [RESULTS] TEMPLATE)120; TEMPLATE = #(INDEX)121; | #(INDEX ...)122; | #(SYMBOL)123; | INTEGER | SYMBOL | STRING124; | (quote CONSTANT)125; | (TEMPLATE . TEMPLATE)126;127; As an alternative to the "#!rest" and "#!optional" keywords, "&rest" or "&optional"128; may be used.129130131(define-constant +fragment-max-length+ 6)132(define-constant +fragment-max-depth+ 4)133(define-constant +maximal-union-type-length+ 20)134(define-constant +maximal-complex-object-constructor-result-type-length+ 256)135136(define-constant value-types137 '(string symbol keyword char null boolean true false bytevector eof bwp138 fixnum float number integer bignum ratnum cplxnum139 pointer-vector port pointer locative))140141(define-constant basic-types142 '(* list pair procedure vector undefined deprecated noreturn values))143144(define-constant struct-types145 '(u8vector s8vector u16vector s16vector u32vector s32vector u64vector146 s64vector f32vector f64vector thread queue environment time147 continuation lock mmap condition hash-table tcp-listener))148149(define-constant type-expansions150 '((pair . (pair * *))151 (list . (list-of *))152 (vector . (vector-of *))153 (boolean . (or true false))154 (integer . (or fixnum bignum))155 (number . (or fixnum float bignum ratnum cplxnum))156 (procedure . (procedure (#!rest *) . *))))157158(define-inline (struct-type? t)159 (and (pair? t) (eq? (car t) 'struct)))160161(define-inline (value-type? t)162 (or (struct-type? t) (memq t value-types)))163164(define specialization-statistics '())165(define trail '())166167(define (walked-result n)168 (first (node-parameters n))) ; assumes ##core#the/result node169170(define (type-always-immediate? t)171 (cond ((pair? t)172 (case (car t)173 ((or) (every type-always-immediate? (cdr t)))174 ((forall) (type-always-immediate? (third t)))175 (else #f)))176 ((memq t '(eof bwp null fixnum char boolean undefined)) #t)177 (else #f)))178179(define (scrutinize node db complain specialize strict block-compilation)180 (d "################################## SCRUTINIZE ##################################")181 (define (report loc msg . args)182 (when *complain?*183 (warning184 (conc (location-name loc)185 (sprintf "~?" msg args)))))186187 (set! *complain?* complain)188189 (let ((blist '()) ; (((VAR . FLOW) TYPE) ...)190 (aliased '())191 (noreturn #f)192 (dropped-branches 0)193 (assigned-immediates 0)194 (errors #f)195 (safe-calls 0))196197 (define (constant-result lit)198 (cond ((string? lit) 'string)199 ((keyword? lit) 'keyword)200 ((symbol? lit) 'symbol)201 ;; Do not assume fixnum width matches target platforms!202 ((or (big-fixnum? lit) (small-bignum? lit)) 'integer)203 ((fixnum? lit) 'fixnum)204 ((bignum? lit) 'bignum)205 ((flonum? lit) 'float) ; Why not "flonum", for consistency?206 ((ratnum? lit) 'ratnum)207 ((cplxnum? lit) 'cplxnum)208 ((boolean? lit)209 (if lit 'true 'false))210 ((null? lit) 'null)211 ((list? lit)212 `(list ,@(map constant-result lit)))213 ((pair? lit)214 (simplify-type215 `(pair ,(constant-result (car lit)) ,(constant-result (cdr lit)))))216 ((eof-object? lit) 'eof)217 ((bwp-object? lit) 'bwp)218 ((vector? lit)219 (simplify-type220 `(vector ,@(map constant-result (vector->list lit)))))221 ((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))222 `(struct ,(##sys#slot lit 0)))223 ((char? lit) 'char)224 (else '*)))225226 (define (global-result id loc node)227 (cond ((variable-mark id '##compiler#type) =>228 (lambda (a)229 (cond230 ((eq? a 'deprecated)231 (r-deprecated-identifier loc node id)232 '(*))233 ((and (pair? a) (eq? (car a) 'deprecated))234 (r-deprecated-identifier loc node id (cadr a))235 '(*))236 (else (list a)))))237 (else '(*))))238239 (define (blist-type id flow)240 (cond ((find (lambda (b)241 (and (eq? id (caar b))242 (memq (cdar b) flow)) )243 blist)244 => cdr)245 (else #f)))246247 (define (variable-result id e loc node flow)248 (cond ((blist-type id flow) => list)249 ((and (not strict)250 (db-get db id 'assigned)251 (not (variable-mark id '##compiler#type-source)))252 '(*))253 ((assq id e) =>254 (lambda (a)255 (cond ((eq? 'undefined (cdr a))256 #;(report257 loc258 "access to variable `~a' which has an undefined value"259 (real-name id db))260 '(*))261 (else (list (cdr a))))))262 (else (global-result id loc node))))263264 (define (always-true1 t)265 (cond ((pair? t)266 (case (car t)267 ((or) (every always-true1 (cdr t)))268 ((not) (not (always-true1 (second t))))269 ((forall) (always-true1 (third t)))270 (else #t)))271 ((memq t '(* boolean false undefined noreturn)) #f)272 (else #t)))273274 (define (always-true if-node test-node t loc)275 (and-let* ((_ (always-true1 t)))276 (r-cond-test-always-true loc if-node test-node t)277 #t))278279 (define (always-false if-node test-node t loc)280 (and-let* ((_ (eq? t 'false)))281 (r-cond-test-always-false loc if-node test-node)282 #t))283284 (define (single tv r-value-count-mismatch)285 (if (eq? '* tv)286 '*287 (let ((n (length tv)))288 (cond ((= 1 n) (car tv))289 ((zero? n)290 (r-value-count-mismatch tv)291 'undefined)292 (else293 (r-value-count-mismatch tv)294 (first tv))))))295296 (define add-loc cons)297298 (define (get-specializations name)299 (let* ((a (variable-mark name '##compiler#local-specializations))300 (b (variable-mark name '##compiler#specializations))301 (c (append (or a '()) (or b '()))))302 (and (pair? c) c)))303304 (define (call-result node args loc typeenv)305 (let* ((actualtypes (map walked-result args))306 (ptype (car actualtypes))307 (pptype? (procedure-type? ptype))308 (nargs (length (cdr args)))309 (xptype `(procedure ,(make-list nargs '*) *))310 (typeenv (append-map type-typeenv actualtypes))311 (op #f))312 (d " call: ~a, te: ~a" actualtypes typeenv)313 (cond ((and (not pptype?) (not (match-types xptype ptype typeenv)))314 (r-invalid-called-procedure-type315 loc node (resolve xptype typeenv) (car args) (resolve ptype typeenv))316 (values '* #f))317 (else318 (let-values (((atypes values-rest ok alen)319 (procedure-argument-types ptype nargs typeenv)))320 (unless ok321 (r-proc-call-argument-count-mismatch loc node alen nargs ptype))322 (do ((actualtypes (cdr actualtypes) (cdr actualtypes))323 (anodes (cdr args) (cdr anodes))324 (atypes atypes (cdr atypes))325 (i 1 (add1 i)))326 ((or (null? actualtypes) (null? atypes)))327 (unless (match-types328 (car atypes)329 (car actualtypes)330 typeenv)331 (r-proc-call-argument-type-mismatch332 loc node i333 (car anodes)334 (resolve (car atypes) typeenv)335 (resolve (car actualtypes) typeenv)336 ptype)))337 (when (noreturn-procedure-type? ptype)338 (set! noreturn #t))339 (let ((r (procedure-result-types ptype values-rest (cdr actualtypes) typeenv)))340 (let* ((pn (procedure-name ptype))341 (trail0 trail))342 (when pn343 (cond ((and (fx= 1 nargs)344 (variable-mark pn '##compiler#predicate)) =>345 (lambda (pt)346 (cond ((match-argument-types (list pt) (cdr actualtypes) typeenv)347 (r-pred-call-always-true348 loc node pt (cadr actualtypes))349 (when specialize350 (specialize-node!351 node (cdr args)352 `(let ((#(tmp) #(1))) '#t))353 (set! r '(true))354 (set! op (list pn pt))))355 ((begin356 (trail-restore trail0 typeenv)357 (match-argument-types (list `(not ,pt)) (cdr actualtypes) typeenv))358 (r-pred-call-always-false359 loc node pt (cadr actualtypes))360 (when specialize361 (specialize-node!362 node (cdr args)363 `(let ((#(tmp) #(1))) '#f))364 (set! r '(false))365 (set! op (list pt `(not ,pt)))))366 (else (trail-restore trail0 typeenv)))))367 ((maybe-constant-fold-call node (node-subexpressions node)368 (lambda (ok res _constant?)369 (and ok (cons res ok))))370 => (lambda (res.ok)371 ;; Actual type doesn't matter; the node gets walked again372 (set! r '*)373 (mutate-node! node (list 'quote (car res.ok)))))374 ((and specialize (get-specializations pn)) =>375 (lambda (specs)376 (let loop ((specs specs))377 (and (pair? specs)378 (let* ((spec (car specs))379 (stype (first spec))380 (tenv2 (append381 (append-map type-typeenv stype)382 typeenv)))383 (cond ((match-argument-types stype (cdr actualtypes) tenv2)384 (set! op (cons pn (car spec)))385 (set! typeenv tenv2)386 (let* ((r2 (and (pair? (cddr spec))387 (second spec)))388 (rewrite (if r2389 (third spec)390 (second spec))))391 (specialize-node! node (cdr args) rewrite)392 (when r2 (set! r r2))))393 (else394 (trail-restore trail0 tenv2)395 (loop (cdr specs))))))))))396 (when op397 (d " specialized: `~s' for ~a" (car op) (cdr op))398 (cond ((assoc op specialization-statistics) =>399 (lambda (a) (set-cdr! a (add1 (cdr a)))))400 (else401 (set! specialization-statistics402 (cons (cons op 1)403 specialization-statistics))))))404 (when (and specialize (not op) (procedure-type? ptype)405 (eq? '##core#call (node-class node)))406 (set-car! (node-parameters node) #t)407 (set! safe-calls (add1 safe-calls))))408 (let ((r (if (eq? '* r) r (map (cut resolve <> typeenv) r))))409 (d " result-types: ~a" r)410 (values r op))))))))411412 (define tag413 (let ((n 0))414 (lambda ()415 (set! n (add1 n))416 n)))417418 (define (add-to-blist var flow type)419 (let loop ((var var))420 (set! blist (alist-update! (cons var flow) type blist equal?))421 (let ((a (assq var aliased)))422 (when a423 (d " applying to alias: ~a -> ~a" (cdr a) type)424 (loop (cdr a))))))425426 (define (initial-argument-types dest vars argc)427 (if (and dest strict428 (variable-mark dest '##compiler#type-source))429 (let* ((ptype (variable-mark dest '##compiler#type))430 (typeenv (type-typeenv ptype)))431 (if (procedure-type? ptype)432 (map (cut resolve <> typeenv)433 (nth-value 0 (procedure-argument-types ptype argc '() #t)))434 (make-list argc '*)))435 (make-list argc '*)))436437 (define (walk n e loc dest flow ctags) ; returns result specifier438 (let ((subs (node-subexpressions n))439 (params (node-parameters n))440 (class (node-class n)) )441 (dd "walk: ~a ~s (loc: ~a, dest: ~a, flow: ~a)"442 class params loc dest flow)443 #;(dd "walk: ~a ~s (loc: ~a, dest: ~a, flow: ~a, blist: ~a, e: ~a)"444 class params loc dest flow blist e)445 (set! d-depth (add1 d-depth))446 (let ((results447 (case class448 ((##core#the/result) (list (first params))) ; already walked449 ((quote) (list (constant-result (first params))))450 ((##core#undefined) '(*))451 ((##core#proc) '(procedure))452 ((##core#variable) (variable-result (first params) e loc n flow))453 ((##core#inline_ref)454 (list (foreign-type->scrutiny-type (second params) 'result)))455 ((##core#inline_loc_ref)456 (list (foreign-type->scrutiny-type (first params) 'result)))457 ((if)458 (let ((tags (cons (tag) (tag)))459 (tst (first subs))460 (nor-1 noreturn))461 (set! noreturn #f)462 (let* ((rt (single (walk tst e loc #f flow tags)463 (cut r-conditional-value-count-invalid loc n tst <>)))464 (c (second subs))465 (a (third subs))466 (nor0 noreturn))467 (cond468 ((and (always-true n tst rt loc) specialize)469 (set! dropped-branches (add1 dropped-branches))470 (mutate-node! n `(let ((,(gensym) ,tst)) ,c))471 (walk n e loc dest flow ctags))472 ((and (always-false n tst rt loc) specialize)473 (set! dropped-branches (add1 dropped-branches))474 (mutate-node! n `(let ((,(gensym) ,tst)) ,a))475 (walk n e loc dest flow ctags))476 (else477 (let* ((r1 (walk c e loc dest (cons (car tags) flow) #f))478 (nor1 noreturn))479 (set! noreturn #f)480 (let* ((r2 (walk a e loc dest (cons (cdr tags) flow) #f))481 (nor2 noreturn))482 (set! noreturn (or nor-1 nor0 (and nor1 nor2)))483 ;; when only one branch is noreturn, add blist entries for484 ;; all in other branch:485 (when (or (and nor1 (not nor2))486 (and nor2 (not nor1)))487 (let ((yestag (if nor1 (cdr tags) (car tags))))488 (for-each489 (lambda (ble)490 (when (eq? (cdar ble) yestag)491 (d "adding blist entry ~a for single returning conditional branch"492 ble)493 (add-to-blist (caar ble) (car flow) (cdr ble))))494 blist)))495 (cond ((and (not (eq? '* r1)) (not (eq? '* r2)))496 ;;(dd " branches: ~s:~s / ~s:~s" nor1 r1 nor2 r2)497 (cond ((and (not nor1) (not nor2)498 (not (= (length r1) (length r2))))499 (r-cond-branch-value-count-mismatch loc n c a r1 r2)500 '*)501 (nor1 r2)502 (nor2 r1)503 (else504 (dd "merge branch results: ~s + ~s" r1 r2)505 (map (lambda (t1 t2)506 (simplify-type `(or ,t1 ,t2)))507 r1 r2))))508 (else '*)))))))))509 ((let)510 ;; before CPS-conversion, `let'-nodes may have multiple bindings511 (let loop ((vars params) (body subs) (e2 '()))512 (if (null? vars)513 (walk (car body) (append e2 e) loc dest flow ctags)514 (let* ((var (car vars))515 (val (car body))516 (t (single (walk val e loc var flow #f)517 (cut r-let-value-count-invalid loc var n val <>))))518 (when (and (eq? (node-class val) '##core#variable)519 (not (db-get db var 'assigned)))520 (let ((var2 (first (node-parameters val))))521 (unless (db-get db var2 'assigned) ;XXX too conservative?522 (set! aliased (alist-cons var var2 aliased)))))523 (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))524 ((##core#lambda lambda)525 (##sys#decompose-lambda-list526 (first params)527 (lambda (vars argc rest)528 (let* ((namelst (if dest (list dest) '()))529 (inits (initial-argument-types dest vars argc))530 (args (append inits (if rest '(#!rest) '())))531 (e2 (append (map (lambda (v i) (cons v i))532 (if rest (butlast vars) vars)533 inits)534 e)))535 (when dest536 (d "~a: initial-argument types: ~a" dest inits))537 (fluid-let ((blist '())538 (noreturn #f)539 (aliased '()))540 (let* ((initial-tag (tag))541 (r (walk (first subs)542 (if rest (alist-cons rest 'list e2) e2)543 (add-loc dest loc)544 #f (list initial-tag) #f)))545 #;(when (and specialize546 dest547 (variable-mark dest '##compiler#type-source)548 (not unsafe))549 (debugging 'x "checks argument-types" dest) ;XXX550 ;; [1] this is subtle: we don't want argtype-checks to be551 ;; generated for toplevel defs other than user-declared ones.552 ;; But since the ##compiler#type-source mark is set AFTER553 ;; the lambda has been walked (see below, [2]), nothing is added.554 (generate-type-checks! n dest vars inits))555 (list556 (append557 '(procedure)558 namelst559 (list560 (let loop ((argc argc) (vars vars) (args args))561 (cond ((zero? argc) args)562 ((and (not (db-get db (car vars) 'assigned))563 (assoc (cons (car vars) initial-tag) blist))564 =>565 (lambda (a)566 (cons567 (cond ((eq? (cdr a) '*) '*)568 (else569 (d "adjusting procedure argument type for `~a' to: ~a"570 (car vars) (cdr a))571 (cdr a) ))572 (loop (sub1 argc) (cdr vars) (cdr args)))))573 (else574 (cons575 (car args)576 (loop (sub1 argc) (cdr vars) (cdr args)))))))577 r))))))))578 ((set! ##core#set!)579 (let* ((var (first params))580 (type (variable-mark var '##compiler#type))581 (rt (single (walk (first subs) e loc var flow #f)582 (cut r-assignment-value-count-invalid583 loc var n (first subs) <>)))584 (typeenv (append585 (if type (type-typeenv type) '())586 (type-typeenv rt)))587 (b (assq var e)) )588 (when (and type (not b)589 (not (or (eq? type 'deprecated)590 (and (pair? type)591 (eq? (car type) 'deprecated))))592 (not (match-types type rt typeenv)))593 (when strict (set! errors #t))594 (r-toplevel-var-assignment-type-mismatch loc n rt var type (first subs)))595 (when (and (not type) ;XXX global declaration could allow this596 (not b)597 (not (eq? '* rt))598 (not (db-get db var 'unknown)))599 (and-let* ((val (or (db-get db var 'value)600 (db-get db var 'local-value))))601 (when (and (eq? val (first subs))602 (or (not (variable-visible? var block-compilation))603 (not (eq? (variable-mark var '##compiler#inline)604 'no))))605 (let ((rtlst (list (cons #f (tree-copy rt)))))606 (smash-component-types! rtlst "global")607 (let ((rt (cdar rtlst)))608 (debugging '|I| (sprintf "(: ~s ~s)" var rt))609 ;; [2] sets property, but lambda has already been walked,610 ;; so no type-checks are generated (see also [1], above)611 ;; note that implicit declarations are not enforcing612 (mark-variable var '##compiler#type-source 'inference)613 (mark-variable var '##compiler#type rt))))))614 (when b615 (cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))616 #;(strict617 (let ((ot (or (blist-type var flow) (cdr b))))618 ;;XXX compiler-syntax for "map" will introduce619 ;; assignments that trigger this warning, so this620 ;; is currently disabled621 (unless (compatible-types? ot rt)622 (report623 loc624 "variable `~a' of type `~a' was modified to a value of type `~a'"625 var ot rt)))))626 (let ((t (if (or strict (not (db-get db var 'captured)))627 rt628 '*))629 (fl (car flow)))630 ;; For each outer flow F, change the var's631 ;; type to (or t <old-type@F>). Add a new632 ;; entry for current flow if it's missing.633 ;;634 ;; Motivating example:635 ;;636 ;; (let* ((x 1)637 ;; (y x)) ; y x : fixnum @ flow f_1638 ;; (if foo639 ;; (set! y 'a)) ; y : symbol @ flow f_2640 ;; y) ; (1) @ flow f_1641 ;;642 ;; At point (1) the type of y can be inferred643 ;; to be (or fixnum symbol). The type of x644 ;; should stay unchanged, however.645 (let loop ((bl blist) (fl-found? #f))646 (cond ((null? bl)647 (unless fl-found?648 (dd "set! ~a in ~a (new) --> ~a" var fl t)649 (set! blist (alist-cons (cons var fl) t blist))))650 ((eq? var (ble-id (car bl)))651 (let* ((ble (car bl))652 (old-type (ble-type ble))653 (t2 (simplify-type `(or ,t ,old-type))))654 (dd "set! ~a in ~a, or old ~a with ~a --> ~a"655 var tag old-type t t2)656 (ble-type-set! ble t2)657 (loop (cdr bl) (or fl-found? (eq? fl (ble-tag ble))))))658 (else (loop (cdr bl) fl-found?))))))659660 (when (type-always-immediate? rt)661 (d " assignment to var ~a in ~a is always immediate" var loc)662 (set! assigned-immediates (add1 assigned-immediates))663 (set-cdr! params '(#t)))664665 '(undefined)))666 ((##core#primitive) '*)667 ((##core#call)668 (let* ((f (fragment n))669 (len (length subs))670 (args (map (lambda (n2 i)671 (make-node672 '##core#the/result673 (list674 (single675 (walk n2 e loc #f flow #f)676 (cut r-proc-call-argument-value-count loc n i n2 <>)))677 (list n2)))678 subs679 (iota len)))680 (fn (walked-result (car args)))681 (pn (procedure-name fn))682 (typeenv (type-typeenv683 `(or ,@(map walked-result args)))) ; hack684 (enforces685 (and pn (variable-mark pn '##compiler#enforce)))686 (pt (and pn (variable-mark pn '##compiler#predicate))))687 (let-values (((r specialized?)688 (call-result n args loc typeenv)))689 (define (smash)690 (when (and (not strict)691 (or (not pn)692 (and693 (not (variable-mark pn '##compiler#pure))694 (not (variable-mark pn '##compiler#clean)))))695 (smash-component-types! e "env")696 (smash-component-types! blist "blist")))697 (cond (specialized?698 (walk n e loc dest flow ctags)699 (smash)700 ;; keep type, as the specialization may contain icky stuff701 ;; like "##core#inline", etc.702 (if (eq? '* r)703 r704 (map (cut resolve <> typeenv) r)))705 ((eq? 'quote (node-class n)) ; Call got constant folded706 (walk n e loc dest flow ctags))707 (else708 (for-each709 (lambda (arg argr)710 (when (eq? '##core#variable (node-class arg))711 (let* ((var (first (node-parameters arg)))712 (a (or (blist-type var flow) (alist-ref var e)))713 (argr (resolve argr typeenv))714 (oparg? (eq? arg (first subs)))715 (pred (and pt716 ctags717 (not (db-get db var 'assigned))718 (not oparg?))))719 (cond (pred720 ;;XXX is this needed? "typeenv" is the te of "args",721 ;; not of "pt":722 (let ((pt (resolve pt typeenv)))723 (d " predicate `~a' indicates `~a' is ~a in flow ~a"724 pn var pt (car ctags))725 (add-to-blist726 var (car ctags)727 (if (not a) pt (refine-types a pt)))728 ;; if the variable type is an "or"-type, we can729 ;; can remove all elements that match the predicate730 ;; type731 (when a732 ;;XXX hack, again:733 (let ((at (refine-types a `(not ,pt))))734 (when at735 (d " predicate `~a' indicates `~a' is ~a in flow ~a"736 pn var at (cdr ctags))737 (add-to-blist var (cdr ctags) at))))))738 (a739 (when enforces740 (let ((ar (if (db-get db var 'assigned)741 '* ; XXX necessary?742 (refine-types a argr))))743 (d " assuming: ~a -> ~a (flow: ~a)"744 var ar (car flow))745 (add-to-blist var (car flow) ar)746 (when ctags747 (add-to-blist var (car ctags) ar)748 (add-to-blist var (cdr ctags) ar)))))749 ((and oparg?750 (variable-mark751 var752 '##compiler#special-result-type))753 => (lambda (srt)754 (dd " hardcoded special result-type: ~a" var)755 (set! r (srt n args loc r))))))))756 subs757 (cons758 fn759 (nth-value760 0761 (procedure-argument-types fn (sub1 len) typeenv))))762 (smash)763 (if (eq? '* r)764 r765 (map (cut resolve <> typeenv) r)))))))766 ((##core#the)767 (let ((t (first params))768 (rt (walk (first subs) e loc dest flow ctags)))769 (cond ((eq? rt '*))770 ((null? rt) (r-zero-values-for-the loc (first subs) t))771 (else772 (when (> (length rt) 1)773 (r-too-many-values-for-the loc (first subs) t rt))774 (when (and (second params)775 (not (compatible-types? t (first rt))))776 (when strict (set! errors #t))777 (r-type-mismatch-in-the loc (first subs) (first rt) t))))778 (list t)))779 ((##core#typecase)780 (let* ((ts (walk (first subs) e loc #f flow ctags))781 (trail0 trail)782 (typeenv0 (type-typeenv (car ts))))783 ;; first exp is always a variable so ts must be of length 1784 (let loop ((types (cdr params)) (subs (cdr subs)))785 (if (null? types)786 (fail-compiler-typecase loc n (car ts) (cdr params))787 (let ((typeenv (append (type-typeenv (car types)) typeenv0)))788 (if (match-types (car types) (car ts) typeenv #t)789 (begin ; drops exp790 (mutate-node! n (car subs))791 (walk n e loc dest flow ctags))792 (begin793 (trail-restore trail0 typeenv)794 (loop (cdr types) (cdr subs)))))))))795 ((##core#switch ##core#cond)796 (bomb "scrutinize: unexpected node class" class))797 (else798 (for-each (lambda (n) (walk n e loc #f flow #f)) subs)799 '*))))800 (set! d-depth (sub1 d-depth))801 (dd "walked ~a -> ~a flow: ~a" class results flow)802 results)))803804 (let ((rn (walk (first (node-subexpressions node)) '() '() #f (list (tag)) #f)))805 (when (pair? specialization-statistics)806 (with-debugging-output807 '(o e)808 (lambda ()809 (print "specializations:")810 (for-each811 (lambda (ss)812 (printf " ~a ~s~%" (cdr ss) (car ss)))813 specialization-statistics))))814 (when (positive? safe-calls)815 (debugging '(o e) "safe calls" safe-calls))816 (when (positive? dropped-branches)817 (debugging '(o e) "dropped branches" dropped-branches))818 (when (positive? assigned-immediates)819 (debugging '(o e) "assignments to immediate values" assigned-immediates))820 (d "############################### SCRUTINIZE FINISH ##############################")821 (when errors822 (quit-compiling "some variable types do not satisfy strictness"))823 rn)))824825826;;; replace pair/vector types with components to variants with undetermined827;; component types (used for env or blist); also convert "list[-of]" types828;; into "pair", since mutation may take place829830(define (smash-component-types! lst where)831 ;; assumes list of the form "((_ . T1) ...)"832 (do ((lst lst (cdr lst)))833 ((null? lst))834 (let loop ((t (cdar lst))835 (change! (cute set-cdr! (car lst) <>)))836 (when (pair? t)837 (case (car t)838 ((vector-of)839 (dd " smashing `~s' in ~a" (caar lst) where)840 (change! 'vector)841 (car t))842 ((vector)843 (dd " smashing `~s' in ~a" (caar lst) where)844 ;; (vector x y z) => (vector * * *)845 (change! (cons 'vector (map (constantly '*) (cdr t))))846 (car t))847 ((list-of list)848 (dd " smashing `~s' in ~a" (caar lst) where)849 (change! '(or pair null))850 (car t))851 ((pair)852 (dd " smashing `~s' in ~a" (caar lst) where)853 (change! (car t))854 (car t))855 ((forall)856 (loop (third t)857 (cute set-car! (cddr t) <>))))))))858859860;;; blist (binding list) helpers861;;862;; - Entries (ble) in blist have type ((symbol . fixnum) . type)863864(define ble-id caar) ; variable name : symbol865(define ble-tag cdar) ; block tag : fixnum866(define ble-type cdr) ; variable type : valid type sexp867(define ble-type-set! set-cdr!)868869870;;; Type-matching871;872; - "all" means: all elements in `or'-types in second argument must match873874(define (match-types t1 t2 #!optional (typeenv (type-typeenv `(or ,t1 ,t2))) all)875876 (define (match-args args1 args2)877 (d "match args: ~s <-> ~s" args1 args2)878 (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))879 (cond ((null? args1)880 (or opt2881 (null? args2)882 (optargs? (car args2))))883 ((null? args2)884 (or opt1885 (optargs? (car args1))))886 ((eq? '#!optional (car args1))887 (loop (cdr args1) args2 #t opt2))888 ((eq? '#!optional (car args2))889 (loop args1 (cdr args2) opt1 #t))890 ((eq? '#!rest (car args1))891 (match-rest (rest-type (cdr args1)) args2 opt2))892 ((eq? '#!rest (car args2))893 (match-rest (rest-type (cdr args2)) args1 opt1))894 ((match1 (car args1) (car args2))895 (loop (cdr args1) (cdr args2) opt1 opt2))896 (else #f))))897898 (define (match-rest rtype args opt) ;XXX currently ignores `opt'899 (let-values (((head tail) (span (lambda (x) (not (eq? '#!rest x))) args)))900 (and (every901 (lambda (t)902 (or (eq? '#!optional t)903 (match1 rtype t)))904 head)905 (match1 rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))906907 (define (optargs? a)908 (memq a '(#!rest #!optional)))909910 (define (match-results results1 results2)911 (cond ((eq? '* results1))912 ((eq? '* results2) (not all))913 ((null? results1) (null? results2))914 ((null? results2) #f)915 ((and (memq (car results1) '(undefined noreturn))916 (memq (car results2) '(undefined noreturn))))917 ((match1 (car results1) (car results2))918 (match-results (cdr results1) (cdr results2)))919 (else #f)))920921 (define (rawmatch1 t1 t2)922 (fluid-let ((all #f))923 (match1 t1 t2)))924925 (define (every-match1 lst1 lst2)926 (let loop ((lst1 lst1) (lst2 lst2))927 (cond ((null? lst1))928 ((match1 (car lst1) (car lst2)) (loop (cdr lst1) (cdr lst2)))929 (else #f))))930931 (define (match1 t1 t2)932 ;; note: the order of determining the type is important933 (dd " match1: ~s <-> ~s" t1 t2)934 (cond ((eq? t1 t2))935 ;;XXX do we have to handle circularities?936 ((and (symbol? t1) (assq t1 typeenv)) =>937 (lambda (e)938 (cond ((second e)939 (and (match1 (second e) t2)940 (or (not (third e)) ; constraint941 (rawmatch1 (third e) t2))))942 ;; special case for two unbound typevars943 ((and (symbol? t2) (assq t2 typeenv)) =>944 (lambda (e2)945 ;;XXX probably not fully right, consider:946 ;; (forall (a b) ((a a b) ->)) + (forall (c d) ((c d d) ->))947 ;; or is this not a problem? I don't know right now...948 (or (not (second e2))949 (and (match1 t1 (second e2))950 (or (not (third e2)) ; constraint951 (rawmatch1 t1 (third e2)))))))952 ((or (not (third e))953 (rawmatch1 (third e) t2))954 (dd " unify ~a = ~a" t1 t2)955 (set! trail (cons t1 trail))956 (set-car! (cdr e) t2)957 #t)958 (else #f))))959 ((and (symbol? t2) (assq t2 typeenv)) =>960 (lambda (e)961 (cond ((second e)962 (and (match1 t1 (second e))963 (or (not (third e)) ; constraint964 (rawmatch1 t1 (third e)))))965 ((or (not (third e))966 (rawmatch1 t1 (third e)))967 (dd " unify ~a = ~a" t2 t1)968 (set! trail (cons t2 trail))969 (set-car! (cdr e) t1)970 #t)971 (else #f))))972 ((eq? t1 '*))973 ((eq? t2 '*) (not all))974 ((eq? t1 'undefined) #f)975 ((eq? t2 'undefined) #f)976 ((eq? t1 'noreturn))977 ((eq? t2 'noreturn))978 ((maybe-expand-type t1) => (cut match1 <> t2))979 ((maybe-expand-type t2) => (cut match1 t1 <>))980 ((and (pair? t1) (eq? 'not (car t1)))981 (fluid-let ((all (not all)))982 (let* ((trail0 trail)983 (m (match1 (cadr t1) t2)))984 (trail-restore trail0 typeenv)985 (not m))))986 ((and (pair? t2) (eq? 'not (car t2)))987 (and (not all)988 (fluid-let ((all #t))989 (let* ((trail0 trail)990 (m (match1 (cadr t2) t1)))991 (trail-restore trail0 typeenv)992 (not m)))))993 ;; this is subtle: "or" types for t2 are less restrictive,994 ;; so we handle them before "or" types for t1995 ((and (pair? t2) (eq? 'or (car t2)))996 (over-all-instantiations997 (cdr t2)998 typeenv999 all1000 (lambda (t) (match1 t1 t))))1001 ;; s.a.1002 ((and (pair? t1) (eq? 'or (car t1)))1003 (over-all-instantiations1004 (cdr t1)1005 typeenv1006 #f1007 (lambda (t) (match1 t t2)))) ; o-a-i ensures at least one element matches1008 ((and (pair? t1) (eq? 'forall (car t1)))1009 (match1 (third t1) t2)) ; assumes typeenv has already been extracted1010 ((and (pair? t2) (eq? 'forall (car t2)))1011 (match1 t1 (third t2))) ; assumes typeenv has already been extracted1012 ((eq? 'procedure t1)1013 (and (pair? t2) (eq? 'procedure (car t2))))1014 ((eq? 'procedure t2)1015 (and (not all)1016 (pair? t1) (eq? 'procedure (car t1))))1017 ((eq? t1 'null)1018 (and (not all)1019 (pair? t2) (eq? 'list-of (car t2))))1020 ((eq? t2 'null)1021 (and (pair? t1) (eq? 'list-of (car t1))))1022 ((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))1023 (case (car t1)1024 ((procedure)1025 (let ((args1 (procedure-arguments t1))1026 (args2 (procedure-arguments t2))1027 (results1 (procedure-results t1))1028 (results2 (procedure-results t2)))1029 (and (match-args args1 args2)1030 (match-results results1 results2))))1031 ((struct) (equal? t1 t2))1032 ((pair) (every-match1 (cdr t1) (cdr t2)))1033 ((list-of vector-of) (match1 (second t1) (second t2)))1034 ((list vector)1035 (and (= (length t1) (length t2))1036 (every-match1 (cdr t1) (cdr t2))))1037 ((refine)1038 (and (match1 (third t1) (third t2))1039 (or (not all)1040 (lset<=/eq? (second t1) (second t2)))))1041 (else #f)))1042 ((and (pair? t1) (eq? 'refine (car t1)))1043 (and (not all) (match1 (third t1) t2)))1044 ((and (pair? t2) (eq? 'refine (car t2)))1045 (match1 t1 (third t2)))1046 ((and (pair? t1) (eq? 'pair (car t1)))1047 (and (pair? t2)1048 (case (car t2)1049 ((list-of)1050 (and (not all)1051 (match1 (second t1) (second t2))1052 (match1 (third t1) t2)))1053 ((list)1054 (and (pair? (cdr t2))1055 (match1 (second t1) (second t2))1056 (match1 (third t1)1057 (if (null? (cddr t2))1058 'null1059 `(list ,@(cddr t2))))))1060 (else #f))))1061 ((and (pair? t2) (eq? 'pair (car t2)))1062 (and (pair? t1)1063 (case (car t1)1064 ((list-of)1065 (and (not all)1066 (match1 (second t1) (second t2))1067 (match1 t1 (third t2))))1068 ((list)1069 (and (pair? (cdr t1))1070 (match1 (second t1) (second t2))1071 (match1 (if (null? (cddr t1))1072 'null1073 `(list ,@(cddr t1)))1074 (third t2))))1075 (else #f))))1076 ((and (pair? t1) (eq? 'list (car t1)))1077 (and (not all)1078 (pair? t2) (eq? 'list-of (car t2))1079 (over-all-instantiations1080 (cdr t1)1081 typeenv1082 #t1083 (cute match1 <> (second t2)))))1084 ((and (pair? t1) (eq? 'list-of (car t1)))1085 (and (pair? t2) (eq? 'list (car t2))1086 (over-all-instantiations1087 (cdr t2)1088 typeenv1089 #t1090 (cute match1 (second t1) <>))))1091 ((and (pair? t1) (eq? 'vector (car t1)))1092 (and (not all)1093 (pair? t2) (eq? 'vector-of (car t2))1094 (over-all-instantiations1095 (cdr t1)1096 typeenv1097 #t1098 (cute match1 <> (second t2)))))1099 ((and (pair? t1) (eq? 'vector-of (car t1)))1100 (and (pair? t2) (eq? 'vector (car t2))1101 (over-all-instantiations1102 (cdr t2)1103 typeenv1104 #t1105 (cute match1 (second t1) <>))))1106 (else #f)))11071108 (dd "match (~a) ~a <-> ~a" (if all "all" "any") t1 t2)1109 (let ((m (match1 t1 t2)))1110 (dd "match (~a) ~s <-> ~s -> ~s" (if all "all" "any") t1 t2 m)1111 m))111211131114(define (match-argument-types typelist atypes typeenv)1115 ;; this doesn't need optional: it is only used for predicate- and specialization1116 ;; matching1117 (let loop ((tl typelist) (atypes atypes))1118 (cond ((null? tl) (null? atypes))1119 ((null? atypes) #f)1120 ((equal? '(#!rest) tl))1121 ((eq? (car tl) '#!rest)1122 (every1123 (lambda (at)1124 (match-types (cadr tl) at typeenv #t))1125 atypes))1126 ((match-types (car tl) (car atypes) typeenv #t)1127 (loop (cdr tl) (cdr atypes)))1128 (else #f))))112911301131;;; Simplify type specifier1132;1133; - coalesces "forall" and renames type-variables1134; - also removes unused typevars11351136(define (simplify-type t)1137 (let ((typeenv '()) ; ((VAR1 . NEWVAR1) ...)1138 (constraints '()) ; ((VAR1 TYPE1) ...)1139 (used '()))1140 (define (simplify t)1141 ;;(dd "simplify/rec: ~s" t)1142 (call/cc1143 (lambda (return)1144 (cond ((pair? t)1145 (case (car t)1146 ((forall)1147 (let ((typevars (second t)))1148 (set! typeenv1149 (append (map (lambda (v)1150 (let ((v (if (symbol? v) v (first v))))1151 (cons v (make-tv v))))1152 typevars)1153 typeenv))1154 (set! constraints1155 (append (filter-map1156 (lambda (v)1157 (and (pair? v) v))1158 typevars)1159 constraints))1160 (simplify (third t))))1161 ((or)1162 (let ((ts (delete-duplicates (map simplify (cdr t)) eq?)))1163 (cond ((null? ts) '*)1164 ((null? (cdr ts)) (car ts))1165 ((> (length ts) +maximal-union-type-length+)1166 (d "union-type cutoff! (~a): ~s" (length ts) ts)1167 '*)1168 ((every procedure-type? ts)1169 (if (any (cut eq? 'procedure <>) ts)1170 'procedure1171 (foldl1172 (lambda (pt t)1173 (let* ((name1 (procedure-name t))1174 (atypes1 (procedure-arguments t))1175 (rtypes1 (procedure-results t))1176 (name2 (procedure-name pt))1177 (atypes2 (procedure-arguments pt))1178 (rtypes2 (procedure-results pt)))1179 (append1180 '(procedure)1181 (if (and name1 name2 (eq? name1 name2)) (list name1) '())1182 (list (merge-argument-types atypes1 atypes2))1183 (merge-result-types rtypes1 rtypes2))))1184 (car ts)1185 (cdr ts))))1186 ((lset=/eq? '(true false) ts) 'boolean)1187 ((lset=/eq? '(fixnum bignum) ts) 'integer)1188 ((lset=/eq? '(fixnum float bignum ratnum cplxnum) ts) 'number)1189 (else1190 (let* ((ts (append-map1191 (lambda (t)1192 (let ((t (simplify t)))1193 (cond ((and (pair? t) (eq? 'or (car t)))1194 (cdr t))1195 ((eq? t 'undefined) (return 'undefined))1196 ((eq? t 'noreturn) (return '*))1197 (else (list t)))))1198 ts))1199 (ts2 (let loop ((ts ts) (done '()))1200 (cond ((null? ts) (reverse done))1201 ((eq? '* (car ts)) (return '*))1202 ((any (cut type<=? (car ts) <>) (cdr ts))1203 (loop (cdr ts) done))1204 ((any (cut type<=? (car ts) <>) done)1205 (loop (cdr ts) done))1206 (else (loop (cdr ts) (cons (car ts) done)))))))1207 (if (equal? ts2 (cdr t))1208 t1209 (simplify `(or ,@ts2))))))))1210 ((refine)1211 (let ((rs (second t))1212 (t2 (simplify (third t))))1213 (cond ((null? rs) t2)1214 ((refinement-type? t2)1215 (list 'refine (lset-union/eq? (second t2) rs) (third t2)))1216 (else1217 (list 'refine (delete-duplicates rs eq?) t2)))))1218 ((pair)1219 (let ((tcar (simplify (second t)))1220 (tcdr (simplify (third t))))1221 (if (and (eq? '* tcar) (eq? '* tcdr))1222 'pair1223 (canonicalize-list-type1224 `(pair ,tcar ,tcdr)))))1225 ((vector-of)1226 (let ((t2 (simplify (second t))))1227 (if (eq? t2 '*)1228 'vector1229 `(,(car t) ,t2))))1230 ((list-of)1231 (let ((t2 (simplify (second t))))1232 (if (eq? t2 '*)1233 'list1234 `(,(car t) ,t2))))1235 ((list)1236 (if (null? (cdr t))1237 'null1238 `(list ,@(map simplify (cdr t)))))1239 ((vector)1240 `(vector ,@(map simplify (cdr t))))1241 ((procedure)1242 (let* ((name (and (named? t) (cadr t)))1243 (rtypes (if name (cdddr t) (cddr t))))1244 (append1245 '(procedure)1246 (if name (list name) '())1247 (list (map simplify (if name (third t) (second t))))1248 (if (eq? '* rtypes)1249 '*1250 (map simplify rtypes)))))1251 (else t)))1252 ((assq t typeenv) =>1253 (lambda (e)1254 (set! used (lset-adjoin/eq? used t))1255 (cdr e)))1256 (else t)))))1257 (let ((t2 (simplify t)))1258 (when (pair? used)1259 (set! t21260 `(forall ,(filter-map1261 (lambda (e)1262 (and (memq (car e) used)1263 (let ((v (cdr e)))1264 (cond ((assq (car e) constraints) =>1265 (lambda (c)1266 (list v (simplify (cadr c)))))1267 (else v)))))1268 typeenv)1269 ,t2)))1270 (dd "simplify: ~a -> ~a" t t2)1271 t2)))12721273(define (maybe-expand-type t)1274 (and (symbol? t)1275 (alist-ref t type-expansions eq?)))12761277;;; Merging types12781279(define (merge-argument-types ts1 ts2)1280 ;; this could be more elegantly done by combining non-matching arguments/llists1281 ;; into "(or (procedure ...) (procedure ...))" and then simplifying1282 (cond ((null? ts1)1283 (cond ((null? ts2) '())1284 ((memq (car ts2) '(#!rest #!optional)) ts2)1285 (else '(#!rest))))1286 ((null? ts2) '(#!rest)) ;XXX giving up1287 ((eq? '#!rest (car ts1))1288 (cond ((and (pair? ts2) (eq? '#!rest (car ts2)))1289 `(#!rest1290 ,(simplify-type1291 `(or ,(rest-type (cdr ts1))1292 ,(rest-type (cdr ts2))))))1293 (else '(#!rest)))) ;XXX giving up1294 ((eq? '#!optional (car ts1))1295 (cond ((and (pair? ts2) (eq? '#!optional (car ts2)))1296 `(#!optional1297 ,(simplify-type `(or ,(cadr ts1) ,(cadr ts2)))1298 ,@(merge-argument-types (cddr ts1) (cddr ts2))))1299 (else '(#!rest)))) ;XXX1300 ((memq (car ts2) '(#!rest #!optional))1301 (merge-argument-types ts2 ts1))1302 (else (cons (simplify-type `(or ,(car ts1) ,(car ts2)))1303 (merge-argument-types (cdr ts1) (cdr ts2))))))13041305(define (merge-result-types ts11 ts21) ;XXX possibly overly conservative1306 (call/cc1307 (lambda (return)1308 (let loop ((ts1 ts11) (ts2 ts21))1309 (cond ((and (null? ts1) (null? ts2)) '())1310 ((or (atom? ts1) (atom? ts2)) (return '*))1311 (else (cons (simplify-type `(or ,(car ts1) ,(car ts2)))1312 (loop (cdr ts1) (cdr ts2)))))))))131313141315(define (compatible-types? t1 t2 #!optional (te (type-typeenv `(or ,t1 ,t2))))1316 (or (type<=? t1 t2 te)1317 (type<=? t2 t1 te)))13181319(define (type-min t1 t2 #!optional (te (type-typeenv `(or ,t1 ,t2))))1320 (cond ((type<=? t1 t2 te) t1)1321 ((type<=? t2 t1 te) t2)1322 (else #f)))13231324(define (type<=? t1 t2 #!optional (te (type-typeenv `(or ,t1 ,t2))))1325 (with-trail-restore1326 te1327 (lambda ()1328 (match-types t2 t1 te #t))))13291330;;1331;; Combines the information in `t1' and `t2' to produce a smaller type,1332;; with a preference for `t2' if no smaller type can be determined.1333;; Merges refinements at each step.1334;;13351336(define (refine-types t1 t2)13371338 (define (refine t1 t2 te)1339 (let loop ((t1 t1) (t2 t2))1340 (cond1341 ((maybe-expand-type t1) => (cut loop <> t2))1342 ((maybe-expand-type t2) => (cut loop t1 <>))1343 ((and (pair? t1) (memq (car t1) '(forall refine)))1344 (let ((t1* (loop (third t1) t2)))1345 (and t1* (list (car t1) (second t1) t1*))))1346 ((and (pair? t2) (memq (car t2) '(forall refine)))1347 (let ((t2* (loop t1 (third t2))))1348 (and t2* (list (car t2) (second t2) t2*))))1349 ;; (or pair null) ~> (list-of a) -> (list-of a)1350 ((and (pair? t1) (eq? (car t1) 'or)1351 (lset=/eq? '(null pair) (cdr t1))1352 (and (pair? t2) (eq? 'list-of (car t2))))1353 t2)1354 ((and (pair? t1) (eq? (car t1) 'or))1355 (let ((ts (filter-map (lambda (t) (loop t t2)) (cdr t1))))1356 (and (pair? ts) (cons 'or ts))))1357 ((and (pair? t1)1358 (memq (car t1) '(pair list vector vector-of list-of))1359 (pair? t2)1360 (eq? (car t1) (car t2))1361 (eq? (length t1) (length t2)))1362 (let ((ts (map loop (cdr t1) (cdr t2))))1363 (and (every identity ts) (cons (car t1) ts))))1364 (else1365 (type-min t1 t2 te)))))13661367 (let* ((te (type-typeenv `(or ,t1 ,t2)))1368 (rt (or (refine t1 t2 te) t2)))1369 (if (eq? rt t2)1370 rt1371 (simplify-type rt))))13721373;;; various operations on procedure types13741375(define (procedure-type? t)1376 (or (eq? 'procedure t)1377 (and (pair? t)1378 (case (car t)1379 ((forall) (procedure-type? (third t)))1380 ((procedure) #t)1381 ((or) (every procedure-type? (cdr t)))1382 (else #f)))))13831384(define (procedure-name t)1385 (and (pair? t)1386 (case (car t)1387 ((forall) (procedure-name (third t)))1388 ((procedure)1389 (let ((n (cadr t)))1390 (cond ((string? n) (string->symbol n))1391 ((symbol? n) n)1392 (else #f))))1393 (else #f))))13941395(define (procedure-arguments t)1396 (and (pair? t)1397 (case (car t)1398 ((forall) (procedure-arguments (third t)))1399 ((procedure)1400 (let ((n (second t)))1401 (if (or (string? n) (symbol? n))1402 (third t)1403 (second t))))1404 (else (bomb "procedure-arguments: not a procedure type" t)))))14051406(define (procedure-results t)1407 (and (pair? t)1408 (case (car t)1409 ((forall) (procedure-results (third t)))1410 ((procedure)1411 (let ((n (second t)))1412 (if (or (string? n) (symbol? n))1413 (cdddr t)1414 (cddr t))))1415 (else (bomb "procedure-results: not a procedure type" t)))))14161417(define (procedure-argument-types t n typeenv #!optional norest)1418 (let loop1 ((t t) (done '()))1419 (cond ((and (pair? t)1420 (eq? 'procedure (car t)))1421 (let* ((vf #f)1422 (ok #t)1423 (alen 0)1424 (llist1425 ;; quite a mess1426 (let loop ((at (if (or (string? (second t)) (symbol? (second t)))1427 (third t)1428 (second t)))1429 (m n)1430 (opt #f))1431 (cond ((null? at)1432 (set! ok (or opt (zero? m)))1433 '())1434 ((eq? '#!optional (car at))1435 (if norest1436 '()1437 (loop (cdr at) m #t) ))1438 ((eq? '#!rest (car at))1439 (cond (norest '())1440 (else1441 (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))1442 (make-list m (rest-type (cdr at))))))1443 ((and opt (<= m 0)) '())1444 (else1445 (set! ok (positive? m))1446 (set! alen (add1 alen))1447 (cons (car at) (loop (cdr at) (sub1 m) opt)))))))1448 (values llist vf ok alen)))1449 ((and (pair? t) (eq? 'forall (car t)))1450 (loop1 (third t) done)) ; assumes typeenv has already been extracted1451 ((assq t typeenv) =>1452 (lambda (e)1453 (let ((t2 (second e)))1454 (if (and t2 (memq t2 done))1455 (loop1 '* done) ; circularity1456 (loop1 t2 (cons t done))))))1457 (else (values (make-list n '*) #f #t n)))))14581459(define (procedure-result-types t values-rest? args typeenv)1460 (define (loop1 t)1461 (cond (values-rest? args)1462 ((assq t typeenv) => (lambda (e) (loop1 (second e))))1463 ((and (pair? t) (eq? 'procedure (car t)))1464 (call/cc1465 (lambda (return)1466 (let loop ((rt (if (or (string? (second t)) (symbol? (second t)))1467 (cdddr t)1468 (cddr t))))1469 (cond ((null? rt) '())1470 ((memq rt '(* noreturn)) (return '*))1471 (else (cons (car rt) (loop (cdr rt)))))))))1472 ((and (pair? t) (eq? 'forall (car t)))1473 (loop1 (third t))) ; assumes typeenv has already been extracted1474 (else '*)))1475 (loop1 t))14761477(define (named? t)1478 (and (pair? t)1479 (case (car t)1480 ((procedure)1481 (not (or (null? (cadr t)) (pair? (cadr t)))))1482 ((forall) (named? (third t)))1483 (else #f))))14841485(define (rest-type r)1486 (cond ((null? r) '*)1487 ((eq? 'values (car r)) '*)1488 (else (car r))))14891490(define (noreturn-procedure-type? ptype)1491 (and (pair? ptype)1492 (case (car ptype)1493 ((procedure)1494 (and (list? ptype)1495 (equal? '(noreturn)1496 (if (pair? (second ptype))1497 (cddr ptype)1498 (cdddr ptype)))))1499 ((forall)1500 (noreturn-procedure-type? (third ptype)))1501 (else #f))))15021503(define (noreturn-type? t)1504 (or (eq? 'noreturn t)1505 (and (pair? t)1506 (case (car t)1507 ((or) (any noreturn-type? (cdr t)))1508 ((forall) (noreturn-type? (third t)))1509 (else #f)))))15101511;;; Refinement type helpers15121513(define (refinement-type? t)1514 (and (pair? t)1515 (case (first t)1516 ((refine) #t)1517 ((forall) (refinement-type? (third t)))1518 (else #f))))15191520;;; Type-environments and -variables15211522(define (make-tv sym)1523 (let* ((r (get sym '##core#tv-root))1524 ;; ##core#tv-root is a string to make this gensym fast1525 (new (gensym r)))1526 (put! new '##core#tv-root r)1527 new))15281529(define (type-typeenv t)1530 (let ((te '()))1531 (let loop ((t t))1532 (when (pair? t)1533 (case (car t)1534 ((refine)1535 (loop (third t)))1536 ((procedure)1537 (cond ((or (string? (second t)) (symbol? (second t)))1538 (for-each loop (third t))1539 (when (pair? (cdddr t))1540 (for-each loop (cdddr t))))1541 (else1542 (for-each loop (second t))1543 (when (pair? (cddr t))1544 (for-each loop (cddr t))))))1545 ((forall)1546 (set! te (append (map (lambda (tv)1547 (if (symbol? tv)1548 (list tv #f #f)1549 (list (first tv) #f (second tv))))1550 (second t))1551 te))1552 (loop (third t)))1553 ((or)1554 (for-each loop (cdr t))))))1555 te))15561557(define (trail-restore tr typeenv)1558 (do ((tr2 trail (cdr tr2)))1559 ((eq? tr2 tr))1560 (let ((a (assq (car tr2) typeenv)))1561 (set-car! (cdr a) #f))))15621563(define (with-trail-restore typeenv thunk)1564 (let* ((trail0 trail)1565 (result (thunk)))1566 (trail-restore trail0 typeenv)1567 result))15681569(define (resolve t typeenv)1570 (simplify-type ;XXX do only when necessary1571 (let resolve ((t t) (done '()))1572 (cond ((assq t typeenv) =>1573 (lambda (a)1574 (let ((t2 (second a)))1575 (if (or (not t2)1576 (memq t done)1577 (memq t2 done)) ; circular reference1578 (if (third a)1579 (resolve (third a) (cons t done))1580 '*)1581 (resolve t2 (cons t done))))))1582 ((not (pair? t))1583 (if (or (memq t value-types) (memq t basic-types))1584 t1585 (bomb "resolve: can't resolve unknown type-variable" t)))1586 (else1587 (case (car t)1588 ((or) `(or ,@(map (cut resolve <> done) (cdr t))))1589 ((not) `(not ,(resolve (second t) done)))1590 ((forall refine)1591 (list (car t) (second t) (resolve (third t) done)))1592 ((pair list vector vector-of list-of)1593 (cons (car t) (map (cut resolve <> done) (cdr t))))1594 ((procedure)1595 (let* ((name (procedure-name t))1596 (argtypes (procedure-arguments t))1597 (rtypes (procedure-results t)))1598 `(procedure1599 ,@(if name (list name) '())1600 ,(let loop ((args argtypes))1601 (cond ((null? args) '())1602 ((eq? '#!rest (car args))1603 (if (equal? '(values) (cdr args))1604 args1605 (cons (car args) (loop (cdr args)))))1606 ((eq? '#!optional (car args))1607 (cons (car args) (loop (cdr args))))1608 (else (cons (resolve (car args) done) (loop (cdr args))))))1609 ,@(if (eq? '* rtypes)1610 '*1611 (map (cut resolve <> done) rtypes)))))1612 (else t)))))))161316141615;;; type-db processing16161617(define (load-type-database name specialize #!optional1618 (path (repository-path)))1619 (and-let* ((dbfile (if (not path)1620 (and (##sys#file-exists? name #t #f #f) name)1621 (chicken.load#find-file name path))))1622 (debugging 'p (sprintf "loading type database `~a' ...~%" dbfile))1623 (fluid-let ((scrutiny-debug #f))1624 (for-each1625 (lambda (e)1626 (let* ((name (car e))1627 (old (variable-mark name '##compiler#type))1628 (specs (and (pair? (cddr e)) (cddr e)))1629 (new1630 (let adjust ((new (cadr e)))1631 (if (pair? new)1632 (cond ((and (vector? (car new))1633 (eq? 'procedure (vector-ref (car new) 0)))1634 (let loop ((props (cdr (vector->list (car new)))))1635 (unless (null? props)1636 (case (car props)1637 ((#:pure)1638 (mark-variable name '##compiler#pure #t)1639 (loop (cdr props)))1640 ((#:clean)1641 (mark-variable name '##compiler#clean #t)1642 (loop (cdr props)))1643 ((#:enforce)1644 (mark-variable name '##compiler#enforce #t)1645 (loop (cdr props)))1646 ((#:foldable)1647 (mark-variable name '##compiler#foldable #t)1648 (loop (cdr props)))1649 ((#:predicate)1650 (mark-variable name '##compiler#predicate (cadr props))1651 (loop (cddr props)))1652 (else1653 (bomb1654 "load-type-database: invalid procedure-type property"1655 (car props) new)))))1656 `(procedure ,@(cdr new)))1657 ((eq? 'forall (car new))1658 `(forall ,(second new) ,(adjust (third new))))1659 (else new))1660 new))))1661 ;; validation is needed, even though .types-files can be considered1662 ;; correct, because type variables have to be renamed:1663 (let-values (((t pred pure) (validate-type new name)))1664 (unless t1665 (warning1666 (sprintf "Invalid type specification for `~a':~%~%~a"1667 name1668 (type->pp-string new))))1669 (when (and old (not (compatible-types? old t)))1670 (warning1671 (sprintf1672 (string-append1673 "Declared type for toplevel binding `~a'"1674 "~%~%~a~%~%"1675 " conflicts with previously loaded type:"1676 "~%~%~a")1677 name1678 (type->pp-string new)1679 (type->pp-string old))))1680 (mark-variable name '##compiler#type t)1681 (mark-variable name '##compiler#type-source 'db)1682 (when specs1683 (install-specializations name specs)))))1684 (call-with-input-file dbfile read-expressions))1685 #t)))16861687(define (hash-table->list ht)1688 (let ((len (vector-length ht)))1689 (let loop1 ((i 0) (lst '()))1690 (if (>= i len)1691 lst1692 (let loop2 ((bl (vector-ref ht i))1693 (lst lst))1694 (if (null? bl)1695 (loop1 (add1 i) lst)1696 (loop2 (cdr bl)1697 (cons (cons (caar bl) (cdar bl)) lst))))))))16981699(define (symbol<? s1 s2)1700 (string<? (symbol->string s1)1701 (symbol->string s2)))17021703(define (emit-types-file source-file types-file db block-compilation)1704 (with-output-to-file types-file1705 (lambda ()1706 (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "1707 source-file "\n")1708 (for-each1709 (lambda (p)1710 (let ((sym (car p))1711 (plist (cdr p)))1712 (when (and (variable-visible? sym block-compilation)1713 (memq (variable-mark sym '##compiler#type-source) '(local inference)))1714 (let ((specs (or (variable-mark sym '##compiler#specializations) '()))1715 (type (variable-mark sym '##compiler#type))1716 (pred (variable-mark sym '##compiler#predicate))1717 (pure (variable-mark sym '##compiler#pure))1718 (clean (variable-mark sym '##compiler#clean))1719 (enforce (variable-mark sym '##compiler#enforce))1720 (foldable (variable-mark sym '##compiler#foldable)))1721 (pp (cons* sym1722 (let wrap ((type type))1723 (if (pair? type)1724 (case (car type)1725 ((procedure)1726 `(#(procedure1727 ,@(if enforce '(#:enforce) '())1728 ,@(if pred `(#:predicate ,pred) '())1729 ,@(if pure '(#:pure) '())1730 ,@(if clean '(#:clean) '())1731 ,@(if foldable '(#:foldable) '()))1732 ,@(cdr type)))1733 ((forall)1734 `(forall ,(second type) ,(wrap (third type))))1735 (else type))1736 type))1737 specs))1738 (newline)))))1739 (sort (hash-table->list db)1740 (lambda (a b) (symbol<? (car a) (car b)))))1741 (print "; END OF FILE"))))17421743;;1744;; Source node tracking1745;;1746;; Nodes are mutated in place during specialization, which may lose line1747;; number information if, for example, a node is changed from a1748;; ##core#call to a class without debug info. To preserve line numbers1749;; and allow us to print fragments of the original source, we maintain a1750;; side table of mappings from mutated nodes to copies of the originals.1751;;17521753(define node-mutations '())17541755(define (mutate-node! node expr)1756 (set! node-mutations (alist-update! node (copy-node node) node-mutations))1757 (copy-node! (build-node-graph expr) node))17581759(define (source-node n #!optional (k values))1760 (let ((orig (alist-ref n node-mutations eq?)))1761 (if (not orig) (k n) (source-node orig k))))17621763(define (source-node-tree n)1764 (source-node1765 n1766 (lambda (n*)1767 (make-node (node-class n*)1768 (node-parameters n*)1769 (map source-node-tree (node-subexpressions n*))))))17701771(define (node-line-number n)1772 (node-debug-info (source-node n)))17731774(define (node-debug-info n)1775 (case (node-class n)1776 ((##core#call)1777 (let ((params (node-parameters n)))1778 (and (pair? (cdr params))1779 (pair? (cadr params)) ; debug-info has line-number information?1780 (source-info->line (cadr params)))))1781 ((##core#typecase)1782 (car (node-parameters n)))1783 (else #f)))17841785;; Mutate node for specialization17861787(define (specialize-node! node args template)1788 (let ((env '()))1789 (define (subst x)1790 (cond ((and (vector? x)1791 (= 1 (vector-length x)) )1792 (let ((y (vector-ref x 0)))1793 (cond ((integer? y)1794 (if (negative? y)1795 (list-tail args (sub1 (- y)))1796 (list-ref args (sub1 y))))1797 ((symbol? y)1798 (cond ((assq y env) => cdr)1799 (else1800 (let ((var (gensym y)))1801 (set! env (alist-cons y var env))1802 var)))))))1803 ((and (vector? x)1804 (= 2 (vector-length x))1805 (integer? (vector-ref x 0))1806 (eq? '... (vector-ref x 1)))1807 (list-tail args (sub1 (vector-ref x 0))))1808 ((not (pair? x)) x)1809 ((eq? 'quote (car x)) x) ; to handle numeric constants1810 (else (cons (subst (car x)) (subst (cdr x))))))1811 (mutate-node! node (subst template))))181218131814;;; Type-validation and -normalization18151816(define (validate-type type name)1817 ;; - returns converted type or #f1818 ;; - also converts "(... -> ...)" types1819 ;; - converts some typenames to struct types (u32vector, etc.)1820 ;; - handles some type aliases1821 ;; - drops "#!key ..." args by converting to #!rest1822 ;; - replaces uses of "&rest"/"&optional" with "#!rest"/"#!optional"1823 ;; - handles "(T1 -> T2 : T3)" (predicate)1824 ;; - handles "(T1 --> T2 [: T3])" (clean)1825 ;; - simplifies result1826 ;; - coalesces all "forall" forms into one (remove "forall" if typevar-set is empty)1827 ;; - renames type-variables1828 ;; - replaces type-abbreviations1829 ;; - replaces "blob" by "bytevector" for backwards compatibility1830 (let ((ptype #f) ; (T . PT) | #f1831 (clean #f)1832 (typevars '())1833 (constraints '()))1834 (define (upto lst p)1835 (let loop ((lst lst))1836 (cond ((eq? lst p) '())1837 (else (cons (car lst) (loop (cdr lst)))))))1838 (define (memq* x lst) ; memq, but allow improper list1839 (let loop ((lst lst))1840 (cond ((not (pair? lst)) #f)1841 ((eq? (car lst) x) lst)1842 (else (loop (cdr lst))))))1843 (define (validate-llist llist)1844 (cond ((null? llist) '())1845 ((symbol? llist) '(#!rest *))1846 ((not (pair? llist)) #f)1847 ((or (eq? '#!optional (car llist))1848 (eq? '&optional (car llist)))1849 (let ((l1 (validate-llist (cdr llist))))1850 (and l1 (cons '#!optional l1))))1851 ((or (eq? '#!rest (car llist))1852 (eq? '&rest (car llist)))1853 (cond ((null? (cdr llist)) '(#!rest *))1854 ((not (pair? (cdr llist))) #f)1855 (else1856 (let ((l1 (validate (cadr llist))))1857 (and l1 `(#!rest ,l1))))))1858 ((eq? '#!key (car llist)) '(#!rest *))1859 (else1860 (let* ((l1 (validate (car llist)))1861 (l2 (validate-llist (cdr llist))))1862 (and l1 l2 (cons l1 l2))))))1863 (define (validate t #!optional (rec #t))1864 (cond ((memq t value-types) t)1865 ((memq t basic-types) t)1866 ((memq t struct-types) `(struct ,t))1867 ((eq? t 'immediate) '(or eof null fixnum char boolean))1868 ((eq? t 'any) '*)1869 ((eq? t 'blob) 'bytevector) ; DEPRECATED1870 ((eq? t 'void) 'undefined)1871 ((eq? t 'input-port) '(refine (input) port))1872 ((eq? t 'output-port) '(refine (output) port))1873 ((and (symbol? t) (##sys#get t '##compiler#type-abbreviation)))1874 ((not (pair? t))1875 (cond ((memq t typevars) t)1876 (else #f)))1877 ((eq? 'not (car t))1878 (and (= 2 (length t))1879 `(not ,(validate (second t)))))1880 ((eq? 'forall (car t))1881 (and (= 3 (length t))1882 (list? (second t))1883 (call/cc1884 (lambda (return)1885 (set! typevars1886 (append (map (lambda (tv)1887 (cond ((symbol? tv) tv)1888 ((and (list? tv)1889 (= 2 (length tv))1890 (symbol? (car tv)))1891 (car tv))1892 (else (return #f))))1893 (second t))1894 typevars))1895 (set! constraints1896 (append (filter-map1897 (lambda (tv)1898 (and (pair? tv)1899 (list (car tv)1900 (let ((t (validate (cadr tv))))1901 (unless t (return #f))1902 t))))1903 (second t))1904 constraints))1905 (validate (third t) rec)))))1906 ((and (eq? 'quote (car t))1907 (pair? (cdr t))1908 (symbol? (second t))1909 (null? (cddr t))1910 (second t))1911 => (lambda (v)1912 (unless (memq v typevars)1913 (set! typevars (cons v typevars)))1914 v))1915 ((eq? 'or (car t))1916 (and (list? t)1917 (not (null? (cdr t)))1918 (let ((ts (map validate (cdr t))))1919 (and (every identity ts)1920 `(or ,@ts)))))1921 ((eq? 'struct (car t))1922 (and (= 2 (length t)) (symbol? (second t)) t))1923 ((eq? 'deprecated (car t))1924 (and (= 2 (length t)) (symbol? (second t)) t))1925 ((eq? 'refine (car t))1926 (and (= 3 (length t))1927 (let ((t2 (validate (third t))))1928 (and (value-type? t2)1929 (list? (second t))1930 (every symbol? (second t))1931 (list 'refine (second t) t2)))))1932 ((or (memq* '--> t) (memq* '-> t)) =>1933 (lambda (p)1934 (let* ((cleanf (eq? '--> (car p)))1935 (ok (or (not rec) (not cleanf))))1936 (unless rec (set! clean cleanf))1937 (let ((cp (memq* ': p)))1938 (cond ((not cp)1939 (and ok1940 (validate1941 `(procedure ,(upto t p) ,@(cdr p))1942 rec)))1943 ((and (= 5 (length t))1944 (eq? p (cdr t)) ; one argument?1945 (eq? cp (cdddr t))) ; 4th item is ":"?1946 (set! t (validate `(procedure (,(first t)) ,(third t)) rec))1947 ;; we do it this way to distinguish the "outermost" predicate1948 ;; procedure type1949 (set! ptype (cons t (validate (cadr cp))))1950 (and ok t))1951 (else #f))))))1952 ((memq (car t) '(vector-of list-of))1953 (and (list? t)1954 (= 2 (length t))1955 (let ((t2 (validate (second t))))1956 (and t2 `(,(car t) ,t2)))))1957 ((memq (car t) '(vector list))1958 (and (list? t)1959 (let loop ((ts (cdr t)) (ts2 '()))1960 (cond ((null? ts) `(,(car t) ,@(reverse ts2)))1961 ((validate (car ts)) =>1962 (lambda (t2) (loop (cdr ts) (cons t2 ts2))))1963 (else #f)))))1964 ((eq? 'pair (car t))1965 (and (= 3 (length t))1966 (let ((ts (map validate (cdr t))))1967 (and (every identity ts) `(pair ,@ts)))))1968 ((eq? 'procedure (car t))1969 (and (pair? (cdr t))1970 (let* ((name (if (symbol? (cadr t))1971 (cadr t)1972 name))1973 (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))1974 (and (pair? t2)1975 (list? (car t2))1976 (let ((ts (validate-llist (car t2))))1977 (and ts1978 (every identity ts)1979 (let* ((rt2 (cdr t2))1980 (rt (if (eq? '* rt2)1981 rt21982 (and (list? rt2)1983 (let ((rts (map validate rt2)))1984 (and (every identity rts)1985 rts))))))1986 (and rt1987 `(procedure1988 ,@(if (and name (not rec)) (list name) '())1989 ,ts1990 ,@rt)))))))))1991 (else #f)))1992 (cond ((validate type #f) =>1993 (lambda (type)1994 (when (pair? typevars)1995 (set! type1996 `(forall1997 ,(map (lambda (tv)1998 (put! tv '##core#tv-root (symbol->string (strip-syntax tv)))1999 (cond ((assq tv constraints) => identity)2000 (else tv)))2001 (delete-duplicates typevars eq?))2002 ,type)))2003 (let ((type2 (simplify-type type)))2004 (values2005 type22006 (and ptype (eq? (car ptype) type) (cdr ptype))2007 clean))))2008 (else (values #f #f #f)))))20092010(define (check-and-validate-type type loc #!optional name)2011 (let-values (((t pred pure) (validate-type (strip-syntax type) name)))2012 (or t2013 (error loc "invalid type specifier" type))))20142015(define (install-specializations name specs)2016 (define (fail spec)2017 (error "invalid specialization format" spec name))2018 (mark-variable2019 name '##compiler#specializations2020 ;;XXX it would be great if result types could refer to typevars2021 ;; bound in the argument types, like this:2022 ;;2023 ;; (: with-input-from-file ((-> . *) -> . *)2024 ;; (((forall (a) (-> a))) (a) ...code that does it single-valued-ly...))2025 ;;2026 ;; This would make it possible to propagate the (single) result type from2027 ;; the thunk to the enclosing expression. Unfortunately the simplification in2028 ;; the first validation renames typevars, so the second validation will have2029 ;; non-matching names.2030 (map (lambda (spec)2031 (if (and (list? spec) (list? (first spec)))2032 (let* ((args2033 (map (lambda (t)2034 (let-values (((t2 pred pure) (validate-type t #f)))2035 (or t22036 (error "invalid argument type in specialization"2037 t spec name))))2038 (first spec)))2039 (typevars (unzip1 (append-map type-typeenv args))))2040 (cons2041 args2042 (case (length spec)2043 ((2) (cdr spec))2044 ((3)2045 (cond ((list? (second spec))2046 (cons2047 (map (lambda (t)2048 (let-values (((t2 pred pure) (validate-type t #f)))2049 (or t22050 (error "invalid result type in specialization"2051 t spec name))))2052 (second spec))2053 (cddr spec)))2054 ((eq? '* (second spec)) (cdr spec))2055 (else (fail spec))))2056 (else (fail spec)))))2057 (fail spec)))2058 specs)))205920602061;;; Canonicalize complex pair/list type for matching with "list-of"2062;2063; Returns an equivalent (list ...) form, or the original argument if no2064; canonicalization could be done.20652066(define (canonicalize-list-type t)2067 (cond ((not (pair? t)) t)2068 ((eq? 'pair (car t))2069 (let ((tcar (second t))2070 (tcdr (third t)))2071 (let rec ((tr tcdr) (ts (list tcar)))2072 (cond ((eq? 'null tr)2073 `(list ,@(reverse ts)))2074 ((and (pair? tr) (eq? 'pair (first tr)))2075 (rec (third tr) (cons (second tr) ts)))2076 ((and (pair? tr) (eq? 'list (first tr)))2077 `(list ,@(reverse ts) ,@(cdr tr)))2078 (else t)))))2079 (else t)))208020812082;;; Drop namespace from module-prefixed symbol:20832084(define (strip-namespace sym)2085 (let* ((s (symbol->string sym))2086 (n (string-length s)))2087 (let loop ((i 0))2088 (cond ((eq? i n) sym)2089 ((eq? (string-ref s i) #\#)2090 (##sys#string->symbol (##sys#substring s (fx+ i 1) n)))2091 (else (loop (fx+ i 1)))))))209220932094;;; hardcoded result types for certain primitives20952096(define-syntax define-special-case2097 (syntax-rules ()2098 ((_ name handler)2099 (##sys#put! 'name '##compiler#special-result-type handler))))21002101(define-special-case ##sys#make-structure2102 (lambda (node args loc rtypes)2103 (or (and-let* ((subs (node-subexpressions node))2104 ((>= (length subs) 2))2105 (arg1 (second subs))2106 ((eq? 'quote (node-class arg1)))2107 (val (first (node-parameters arg1)))2108 ((symbol? val)))2109 ;;XXX a dirty hack - we should remove the distinct2110 ;; "pointer-vector" type.2111 (if (eq? 'pointer-vector val)2112 '(pointer-vector)2113 `((struct ,(strip-namespace val)))))2114 rtypes)))21152116(let ()2117 (define (known-length-vector-index node args loc expected-argcount)2118 (and-let* ((subs (node-subexpressions node))2119 ((= (length subs) (add1 expected-argcount)))2120 (arg1 (walked-result (second args)))2121 ((pair? arg1))2122 ((eq? 'vector (car arg1)))2123 (index (third subs))2124 ((eq? 'quote (node-class index)))2125 (val (first (node-parameters index)))2126 ((fixnum? val)) ; Standard type warning otherwise2127 (vector-length (length (cdr arg1))))2128 (if (and (>= val 0) (< val vector-length))2129 val2130 (begin2131 (r-index-out-of-range loc node val vector-length "vector")2132 #f))))21332134 ;; These are a bit hacky, since they mutate the node. These special2135 ;; cases are really only intended for determining result types...2136 (define (vector-ref-result-type node args loc rtypes)2137 (or (and-let* ((index (known-length-vector-index node args loc 2))2138 (arg1 (walked-result (second args)))2139 (vector (second (node-subexpressions node))))2140 (mutate-node! node `(##sys#slot ,vector ',index))2141 (list (list-ref (cdr arg1) index)))2142 rtypes))21432144 (define-special-case scheme#vector-ref vector-ref-result-type)2145 (define-special-case ##sys#vector-ref vector-ref-result-type)21462147 (define-special-case scheme#vector-set!2148 (lambda (node args loc rtypes)2149 (or (and-let* ((index (known-length-vector-index node args loc 3))2150 (subs (node-subexpressions node))2151 (vector (second subs))2152 (new-value (fourth subs))2153 (new-value-type (walked-result (fourth args)))2154 (setter (if (type-always-immediate? new-value-type)2155 '##sys#setislot2156 '##sys#setslot)))2157 (mutate-node! node `(,setter ,vector ',index ,new-value))2158 '(undefined))2159 rtypes))))21602161;; TODO: Also special-case vector-length? Makes little sense though.216221632164;;; List-related special cases2165;2166; Preserve known element types for:2167;2168; list-ref, list-tail21692170(let ()2171 (define (list-or-null a)2172 (if (null? a) 'null `(list ,@a)))21732174 ;; Split a list or pair type form at index i, calling k with the two2175 ;; sections of the type or returning #f if it doesn't match that far.2176 ;; Note that "list-of" is handled by "forall" entries in types.db2177 (define (split-list-type l i k)2178 (cond ((not (pair? l))2179 (and (fx= i 0) (eq? l 'null) (k l l)))2180 ((eq? (first l) 'list)2181 (and (fx< i (length l))2182 (receive (left right) (split-at (cdr l) i)2183 (k (list-or-null left)2184 (list-or-null right)))))2185 ((eq? (first l) 'pair)2186 (let lp ((a '()) (l l) (i i))2187 (cond ((fx= i 0)2188 (k (list-or-null (reverse a)) l))2189 ((and (pair? l)2190 (eq? (first l) 'pair))2191 (lp (cons (second l) a)2192 (third l)2193 (sub1 i)))2194 (else #f))))2195 (else #f)))21962197 ;; canonicalize-list-type will have taken care of converting (pair2198 ;; (pair ...)) to (list ...) or (list-of ...) for proper lists.2199 (define (proper-list-type-length t)2200 (cond ((eq? t 'null) 0)2201 ((and (pair? t) (eq? (car t) 'list)) (length (cdr t)))2202 (else #f)))22032204 (define (list+index-call-result-type-special-case k)2205 (lambda (node args loc rtypes)2206 (or (and-let* ((subs (node-subexpressions node))2207 ((= (length subs) 3))2208 (arg1 (walked-result (second args)))2209 (index (third subs))2210 ((eq? 'quote (node-class index)))2211 (val (first (node-parameters index)))2212 ((fixnum? val))) ; Standard type warning otherwise2213 (cond ((negative? val)2214 (r-index-out-of-range loc node val 'not-used "list")2215 #f)2216 ((split-list-type arg1 val k))2217 ;; Warn only if it's a known proper list. This avoids2218 ;; false warnings due to component smashing.2219 ((proper-list-type-length arg1) =>2220 (lambda (length)2221 (r-index-out-of-range loc node val length "list")2222 #f))2223 (else #f)))2224 rtypes)))22252226 (define-special-case scheme#list-ref2227 (list+index-call-result-type-special-case2228 (lambda (_ result-type)2229 (and (pair? result-type)2230 (list (cadr result-type))))))22312232 (define-special-case scheme#list-tail2233 (list+index-call-result-type-special-case2234 (lambda (_ result-type) (list result-type)))))22352236(define-special-case scheme#list2237 (lambda (node args loc rtypes)2238 (if (null? (cdr args))2239 '(null)2240 `((list ,@(map walked-result (cdr args)))))))22412242(define-special-case ##sys#list2243 (lambda (node args loc rtypes)2244 (if (null? (cdr args))2245 '(null)2246 `((list ,@(map walked-result (cdr args)))))))22472248(define-special-case scheme#vector2249 (lambda (node args loc rtypes)2250 `((vector ,@(map walked-result (cdr args))))))22512252(define-special-case ##sys#vector2253 (lambda (node args loc rtypes)2254 `((vector ,@(map walked-result (cdr args))))))22552256(define-special-case scheme#reverse2257 (lambda (node args loc rtypes)2258 (or (and-let* ((subs (node-subexpressions node))2259 ((= (length subs) 2))2260 (arg1 (walked-result (second args)))2261 ((pair? arg1))2262 ((eq? (car arg1) 'list)))2263 `((list ,@(reverse (cdr arg1)))))2264 rtypes)))22652266(let ()2267 (define (append-special-case node args loc rtypes)2268 (define (potentially-proper-list? l) (match-types l 'list '()))22692270 (define (derive-result-type)2271 (let lp ((args (cdr args))2272 (index 1))2273 (if (null? args)2274 'null2275 (let* ((arg1 (car args))2276 (arg1-t (walked-result arg1)))2277 (cond2278 ((and (pair? arg1-t) (eq? (car arg1-t) 'list))2279 (and-let* ((rest-t (lp (cdr args) (add1 index))))2280 ;; decanonicalize, then recanonicalize to make it2281 ;; easy to append a variety of types.2282 (canonicalize-list-type2283 (foldl (lambda (rest t) `(pair ,t ,rest))2284 rest-t (reverse (cdr arg1-t))))))22852286 ((and (pair? arg1-t) (eq? (car arg1-t) 'list-of))2287 (and-let* ((rest-t (lp (cdr args) (add1 index))))2288 ;; list-of's length unsurety is "contagious"2289 (simplify-type `(or ,arg1-t ,rest-t))))22902291 ;; TODO: (append (pair x (pair y z)) lst) =>2292 ;; (pair x (pair y (or z lst)))2293 ;; This is trickier than it sounds!22942295 (else2296 ;; The final argument may be an atom or improper list2297 (unless (or (null? (cdr args))2298 (potentially-proper-list? arg1-t))2299 (r-proc-call-argument-type-mismatch2300 loc node index arg1 'list arg1-t2301 (variable-mark 'scheme#append '##compiler#type)))2302 #f))))))2303 (cond ((derive-result-type) => list)2304 (else rtypes)))23052306 (define-special-case scheme#append append-special-case)2307 (define-special-case ##sys#append append-special-case))23082309;;; Special cases for make-list/make-vector with a known size2310;2311; e.g. (make-list 3 #\a) => (list char char char)23122313(let ()23142315 (define (complex-object-constructor-result-type-special-case type)2316 (lambda (node args loc rtypes)2317 (or (and-let* ((subs (node-subexpressions node))2318 (fill (case (length subs)2319 ((2) '*)2320 ((3) (walked-result (third args)))2321 (else #f)))2322 (sub2 (second subs))2323 ((eq? 'quote (node-class sub2)))2324 (size (first (node-parameters sub2)))2325 ((fixnum? size))2326 ((<= 0 size +maximal-complex-object-constructor-result-type-length+)))2327 `((,type ,@(make-list size fill))))2328 rtypes)))23292330 (define-special-case scheme#make-vector2331 (complex-object-constructor-result-type-special-case 'vector)))233223332334;;; perform check over all typevar instantiations2335;2336; If "all" is #t all types in tlist must match, if #f then one or more.23372338(define (over-all-instantiations tlist typeenv all process)2339 (let ((insts '())2340 (anyinst #f)2341 (trail0 trail))23422343 ;; restore trail and collect instantiations2344 (define (restore)2345 (ddd "restoring, trail: ~s, te: ~s" trail typeenv)2346 (let ((is '()))2347 (do ((tr trail (cdr tr)))2348 ((eq? tr trail0)2349 (set! trail tr)2350 (when (pair? is) (set! anyinst #t))2351 (set! insts (cons is insts)))2352 (set! is (alist-cons2353 (car tr)2354 (resolve (car tr) typeenv)2355 is))2356 (ddd " restoring ~a, insts: ~s" (car tr) insts)2357 (let ((a (assq (car tr) typeenv)))2358 (set-car! (cdr a) #f)))))23592360 ;; collect candidates for each typevar2361 (define (collect)2362 (let* ((vars (delete-duplicates (concatenate (map unzip1 insts)) eq?))2363 (all (map (lambda (var)2364 (cons2365 var2366 (filter-map2367 (lambda (inst)2368 (cond ((assq var inst) => cdr)2369 ;;XXX is the following correct in all cases?2370 (all '*)2371 (else #f)))2372 insts)))2373 vars)))2374 (ddd " collected: ~s" all)2375 all))23762377 (ddd " over-all-instantiations: ~s all: ~a" tlist all)2378 ;; process all tlist elements2379 (let loop ((ts (delete-duplicates tlist eq?))2380 (ok #f))2381 (cond ((null? ts)2382 (cond ((or ok (null? tlist))2383 (for-each2384 (lambda (i)2385 (set! trail (cons (car i) trail))2386 (set-car! (cdr (assq (car i) typeenv))2387 (simplify-type `(or ,@(cdr i)))))2388 (collect))2389 #t)2390 (else #f)))2391 ((process (car ts))2392 (restore)2393 (loop (cdr ts) #t))2394 (all2395 (restore)2396 #f)2397 (else2398 (restore)2399 (loop (cdr ts) ok))))))24002401;;; Report helpers24022403(define (multiples n)2404 (if (= n 1) "" "s"))24052406(define (string-add-indent str #!optional (indent " "))2407 (let* ((ls (string-split str "\n" #t))2408 (s (string-intersperse2409 (map (lambda (l)2410 (if (string=? "" l)2411 l2412 (string-append indent l)))2413 ls)2414 "\n")))2415 (if (eq? #\newline (string-ref str (sub1 (string-length str))))2416 (string-append s "\n")2417 s)))24182419(define (type->pp-string t)2420 (define (pp-tv tv)2421 (let ((r (get tv '##core#tv-root)))2422 (assert r (list tv: tv))2423 (list 'quote (string->symbol r))))2424 (define (conv t #!optional (tv-replacements '()))2425 (define (R t) (conv t tv-replacements))2426 (cond2427 ((not (pair? t))2428 (or (alist-ref t tv-replacements eq?) t))2429 ((refinement-type? t)2430 (string->symbol2431 (sprintf "~a-~a" (string-intersperse (map conc (second t)) "/") (third t))))2432 (else2433 (let ((tcar (and (pair? t) (car t))))2434 (cond2435 ((and (eq? 'forall tcar) (every symbol? (second t))) ; no constraints2436 (let ((tvs (map (lambda (tv) (cons tv (pp-tv tv))) (second t))))2437 (conv (third t) tvs)))2438 ((eq? 'forall tcar) t) ; forall with constraints, do nothing2439 ((memq tcar '(or not list vector pair list-of vector-of))2440 `(,tcar ,@(map R (cdr t))))2441 ((eq? 'struct tcar) t)2442 ((eq? 'procedure tcar)2443 (let ((args (map R (procedure-arguments t)))2444 (res (let ((res (procedure-results t)))2445 (if (eq? '* res)2446 #f2447 (map R res)))))2448 (if (not res) ; '. *' return type not supported by ->2449 `(procedure ,args ,@(or res '*))2450 `(,@args ,(if (and-let* ((pn (procedure-name t))2451 ((variable-mark pn '##compiler#pure))))2452 '--> '->)2453 ,@res))))2454 (else (bomb "type->pp-string: unhandled type" t)))))))2455 (let ((t* (conv (strip-syntax t))))2456 (string-add-indent2457 (string-chomp2458 (with-output-to-string2459 (lambda () (pp t*)))))))24602461(define (fragment x)2462 (let ((x (build-expression-tree (source-node-tree x))))2463 (let walk ((x x) (d 0))2464 (cond ((atom? x) (strip-syntax x))2465 ((>= d +fragment-max-depth+) '...)2466 ((list? x)2467 (let* ((len (length x))2468 (xs (if (< +fragment-max-length+ len)2469 (append (take x +fragment-max-length+) '(...))2470 x)))2471 (map (cute walk <> (add1 d)) xs)))2472 (else (strip-syntax x))))))24732474(define (pp-fragment x)2475 (string-add-indent2476 (string-chomp2477 (with-output-to-string2478 (lambda ()2479 (pp (fragment x)))))))24802481(define (node-source-prefix n)2482 (let ((line (node-line-number n)))2483 (if (not line) "" (sprintf "In file `~a'," line))))24842485(define (location-name loc #!optional (indent " "))2486 (define (lname loc1)2487 (if loc12488 (sprintf "In procedure `~a'," (real-name loc1))2489 "In a local procedure,"))2490 (if (null? loc)2491 (conc "At the toplevel,\n" indent)2492 (let rec ((loc loc)2493 (msgs (list "")))2494 (if (null? (cdr loc))2495 (string-intersperse2496 (cons (if (car loc)2497 ;; If the first location is of format 'bar#foo'2498 ;; consider it as being being procedure 'foo' in2499 ;; module 'bar'.2500 (receive (var mod) (variable-and-module (real-name (car loc)))2501 (conc (if mod (sprintf "In module `~a',~%~a" mod indent) "")2502 (sprintf "In procedure `~a'," var)))2503 "In a toplevel procedure,") msgs)2504 (conc "\n" indent))2505 (rec (cdr loc)2506 (cons (lname (car loc)) msgs))))))25072508(define (variable-and-module name) ; -> (values var module-or-false)2509 (let* ((str-name (if (symbol? name) (symbol->string name) name))2510 (r (string-split str-name "#" #t)))2511 (if (pair? (cdr r))2512 (values (string->symbol (second r)) (string->symbol (first r)))2513 (values (string->symbol str-name) #f))))25142515(define (variable-from-module sym)2516 (receive (var mod) (variable-and-module sym)2517 (if mod2518 (sprintf "`~a' from module `~a'" var mod)2519 (sprintf "`~a'" var))))25202521(define (describe-expression node)2522 (define (p-expr n)2523 (sprintf (string-append "This is the expression:" "~%~%" "~a")2524 (pp-fragment n)))2525 (define (p-node n)2526 (cond ((and (eq? '##core#call (node-class n))2527 (let ((pnode (first (node-subexpressions n))))2528 (and-let* (((eq? '##core#variable (node-class pnode)))2529 (pname (car (node-parameters pnode)))2530 (ptype (variable-mark pname '##compiler#type)))2531 (sprintf (string-append2532 "It is a call to ~a which has this type:"2533 "~%~%"2534 "~a"2535 "~%~%"2536 "~a")2537 (variable-from-module pname)2538 (type->pp-string ptype)2539 (p-expr n))))))2540 ((eq? '##core#the/result (node-class n)) ; walk through2541 (p-node (first (node-subexpressions n))))2542 (else (p-expr n))))2543 (p-node (source-node-tree node)))25442545(define (call-node-procedure-name node)2546 (fragment (first (node-subexpressions node))))25472548(define (report2 short report-f location-node-candidates loc msg . args)2549 (define (file-location)2550 (any (lambda (n) (and (not (string=? "" (node-source-prefix n)))2551 (node-source-prefix n)))2552 location-node-candidates))2553 (when *complain?*2554 (report-f2555 (conc2556 short2557 (string-add-indent2558 (conc (let ((l (file-location))) (if l (conc "\n" l) "")) "\n"2559 (location-name loc "")2560 (sprintf "~?" msg args))2561 " ")))2562 (flush-output)))25632564(define (report-notice reason location-node-candidates loc msg . args)2565 (apply report2 reason ##sys#notice location-node-candidates loc msg args))25662567;;; Reports25682569(define (r-invalid-called-procedure-type loc call-node xptype p-node ptype)2570 (define (variable-node-name n)2571 (cond ((eq? '##core#the/result (node-class n))2572 (variable-node-name (first (node-subexpressions n))))2573 ((eq? '##core#variable (node-class n)) (car (node-parameters n)))2574 (else #f)))2575 (if (variable-node-name p-node)2576 (report22577 "Invalid procedure"2578 warning2579 (list p-node call-node)2580 loc2581 (string-append2582 "In procedure call:"2583 "~%~%"2584 "~a"2585 "~%~%"2586 "Variable ~a is not a procedure."2587 "~%~%"2588 "It has this type:"2589 "~%~%"2590 "~a")2591 (pp-fragment call-node)2592 (variable-from-module (variable-node-name p-node))2593 (type->pp-string ptype))2594 (report22595 "Invalid procedure"2596 warning2597 (list p-node call-node)2598 loc2599 (string-append2600 "In procedure call:"2601 "~%~%"2602 "~a"2603 "~%~%"2604 "The procedure expression does not appear to be a callable."2605 "~%~%"2606 "~a"2607 "~%~%"2608 "The expected type is:"2609 "~%~%"2610 "~a"2611 "~%~%"2612 "The actual type is:"2613 "~%~%"2614 "~a")2615 (pp-fragment call-node)2616 (describe-expression p-node)2617 (type->pp-string xptype)2618 (type->pp-string ptype))))26192620(define (r-proc-call-argument-count-mismatch loc node exp-count argc ptype)2621 (define pname (call-node-procedure-name node))2622 (report22623 "Wrong number of arguments"2624 warning2625 (list node)2626 loc2627 (string-append2628 "In procedure call:"2629 "~%~%"2630 "~a"2631 "~%~%"2632 "Procedure `~a' is called with ~a argument~a but ~a argument~a ~a expected."2633 "~%~%"2634 "Procedure ~a has this type:"2635 "~%~%"2636 "~a")2637 (pp-fragment node)2638 (strip-namespace pname)2639 argc (multiples argc)2640 exp-count (multiples exp-count)2641 (if (= exp-count 1) "is" "are")2642 (variable-from-module pname)2643 (type->pp-string ptype)))26442645(define (r-proc-call-argument-type-mismatch loc node i arg-node xptype atype ptype)2646 (define pname (call-node-procedure-name node))2647 (report22648 "Invalid argument"2649 warning2650 (list node)2651 loc2652 (string-append2653 "In procedure call:"2654 "~%~%"2655 "~a"2656 "~%~%"2657 "Argument #~a to procedure `~a' has an invalid type:"2658 "~%~%"2659 "~a"2660 "~%~%"2661 "The expected type is:"2662 "~%~%"2663 "~a"2664 "~%~%"2665 "~a"2666 "~%~%"2667 "Procedure ~a has this type:"2668 "~%~%"2669 "~a")2670 (pp-fragment node)2671 i2672 (strip-namespace pname)2673 (type->pp-string atype)2674 (type->pp-string xptype)2675 (describe-expression arg-node)2676 (variable-from-module pname)2677 (type->pp-string ptype)))26782679(define (r-proc-call-argument-value-count loc call-node i arg-node atype)2680 (define pname (call-node-procedure-name call-node))2681 (define (p short long)2682 (report22683 short2684 warning2685 (list arg-node call-node)2686 loc2687 (string-append2688 "In procedure call:"2689 "~%~%"2690 "~a"2691 "~%~%"2692 "Argument #~a to procedure~a ~a"2693 "~%~%"2694 "~a")2695 (pp-fragment call-node)2696 i2697 (if (zero? i) "" (sprintf " `~a'" (strip-namespace pname)))2698 long2699 (describe-expression arg-node)))2700 (if (zero? (length atype))2701 (p "Not enough argument values"2702 "does not return any values.")2703 (p "Too many argument values"2704 (sprintf "returns ~a values but 1 is expected." (length atype)))))27052706(define (r-index-out-of-range loc node idx obj-length obj-name)2707 ;; Negative indices should always generate a warning2708 (define pname (call-node-procedure-name node))2709 (report22710 (if (negative? idx)2711 (sprintf "Negative ~a index" obj-name)2712 (sprintf "~a~a index out of range"2713 (char-upcase (string-ref obj-name 0))2714 (substring obj-name 1)))2715 warning2716 (list node)2717 loc2718 (string-append2719 "In procedure call:"2720 "~%~%"2721 "~a"2722 "~%~%"2723 "Procedure ~a is called with ~a")2724 (pp-fragment node)2725 (variable-from-module pname)2726 (if (negative? idx)2727 (sprintf "a negative index ~a." idx)2728 (sprintf "index `~a' for a ~a of length `~a'." idx obj-name obj-length))))27292730(define (r-conditional-value-count-invalid loc if-node test-node atype)2731 (define (p short long)2732 (report2 short warning (list test-node if-node)2733 loc2734 (string-append2735 "In conditional:"2736 "~%~%"2737 "~a"2738 "~%~%"2739 "The test expression ~a"2740 "~%~%"2741 "~a")2742 (pp-fragment if-node)2743 long2744 (describe-expression test-node)))2745 (if (zero? (length atype))2746 (p "Zero values for conditional"2747 "returns 0 values.")2748 (p "Too many values for conditional"2749 (sprintf "returns ~a values." (length atype)))))27502751(define (r-let-value-count-invalid loc var let-node val-node atype)2752 (define (p short long)2753 (report2 short warning (list val-node let-node)2754 loc2755 (string-append2756 "In let expression:"2757 "~%~%"2758 "~a"2759 "~%~%"2760 "Variable `~a' is bound to an expression that ~a"2761 "~%~%"2762 "~a")2763 (pp-fragment let-node)2764 (real-name var)2765 long2766 (describe-expression val-node)))2767 (if (zero? (length atype))2768 (p (sprintf "Let binding to `~a' has zero values" (real-name var))2769 "returns 0 values.")2770 (p (sprintf "Let binding to `~a' has ~a values" (real-name var) (length atype))2771 (sprintf "returns ~a values." (length atype)))))27722773(define (r-assignment-value-count-invalid loc var set-node val-node atype)2774 (define (p short long)2775 (report2 short warning (list val-node set-node)2776 loc2777 (string-append2778 "In assignment:"2779 "~%~%"2780 "~a"2781 "~%~%"2782 "Variable `~a' is assigned from expression that ~a"2783 "~%~%"2784 "~a")2785 (pp-fragment set-node)2786 (strip-namespace var)2787 long2788 (describe-expression val-node)))2789 (if (zero? (length atype))2790 (p (sprintf "Assignment to `~a' has zero values" (strip-namespace var))2791 "returns 0 values.")2792 (p (sprintf "Assignment to `~a' has ~a values" (strip-namespace var) (length atype))2793 (sprintf "returns ~a values." (length atype)))))27942795(define (r-pred-call-always-true loc node pred-type atype)2796 (define pname (call-node-procedure-name node))2797 (report-notice2798 "Predicate is always true"2799 (list node)2800 loc2801 (string-append2802 "In procedure call:"2803 "~%~%"2804 "~a"2805 "~%~%"2806 "The predicate will always return true."2807 "~%~%"2808 "Procedure ~a is a predicate for:"2809 "~%~%"2810 "~a"2811 "~%~%"2812 "The given argument has this type:"2813 "~%~%"2814 "~a")2815 (pp-fragment node)2816 (variable-from-module pname)2817 (type->pp-string pred-type)2818 (type->pp-string atype)))28192820(define (r-pred-call-always-false loc node pred-type atype)2821 (define pname (call-node-procedure-name node))2822 (report-notice2823 "Predicate is always false"2824 (list node)2825 loc2826 (string-append2827 "In procedure call:"2828 "~%~%"2829 "~a"2830 "~%~%"2831 "The predicate will always return false."2832 "~%~%"2833 "Procedure ~a is a predicate for:"2834 "~%~%"2835 "~a"2836 "~%~%"2837 "The given argument has this type:"2838 "~%~%"2839 "~a")2840 (pp-fragment node)2841 (variable-from-module pname)2842 (type->pp-string pred-type)2843 (type->pp-string atype)))28442845(define (r-cond-test-always-true loc if-node test-node t)2846 (report-notice2847 "Test is always true"2848 (list test-node if-node)2849 loc2850 (string-append2851 "In conditional expression:"2852 "~%~%"2853 "~a"2854 "~%~%"2855 "Test condition has always true value of type:"2856 "~%~%"2857 "~a")2858 (pp-fragment if-node)2859 (type->pp-string t)))28602861(define (r-cond-test-always-false loc if-node test-node)2862 (report-notice2863 "Test is always false"2864 (list test-node if-node)2865 loc2866 (string-append2867 "In conditional expression:"2868 "~%~%"2869 "~a"2870 "~%~%"2871 "Test condition is always false.")2872 (pp-fragment if-node)))28732874(define (r-zero-values-for-the loc node the-type)2875 ;; (the t r) expects r returns exactly 1 value2876 (report22877 "Not enough values"2878 warning2879 (list node)2880 loc2881 (string-append2882 "In expression:"2883 "~%~%"2884 "~a"2885 "~%~%"2886 "Expression returns 0 values but is declared to return:"2887 "~%~%"2888 "~a")2889 (pp-fragment node)2890 (type->pp-string the-type)))28912892(define (r-too-many-values-for-the loc node the-type rtypes)2893 (report22894 "Too many values"2895 warning2896 (list node)2897 loc2898 (string-append2899 "In expression:"2900 "~%~%"2901 "~a"2902 "~%~%"2903 "Expression returns too many values."2904 "~%~%"2905 "The expression returns ~a values but is declared to return:"2906 "~%~%"2907 "~a")2908 (pp-fragment node)2909 (length rtypes)2910 (type->pp-string the-type)))29112912(define (r-type-mismatch-in-the loc node atype the-type)2913 (report22914 "Type mismatch"2915 warning2916 (list node)2917 loc2918 (string-append2919 "In expression:"2920 "~%~%"2921 "~a"2922 "~%~%"2923 "Expression's declared and actual types do not match."2924 "~%~%"2925 "The declared type is:"2926 "~%~%"2927 "~a"2928 "~%~%"2929 "The actual type is:"2930 "~%~%"2931 "~a")2932 (pp-fragment node)2933 (type->pp-string the-type)2934 (type->pp-string atype)))29352936(define (fail-compiler-typecase loc node atype ct-types)2937 (define (pp-type t) (string-add-indent (type->pp-string t) " "))2938 (quit-compiling2939 (string-append2940 "No typecase match"2941 "~%"2942 "~a"2943 "~a"2944 "In `compiler-typecase' expression:"2945 "~%~%"2946 " ~a"2947 "~%~%"2948 " Tested expression does not match any case."2949 "~%~%"2950 " The expression has this type:"2951 "~%~%"2952 "~a"2953 "~%~%"2954 " The specified type cases are these:"2955 "~%~%"2956 "~a")2957 (if (string=? "" (node-source-prefix node))2958 "\n"2959 (conc " " (node-source-prefix node) "\n "))2960 (location-name loc)2961 (pp-fragment node)2962 (pp-type atype)2963 (string-intersperse (map pp-type ct-types) "\n\n")))29642965(define (r-cond-branch-value-count-mismatch loc node c-node a-node c-types a-types)2966 (report22967 "Branch values mismatch"2968 warning2969 (list a-node node)2970 loc2971 (string-append2972 "In conditional expression:"2973 "~%~%"2974 "~a"2975 "~%~%"2976 "The branches have different numbers of values."2977 "~%~%"2978 "The true branch returns ~a value~a:"2979 "~%~%"2980 "~a"2981 "~%~%"2982 "The false branch returns ~a value~a:"2983 "~%~%"2984 "~a")2985 (pp-fragment node)2986 (length c-types) (multiples (length c-types))2987 (pp-fragment c-node)2988 (length a-types) (multiples (length a-types))2989 (pp-fragment a-node)))29902991(define (r-toplevel-var-assignment-type-mismatch loc node atype var xptype value-node)2992 (report22993 "Invalid assignment"2994 warning2995 (list node value-node)2996 loc2997 (string-append2998 "In assignment:"2999 "~%~%"3000 "~a"3001 "~%~%"3002 "Variable `~a' is assigned invalid value."3003 "~%~%"3004 "The assigned value has this type:"3005 "~%~%"3006 "~a"3007 "~%~%"3008 "The declared type of ~a is:"3009 "~%~%"3010 "~a")3011 (pp-fragment node)3012 (strip-namespace var)3013 (type->pp-string atype)3014 (variable-from-module3015 (let ((n (real-name var)))3016 (if (symbol? n) n (string->symbol n))))3017 (type->pp-string xptype)))30183019(define (r-deprecated-identifier loc node id #!optional suggestion)3020 (report23021 (sprintf "Deprecated identifier `~a'" (strip-namespace id))3022 warning3023 (list node)3024 loc3025 (string-append3026 "In expression:"3027 "~%~%"3028 "~a"3029 "~%~%"3030 "Use of deprecated identifier ~a."3031 "~a")3032 (pp-fragment node) ;; TODO: parent node would be nice here3033 (variable-from-module id)3034 (if suggestion3035 (sprintf "~%~%The suggested alternative is ~a."3036 (variable-from-module suggestion))3037 "")))3038)