~ chicken-core (chicken-5) /scrutinizer.scm

   1;;;; scrutinizer.scm - The CHICKEN Scheme compiler (local flow analysis)
   2;
   3; Copyright (c) 2009-2022, The CHICKEN Team
   4; All rights reserved.
   5;
   6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
   7; conditions are met:
   8;
   9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
  10;     disclaimer. 
  11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
  12;     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 promote
  14;     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 EXPRESS
  17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
  19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  24; POSSIBILITY OF SUCH DAMAGE.
  25
  26
  27(declare
  28  (unit scrutinizer)
  29  (uses data-structures expand extras pathname port support internal))
  30
  31(module chicken.compiler.scrutinizer
  32    (scrutinize load-type-database emit-types-file
  33     validate-type check-and-validate-type install-specializations
  34     ;; Exported for use in the tests:
  35     match-types refine-types type<=?)
  36
  37(import scheme
  38	chicken.base
  39	chicken.compiler.support
  40	chicken.fixnum
  41	chicken.format
  42	chicken.internal
  43	chicken.io
  44	chicken.keyword
  45	chicken.pathname
  46	chicken.platform
  47	chicken.plist
  48	chicken.sort
  49	chicken.port
  50	chicken.pretty-print
  51	chicken.string
  52	chicken.syntax)
  53
  54(include "tweaks")
  55(include "mini-srfi-1.scm")
  56
  57(define d-depth 0)
  58(define scrutiny-debug #t)
  59(define *complain?* #f)
  60
  61(define (d fstr . args)
  62  (when (and scrutiny-debug (##sys#debug-mode?))
  63    (printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) )
  64
  65(define dd d)
  66(define ddd d)
  67
  68(define-syntax d (syntax-rules () ((_ . _) (void))))
  69(define-syntax dd (syntax-rules () ((_ . _) (void))))
  70(define-syntax ddd (syntax-rules () ((_ . _) (void))))
  71
  72
  73;;; Walk node tree, keeping type and binding information
  74;
  75; result specifiers:
  76;
  77;   SPEC = * | (TYPE1 ...)
  78;   TYPE = (or TYPE1 TYPE2 ...)
  79;        | (not TYPE)
  80;        | (struct NAME)
  81;        | (procedure [NAME] (TYPE1 ... [#!optional TYPE1 ...] [#!rest [TYPE | values]]) . RESULTS)
  82;        | VALUE
  83;        | BASIC
  84;        | COMPLEX
  85;        | (forall (TVAR1 ...) TYPE)
  86;        | (refine (SYMBOL ...) VALUE)
  87;        | deprecated
  88;        | (deprecated NAME)
  89;   VALUE = string | symbol | keyword | char | number |
  90;           boolean | true | false |
  91;           null | eof | bwp | blob |  pointer | port | locative | fixnum |
  92;           float | bignum | ratnum | cplxnum | integer | pointer-vector
  93;   BASIC = * | list | pair | procedure | vector | undefined | noreturn | values
  94;   COMPLEX = (pair TYPE TYPE)
  95;           | (vector-of TYPE)
  96;           | (list-of TYPE)
  97;           | (vector TYPE1 ...)
  98;           | (list TYPE1 ...)
  99;   RESULTS = *
 100;           | (TYPE1 ...)
 101;   TVAR = (VAR TYPE) | VAR
 102;
 103; global symbol properties:
 104;
 105;   ##compiler#type            ->  TYPESPEC
 106;   ##compiler#type-source     ->  'db | 'local | 'inference
 107;   ##compiler#predicate       ->  TYPESPEC
 108;   ##compiler#specializations ->  (SPECIALIZATION ...)
 109;   ##compiler#local-specializations ->  (SPECIALIZATION ...)
 110;   ##compiler#enforce         ->  BOOL
 111;   ##compiler#special-result-type -> PROCEDURE
 112;   ##compiler#escape          ->  #f | 'yes | 'no
 113;   ##compiler#type-abbreviation -> TYPESPEC
 114;;  ##compiler#tv-root         ->  STRING
 115;
 116; specialization specifiers:
 117;
 118;   SPECIALIZATION = ((TYPE ... [#!rest TYPE]) [RESULTS] TEMPLATE)
 119;   TEMPLATE = #(INDEX)
 120;            | #(INDEX ...)
 121;            | #(SYMBOL)
 122;            | INTEGER | SYMBOL | STRING
 123;            | (quote CONSTANT)
 124;            | (TEMPLATE . TEMPLATE)
 125;
 126; As an alternative to the "#!rest" and "#!optional" keywords, "&rest" or "&optional"
 127; may be used.
 128
 129
 130(define-constant +fragment-max-length+ 6)
 131(define-constant +fragment-max-depth+ 4)
 132(define-constant +maximal-union-type-length+ 20)
 133(define-constant +maximal-complex-object-constructor-result-type-length+ 256)
 134
 135(define-constant value-types
 136  '(string symbol keyword char null boolean true false blob eof bwp
 137    fixnum float number integer bignum ratnum cplxnum
 138    pointer-vector port pointer locative))
 139
 140(define-constant basic-types
 141  '(* list pair procedure vector undefined deprecated noreturn values))
 142
 143(define-constant struct-types
 144  '(u8vector s8vector u16vector s16vector u32vector s32vector u64vector
 145    s64vector f32vector f64vector thread queue environment time
 146    continuation lock mmap condition hash-table tcp-listener))
 147
 148(define-constant type-expansions
 149  '((pair . (pair * *))
 150    (list . (list-of *))
 151    (vector . (vector-of *))
 152    (boolean . (or true false))
 153    (integer . (or fixnum bignum))
 154    (number . (or fixnum float bignum ratnum cplxnum))
 155    (procedure . (procedure (#!rest *) . *))))
 156
 157(define-inline (struct-type? t)
 158  (and (pair? t) (eq? (car t) 'struct)))
 159
 160(define-inline (value-type? t)
 161  (or (struct-type? t) (memq t value-types)))
 162
 163(define specialization-statistics '())
 164(define trail '())
 165
 166(define (walked-result n)
 167  (first (node-parameters n)))		; assumes ##core#the/result node
 168
 169(define (type-always-immediate? t)
 170  (cond ((pair? t)
 171	 (case (car t)
 172	   ((or) (every type-always-immediate? (cdr t)))
 173	   ((forall) (type-always-immediate? (third t)))
 174	   (else #f)))
 175	((memq t '(eof bwp null fixnum char boolean undefined)) #t)
 176	(else #f)))
 177
 178(define (scrutinize node db complain specialize strict block-compilation)
 179  (d "################################## SCRUTINIZE ##################################")
 180  (define (report loc msg . args)
 181    (when *complain?*
 182      (warning
 183       (conc (location-name loc)
 184	     (sprintf "~?" msg args)))))
 185
 186  (set! *complain?* complain)
 187
 188  (let ((blist '())			; (((VAR . FLOW) TYPE) ...)
 189	(aliased '())
 190	(noreturn #f)
 191	(dropped-branches 0)
 192	(assigned-immediates 0)
 193	(errors #f)
 194	(safe-calls 0))
 195
 196    (define (constant-result lit)
 197      (cond ((string? lit) 'string)
 198	    ((keyword? lit) 'keyword)
 199	    ((symbol? lit) 'symbol)
 200	    ;; Do not assume fixnum width matches target platforms!
 201	    ((or (big-fixnum? lit) (small-bignum? lit)) 'integer)
 202	    ((fixnum? lit) 'fixnum)
 203	    ((bignum? lit) 'bignum)
 204	    ((flonum? lit) 'float)	; Why not "flonum", for consistency?
 205	    ((ratnum? lit) 'ratnum)
 206	    ((cplxnum? lit) 'cplxnum)
 207	    ((boolean? lit)
 208	     (if lit 'true 'false))
 209	    ((null? lit) 'null)
 210	    ((list? lit) 
 211	     `(list ,@(map constant-result lit)))
 212	    ((pair? lit)
 213	     (simplify-type
 214	      `(pair ,(constant-result (car lit)) ,(constant-result (cdr lit)))))
 215	    ((eof-object? lit) 'eof)
 216	    ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
 217	    ((##core#inline "C_bwpp" lit) #;(bwp-object? lit) 'bwp)
 218	    ((vector? lit) 
 219	     (simplify-type
 220	      `(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 '*)))
 225
 226    (define (global-result id loc node)
 227      (cond ((variable-mark id '##compiler#type) =>
 228	     (lambda (a)
 229	       (cond
 230		((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 '(*))))
 238
 239    (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)))
 246
 247    (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		      #;(report
 257		       loc
 258		       "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))))
 263
 264    (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)))
 273
 274    (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))
 278
 279    (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))
 283
 284    (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		  (else
 293		   (r-value-count-mismatch tv)
 294		   (first tv))))))
 295
 296    (define add-loc cons)
 297
 298    (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)))
 303
 304    (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-type
 315		loc node (resolve xptype typeenv) (car args) (resolve ptype typeenv))
 316	       (values '* #f))
 317	      (else
 318	       (let-values (((atypes values-rest ok alen)
 319			     (procedure-argument-types ptype nargs typeenv)))
 320		 (unless ok
 321		   (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-types 
 328			    (car atypes)
 329			    (car actualtypes)
 330			    typeenv)
 331		     (r-proc-call-argument-type-mismatch
 332		      loc node i
 333		      (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 pn
 343		       (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-true
 348					     loc node pt (cadr actualtypes))
 349					    (when specialize
 350					      (specialize-node!
 351					       node (cdr args)
 352					       `(let ((#(tmp) #(1))) '#t))
 353					      (set! r '(true))
 354					      (set! op (list pn pt))))
 355					   ((begin
 356					      (trail-restore trail0 typeenv)
 357					      (match-argument-types (list `(not ,pt)) (cdr actualtypes) typeenv))
 358					    (r-pred-call-always-false
 359					     loc node pt (cadr actualtypes))
 360					    (when specialize
 361					      (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 again
 372			     	   (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 (append
 381						      (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 r2
 389								    (third spec)
 390								    (second spec))))
 391						  (specialize-node! node (cdr args) rewrite)
 392						  (when r2 (set! r r2))))
 393					       (else
 394						(trail-restore trail0 tenv2)
 395						(loop (cdr specs))))))))))
 396		       (when op
 397			 (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			       (else
 401				(set! specialization-statistics
 402				  (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))))))))
 411
 412    (define tag
 413      (let ((n 0))
 414	(lambda () 
 415	  (set! n (add1 n))
 416	  n)))
 417
 418    (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 a
 423	    (d "  applying to alias: ~a -> ~a" (cdr a) type)
 424	    (loop (cdr a))))))
 425
 426    (define (initial-argument-types dest vars argc)
 427      (if (and dest strict
 428	       (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 '*)))
 436
 437    (define (walk n e loc dest flow ctags) ; returns result specifier
 438      (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 ((results
 447	       (case class
 448		 ((##core#the/result) (list (first params))) ; already walked
 449		 ((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		      (cond
 468			((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			(else
 477			 (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 for
 484			     ;; 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-each
 489				 (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					 (else
 504					  (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 bindings
 511		  (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-list
 526		   (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 dest 
 536			 (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 specialize
 546				      dest
 547				      (variable-mark dest '##compiler#type-source)
 548				      (not unsafe))
 549			     (debugging 'x "checks argument-types" dest) ;XXX
 550			     ;; [1] this is subtle: we don't want argtype-checks to be 
 551			     ;; generated for toplevel defs other than user-declared ones. 
 552			     ;; But since the ##compiler#type-source mark is set AFTER
 553			     ;; the lambda has been walked (see below, [2]), nothing is added.
 554			     (generate-type-checks! n dest vars inits))
 555			   (list
 556			    (append
 557			     '(procedure) 
 558			     namelst
 559			     (list
 560			      (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					 (cons
 567					  (cond ((eq? (cdr a) '*) '*)
 568						(else
 569						 (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				      (else 
 574				       (cons 
 575					(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-invalid
 583					  loc var n (first subs) <>)))
 584			 (typeenv (append 
 585				   (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 this
 596			       (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 enforcing
 612			      (mark-variable var '##compiler#type-source 'inference)
 613			      (mark-variable var '##compiler#type rt))))))
 614		    (when b
 615		      (cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
 616			    #;(strict
 617			     (let ((ot (or (blist-type var flow) (cdr b))))
 618			       ;;XXX compiler-syntax for "map" will introduce
 619			       ;;    assignments that trigger this warning, so this
 620			       ;;    is currently disabled
 621			       (unless (compatible-types? ot rt)
 622				 (report
 623				  loc
 624				  "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				   rt 
 628				   '*))
 629			    (fl (car flow)))
 630			;; For each outer flow F, change the var's
 631			;; type to (or t <old-type@F>). Add a new
 632			;; 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_1
 638			;;     (if foo
 639			;;         (set! y 'a)) ; y : symbol   @ flow f_2
 640			;;     y)               ; (1)          @ flow f_1
 641			;;
 642			;; At point (1) the type of y can be inferred
 643			;; to be (or fixnum symbol). The type of x
 644			;; 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?))))))
 659
 660		    (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)))
 664
 665		    '(undefined)))
 666		 ((##core#primitive) '*)
 667		 ((##core#call)
 668		  (let* ((f (fragment n))
 669			 (len (length subs))
 670			 (args (map (lambda (n2 i)
 671				      (make-node
 672				       '##core#the/result
 673				       (list
 674					(single
 675					 (walk n2 e loc #f flow #f)
 676					 (cut r-proc-call-argument-value-count loc n i n2 <>)))
 677				       (list n2)))
 678				    subs
 679				    (iota len)))
 680			 (fn (walked-result (car args)))
 681			 (pn (procedure-name fn))
 682			 (typeenv (type-typeenv
 683				   `(or ,@(map walked-result args)))) ; hack
 684			 (enforces
 685			  (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				       (and
 693					(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 stuff
 701			     ;; like "##core#inline", etc.
 702			     (if (eq? '* r)
 703				 r
 704				 (map (cut resolve <> typeenv) r)))
 705			    ((eq? 'quote (node-class n)) ; Call got constant folded
 706			     (walk n e loc dest flow ctags))
 707			    (else
 708			     (for-each
 709			      (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 pt
 716						    ctags
 717						    (not (db-get db var 'assigned)) 
 718						    (not oparg?))))
 719				    (cond (pred
 720					   ;;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-blist
 726					      var (car ctags)
 727					      (if (not a) pt (refine-types a pt)))
 728					     ;; if the variable type is an "or"-type, we can
 729					     ;; can remove all elements that match the predicate
 730					     ;; type
 731					     (when a
 732					       ;;XXX hack, again:
 733					       (let ((at (refine-types a `(not ,pt))))
 734						 (when at
 735						   (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					  (a
 739					   (when enforces
 740					     (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 ctags
 747						 (add-to-blist var (car ctags) ar)
 748						 (add-to-blist var (cdr ctags) ar)))))
 749					  ((and oparg?
 750						(variable-mark 
 751						 var
 752						 '##compiler#special-result-type))
 753					   => (lambda (srt)
 754						(dd "  hardcoded special result-type: ~a" var)
 755						(set! r (srt n args loc r))))))))
 756			      subs
 757			      (cons 
 758			       fn
 759			       (nth-value 
 760				0 
 761				(procedure-argument-types fn (sub1 len) typeenv))))
 762			     (smash)
 763			     (if (eq? '* r)
 764				 r
 765				 (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			  (else
 772			   (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 1
 784		    (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 exp
 790				  (mutate-node! n (car subs))
 791				  (walk n e loc dest flow ctags))
 792				(begin
 793				  (trail-restore trail0 typeenv)
 794				  (loop (cdr types) (cdr subs)))))))))
 795		 ((##core#switch ##core#cond)
 796		  (bomb "scrutinize: unexpected node class" class))
 797		 (else
 798		  (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)))
 803
 804    (let ((rn (walk (first (node-subexpressions node)) '() '() #f (list (tag)) #f)))
 805      (when (pair? specialization-statistics)
 806	(with-debugging-output
 807	 '(o e)
 808	 (lambda ()
 809	   (print "specializations:")
 810	   (for-each 
 811	    (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 errors
 822	(quit-compiling "some variable types do not satisfy strictness"))
 823      rn)))
 824      
 825
 826;;; replace pair/vector types with components to variants with undetermined
 827;;  component types (used for env or blist); also convert "list[-of]" types
 828;;  into "pair", since mutation may take place
 829
 830(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) <>))))))))
 858
 859
 860;;; blist (binding list) helpers
 861;;
 862;; - Entries (ble) in blist have type ((symbol . fixnum) . type)
 863
 864(define ble-id caar)		; variable name : symbol
 865(define ble-tag cdar)		; block tag     : fixnum
 866(define ble-type cdr)		; variable type : valid type sexp
 867(define ble-type-set! set-cdr!)
 868
 869
 870;;; Type-matching
 871;
 872; - "all" means: all elements in `or'-types in second argument must match
 873
 874(define (match-types t1 t2 #!optional (typeenv (type-typeenv `(or ,t1 ,t2))) all)
 875
 876  (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 opt2
 881		 (null? args2)
 882		 (optargs? (car args2))))
 883	    ((null? args2) 
 884	     (or opt1
 885		 (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))))
 897
 898  (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 (every			
 901	    (lambda (t)
 902	      (or (eq? '#!optional t)
 903		  (match1 rtype t)))
 904	    head)
 905	   (match1 rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
 906
 907  (define (optargs? a)
 908    (memq a '(#!rest #!optional)))
 909
 910  (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)))
 920
 921  (define (rawmatch1 t1 t2)
 922    (fluid-let ((all #f))
 923      (match1 t1 t2)))
 924
 925  (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))))
 930
 931  (define (match1 t1 t2)
 932    ;; note: the order of determining the type is important
 933    (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)) ; constraint
 941			     (rawmatch1 (third e) t2))))
 942		   ;; special case for two unbound typevars
 943		   ((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)) ; constraint
 951				   (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)) ; constraint
 964			     (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 t1
 995	  ((and (pair? t2) (eq? 'or (car t2)))
 996	   (over-all-instantiations
 997	    (cdr t2)
 998	    typeenv
 999	    all
 1000	    (lambda (t) (match1 t1 t))))
1001	  ;; s.a.
1002	  ((and (pair? t1) (eq? 'or (car t1))) 
1003	   (over-all-instantiations
1004	    (cdr t1)
1005	    typeenv
1006	    #f
1007	    (lambda (t) (match1 t t2)))) ; o-a-i ensures at least one element matches
1008	  ((and (pair? t1) (eq? 'forall (car t1)))
1009	   (match1 (third t1) t2)) ; assumes typeenv has already been extracted
1010	  ((and (pair? t2) (eq? 'forall (car t2)))
1011	   (match1 t1 (third t2))) ; assumes typeenv has already been extracted
1012	  ((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				    'null
1059				    `(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				    'null
1073				    `(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-instantiations
1080		 (cdr t1)
1081		 typeenv
1082		 #t
1083		 (cute match1 <> (second t2)))))
1084	  ((and (pair? t1) (eq? 'list-of (car t1)))
1085	   (and (pair? t2) (eq? 'list (car t2))
1086		(over-all-instantiations
1087		 (cdr t2)
1088		 typeenv
1089		 #t
1090		 (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-instantiations
1095		 (cdr t1)
1096		 typeenv
1097		 #t
1098		 (cute match1 <> (second t2)))))
1099	  ((and (pair? t1) (eq? 'vector-of (car t1)))
1100	   (and (pair? t2) (eq? 'vector (car t2))
1101		(over-all-instantiations
1102		 (cdr t2)
1103		 typeenv
1104		 #t
1105		 (cute match1 (second t1) <>))))
1106	  (else #f)))
1107
1108  (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))
1112
1113
1114(define (match-argument-types typelist atypes typeenv)
1115  ;; this doesn't need optional: it is only used for predicate- and specialization
1116  ;; matching
1117  (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	   (every 
1123	    (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))))
1129
1130
1131;;; Simplify type specifier
1132;
1133; - coalesces "forall" and renames type-variables
1134; - also removes unused typevars
1135
1136(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/cc 
1143       (lambda (return)
1144	 (cond ((pair? t)
1145		(case (car t)
1146		  ((forall)
1147		   (let ((typevars (second t)))
1148		     (set! typeenv
1149		       (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! constraints 
1155		       (append (filter-map 
1156				(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				'procedure
1171				(foldl
1172				 (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				     (append
1180				      '(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			   (else
1190			    (let* ((ts (append-map
1191					(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				      t
1209				      (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			   (else
1217			    (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			 'pair
1223			 (canonicalize-list-type
1224			  `(pair ,tcar ,tcdr)))))
1225		  ((vector-of)
1226		   (let ((t2 (simplify (second t))))
1227		     (if (eq? t2 '*)
1228			 'vector
1229			 `(,(car t) ,t2))))
1230		  ((list-of)
1231		   (let ((t2 (simplify (second t))))
1232		     (if (eq? t2 '*)
1233			 'list
1234			 `(,(car t) ,t2))))
1235		  ((list)
1236		   (if (null? (cdr t))
1237		       'null
1238		       `(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		     (append
1245		      '(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! t2 
1260	  `(forall ,(filter-map
1261		     (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)))
1272
1273(define (maybe-expand-type t)
1274  (and (symbol? t)
1275       (alist-ref t type-expansions eq?)))
1276
1277;;; Merging types
1278
1279(define (merge-argument-types ts1 ts2) 
1280  ;; this could be more elegantly done by combining non-matching arguments/llists
1281  ;; into "(or (procedure ...) (procedure ...))" and then simplifying
1282  (cond ((null? ts1) 
1283	 (cond ((null? ts2) '())
1284	       ((memq (car ts2) '(#!rest #!optional)) ts2)
1285	       (else '(#!rest))))
1286	((null? ts2) '(#!rest))		;XXX giving up
1287	((eq? '#!rest (car ts1))
1288	 (cond ((and (pair? ts2) (eq? '#!rest (car ts2)))
1289		`(#!rest
1290		  ,(simplify-type
1291		    `(or ,(rest-type (cdr ts1))
1292			 ,(rest-type (cdr ts2))))))
1293	       (else '(#!rest))))	;XXX giving up
1294	((eq? '#!optional (car ts1))
1295	 (cond ((and (pair? ts2) (eq? '#!optional (car ts2)))
1296		`(#!optional 
1297		  ,(simplify-type `(or ,(cadr ts1) ,(cadr ts2)))
1298		  ,@(merge-argument-types (cddr ts1) (cddr ts2))))
1299	       (else '(#!rest))))	;XXX
1300	((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))))))
1304
1305(define (merge-result-types ts11 ts21) ;XXX possibly overly conservative
1306  (call/cc
1307   (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)))))))))
1313
1314
1315(define (compatible-types? t1 t2 #!optional (te (type-typeenv `(or ,t1 ,t2))))
1316  (or (type<=? t1 t2 te)
1317      (type<=? t2 t1 te)))
1318
1319(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)))
1323
1324(define (type<=? t1 t2 #!optional (te (type-typeenv `(or ,t1 ,t2))))
1325  (with-trail-restore
1326   te
1327   (lambda ()
1328     (match-types t2 t1 te #t))))
1329
1330;;
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;;
1335
1336(define (refine-types t1 t2)
1337
1338  (define (refine t1 t2 te)
1339    (let loop ((t1 t1) (t2 t2))
1340      (cond
1341       ((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	(else
1365	 (type-min t1 t2 te)))))
1366
1367  (let* ((te (type-typeenv `(or ,t1 ,t2)))
1368	 (rt (or (refine t1 t2 te) t2)))
1369    (if (eq? rt t2)
1370	rt
1371	(simplify-type rt))))
1372
1373;;; various operations on procedure types
1374
1375(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)))))
1383
1384(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))))
1394
1395(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)))))
1405
1406(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)))))
1416
1417(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		  (llist
1425		   ;; quite a mess
1426		   (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 norest
1436				'()
1437				(loop (cdr at) m #t) ))
1438			   ((eq? '#!rest (car at))
1439			    (cond (norest '())
1440				  (else
1441				   (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))
1442				   (make-list m (rest-type (cdr at))))))
1443			   ((and opt (<= m 0)) '())
1444			   (else
1445			    (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 extracted
1451	  ((assq t typeenv) =>
1452	   (lambda (e)
1453	     (let ((t2 (second e)))
1454	       (if (and t2 (memq t2 done))
1455		   (loop1 '* done)		; circularity
1456		   (loop1 t2 (cons t done))))))
1457	  (else (values (make-list n '*) #f #t n)))))
1458
1459(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/cc
1465	    (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 extracted
1474	  (else '*)))
1475  (loop1 t))
1476
1477(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))))
1484
1485(define (rest-type r)
1486  (cond ((null? r) '*)
1487	((eq? 'values (car r)) '*)
1488	(else (car r))))
1489
1490(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))))
1502
1503(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)))))
1510
1511;;; Refinement type helpers
1512
1513(define (refinement-type? t)
1514  (and (pair? t)
1515       (case (first t)
1516	 ((refine) #t)
1517	 ((forall) (refinement-type? (third t)))
1518	 (else #f))))
1519
1520;;; Type-environments and -variables
1521
1522(define (make-tv sym)
1523  (let* ((r (get sym '##core#tv-root))
1524	 ;; ##core#tv-root is a string to make this gensym fast
1525	 (new (gensym r)))
1526    (put! new '##core#tv-root r)
1527    new))
1528
1529(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		 (else
1542		  (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))
1556
1557(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))))
1562
1563(define (with-trail-restore typeenv thunk)
1564  (let* ((trail0 trail)
1565	 (result (thunk)))
1566    (trail-restore trail0 typeenv)
1567    result))
1568
1569(define (resolve t typeenv)
1570  (simplify-type			;XXX do only when necessary
1571   (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 reference
1578		    (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		t
1585		(bomb "resolve: can't resolve unknown type-variable" t)))
1586	   (else 
1587	    (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		 `(procedure
1599		   ,@(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				 args
1605				 (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)))))))
1613
1614
1615;;; type-db processing
1616
1617(define (load-type-database name specialize #!optional
1618                            (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-each
1625       (lambda (e)
1626	 (let* ((name (car e))
1627		(old (variable-mark name '##compiler#type))
1628		(specs (and (pair? (cddr e)) (cddr e)))
1629		(new
1630		 (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				    (else
1653				     (bomb
1654				      "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 considered
1662	   ;; correct, because type variables have to be renamed:
1663	   (let-values (((t pred pure) (validate-type new name)))
1664	     (unless t
1665	       (warning
1666		(sprintf "Invalid type specification for `~a':~%~%~a"
1667			 name
1668			 (type->pp-string new))))
1669	     (when (and old (not (compatible-types? old t)))
1670	       (warning
1671		(sprintf
1672		 (string-append
1673		  "Declared type for toplevel binding `~a'"
1674		  "~%~%~a~%~%"
1675		  "  conflicts with previously loaded type:"
1676		  "~%~%~a")
1677		 name
1678		 (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 specs
1683	       (install-specializations name specs)))))
1684       (call-with-input-file dbfile read-expressions))
1685      #t)))
1686
1687(define (hash-table->list ht)
1688  (let ((len (vector-length ht)))
1689    (let loop1 ((i 0) (lst '()))
1690      (if (>= i len)
1691          lst
1692          (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))))))))
1698
1699(define (symbol<? s1 s2)
1700  (string<? (symbol->string s1)
1701            (symbol->string s2)))
1702
1703(define (emit-types-file source-file types-file db block-compilation)
1704  (with-output-to-file types-file
1705    (lambda ()
1706      (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
1707	     source-file "\n")
1708      (for-each
1709       (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* sym
1722                          (let wrap ((type type))
1723                            (if (pair? type)
1724                                (case (car type)
1725                                  ((procedure)
1726                                   `(#(procedure
1727                                                 ,@(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"))))
1742
1743;;
1744;; Source node tracking
1745;;
1746;; Nodes are mutated in place during specialization, which may lose line
1747;; number information if, for example, a node is changed from a
1748;; ##core#call to a class without debug info. To preserve line numbers
1749;; and allow us to print fragments of the original source, we maintain a
1750;; side table of mappings from mutated nodes to copies of the originals.
1751;;
1752
1753(define node-mutations '())
1754
1755(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))
1758
1759(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))))
1762
1763(define (source-node-tree n)
1764  (source-node
1765   n
1766   (lambda (n*)
1767     (make-node (node-class n*)
1768		(node-parameters n*)
1769		(map source-node-tree (node-subexpressions n*))))))
1770
1771(define (node-line-number n)
1772  (node-debug-info (source-node n)))
1773
1774(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)))
1784
1785;; Mutate node for specialization
1786
1787(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			    (else
1800			     (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 constants
1810	    (else (cons (subst (car x)) (subst (cdr x))))))
1811    (mutate-node! node (subst template))))
1812
1813
1814;;; Type-validation and -normalization
1815
1816(define (validate-type type name)
1817  ;; - returns converted type or #f
1818  ;; - also converts "(... -> ...)" types
1819  ;; - converts some typenames to struct types (u32vector, etc.)
1820  ;; - handles some type aliases
1821  ;; - drops "#!key ..." args by converting to #!rest
1822  ;; - replaces uses of "&rest"/"&optional" with "#!rest"/"#!optional"
1823  ;; - handles "(T1 -> T2 : T3)" (predicate) 
1824  ;; - handles "(T1 --> T2 [: T3])" (clean)
1825  ;; - simplifies result
1826  ;; - coalesces all "forall" forms into one (remove "forall" if typevar-set is empty)
1827  ;; - renames type-variables
1828  ;; - replaces type-abbreviations
1829  (let ((ptype #f)			; (T . PT) | #f
1830	(clean #f)
1831	(typevars '())
1832	(constraints '()))
1833    (define (upto lst p)
1834      (let loop ((lst lst))
1835	(cond ((eq? lst p) '())
1836	      (else (cons (car lst) (loop (cdr lst)))))))
1837    (define (memq* x lst) ; memq, but allow improper list
1838      (let loop ((lst lst))
1839	(cond ((not (pair? lst)) #f)
1840	      ((eq? (car lst) x) lst)
1841	      (else (loop (cdr lst))))))
1842    (define (validate-llist llist)
1843      (cond ((null? llist) '())
1844	    ((symbol? llist) '(#!rest *))
1845	    ((not (pair? llist)) #f)
1846	    ((or (eq? '#!optional (car llist))
1847		 (eq? '&optional (car llist)))
1848	     (let ((l1 (validate-llist (cdr llist))))
1849	       (and l1 (cons '#!optional l1))))
1850	    ((or (eq? '#!rest (car llist))
1851		 (eq? '&rest (car llist)))
1852	     (cond ((null? (cdr llist)) '(#!rest *))
1853		   ((not (pair? (cdr llist))) #f)
1854		   (else
1855		    (let ((l1 (validate (cadr llist))))
1856		      (and l1 `(#!rest ,l1))))))
1857	    ((eq? '#!key (car llist)) '(#!rest *))
1858	    (else
1859	     (let* ((l1 (validate (car llist)))
1860		    (l2 (validate-llist (cdr llist))))
1861	       (and l1 l2 (cons l1 l2))))))
1862    (define (validate t #!optional (rec #t))
1863      (cond ((memq t value-types) t)
1864	    ((memq t basic-types) t)
1865	    ((memq t struct-types) `(struct ,t))
1866	    ((eq? t 'immediate) '(or eof null fixnum char boolean))
1867	    ((eq? t 'any) '*)
1868	    ((eq? t 'void) 'undefined)
1869	    ((eq? t 'input-port) '(refine (input) port))
1870	    ((eq? t 'output-port) '(refine (output) port))
1871	    ((and (symbol? t) (##sys#get t '##compiler#type-abbreviation)))
1872	    ((not (pair? t)) 
1873	     (cond ((memq t typevars) t)
1874		   (else #f)))
1875	    ((eq? 'not (car t))
1876	     (and (= 2 (length t))
1877		  `(not ,(validate (second t)))))
1878	    ((eq? 'forall (car t))
1879	     (and (= 3 (length t))
1880		  (list? (second t))
1881		  (call/cc
1882		   (lambda (return)
1883		     (set! typevars
1884		       (append (map (lambda (tv)
1885				      (cond ((symbol? tv) tv)
1886					    ((and (list? tv)
1887						  (= 2 (length tv))
1888						  (symbol? (car tv)))
1889					     (car tv))
1890					    (else (return #f))))
1891				    (second t))
1892			       typevars))
1893		     (set! constraints
1894		       (append (filter-map
1895				(lambda (tv)
1896				  (and (pair? tv)
1897				       (list (car tv)
1898					     (let ((t (validate (cadr tv))))
1899					       (unless t (return #f))
1900					       t))))
1901				(second t))
1902			       constraints))
1903		     (validate (third t) rec)))))
1904	    ((and (eq? 'quote (car t))
1905		  (pair? (cdr t))
1906		  (symbol? (second t))
1907		  (null? (cddr t))
1908		  (second t))
1909	     => (lambda (v)
1910		  (unless (memq v typevars)
1911		    (set! typevars (cons v typevars)))
1912		  v))
1913	    ((eq? 'or (car t)) 
1914	     (and (list? t)
1915		  (not (null? (cdr t)))
1916		  (let ((ts (map validate (cdr t))))
1917		    (and (every identity ts)
1918			 `(or ,@ts)))))
1919	    ((eq? 'struct (car t))
1920	     (and (= 2 (length t)) (symbol? (second t)) t))
1921	    ((eq? 'deprecated (car t))
1922	     (and (= 2 (length t)) (symbol? (second t)) t))
1923	    ((eq? 'refine (car t))
1924	     (and (= 3 (length t))
1925		  (let ((t2 (validate (third t))))
1926		    (and (value-type? t2)
1927			 (list? (second t))
1928			 (every symbol? (second t))
1929			 (list 'refine (second t) t2)))))
1930	    ((or (memq* '--> t) (memq* '-> t)) =>
1931	     (lambda (p)
1932	       (let* ((cleanf (eq? '--> (car p)))
1933		      (ok (or (not rec) (not cleanf))))
1934		 (unless rec (set! clean cleanf))
1935		 (let ((cp (memq* ': p)))
1936		   (cond ((not cp)
1937			  (and ok
1938			       (validate
1939				`(procedure ,(upto t p) ,@(cdr p))
1940				rec)))
1941			 ((and (= 5 (length t))
1942			       (eq? p (cdr t)) ; one argument?
1943			       (eq? cp (cdddr t))) ; 4th item is ":"?
1944			  (set! t (validate `(procedure (,(first t)) ,(third t)) rec))
1945			  ;; we do it this way to distinguish the "outermost" predicate
1946			  ;; procedure type
1947			  (set! ptype (cons t (validate (cadr cp))))
1948			  (and ok t))
1949			 (else #f))))))
1950	    ((memq (car t) '(vector-of list-of))
1951	     (and (list? t)
1952		  (= 2 (length t))
1953		  (let ((t2 (validate (second t))))
1954		    (and t2 `(,(car t) ,t2)))))
1955	    ((memq (car t) '(vector list))
1956	     (and (list? t)
1957		  (let loop ((ts (cdr t)) (ts2 '()))
1958		    (cond ((null? ts) `(,(car t) ,@(reverse ts2)))
1959			  ((validate (car ts)) => 
1960			   (lambda (t2) (loop (cdr ts) (cons t2 ts2))))
1961			  (else #f)))))
1962	    ((eq? 'pair (car t))
1963	     (and (= 3 (length t))
1964		  (let ((ts (map validate (cdr t))))
1965		    (and (every identity ts) `(pair ,@ts)))))
1966	    ((eq? 'procedure (car t))
1967	     (and (pair? (cdr t))
1968		  (let* ((name (if (symbol? (cadr t))
1969				   (cadr t)
1970				   name))
1971			 (t2 (if (symbol? (cadr t)) (cddr t) (cdr t))))
1972		    (and (pair? t2)
1973			 (list? (car t2))
1974			 (let ((ts (validate-llist (car t2))))
1975			   (and ts
1976				(every identity ts)
1977				(let* ((rt2 (cdr t2))
1978				       (rt (if (eq? '* rt2) 
1979					       rt2
1980					       (and (list? rt2)
1981						    (let ((rts (map validate rt2)))
1982						      (and (every identity rts)
1983							   rts))))))
1984				  (and rt
1985				       `(procedure 
1986					 ,@(if (and name (not rec)) (list name) '())
1987					 ,ts
1988					 ,@rt)))))))))
1989	    (else #f)))
1990    (cond ((validate type #f) =>
1991	   (lambda (type)
1992	     (when (pair? typevars)
1993	       (set! type
1994		 `(forall
1995		   ,(map (lambda (tv)
1996			   (put! tv '##core#tv-root (symbol->string (strip-syntax tv)))
1997			   (cond ((assq tv constraints) => identity)
1998				 (else tv)))
1999			 (delete-duplicates typevars eq?))
2000		   ,type)))
2001	     (let ((type2 (simplify-type type)))
2002	       (values 
2003		type2
2004		(and ptype (eq? (car ptype) type) (cdr ptype))
2005		clean))))
2006	  (else (values #f #f #f)))))
2007
2008(define (check-and-validate-type type loc #!optional name)
2009  (let-values (((t pred pure) (validate-type (strip-syntax type) name)))
2010    (or t 
2011	(error loc "invalid type specifier" type))))
2012
2013(define (install-specializations name specs)
2014  (define (fail spec)
2015    (error "invalid specialization format" spec name))
2016  (mark-variable 
2017   name '##compiler#specializations
2018   ;;XXX it would be great if result types could refer to typevars
2019   ;;    bound in the argument types, like this:
2020   ;;
2021   ;; (: with-input-from-file ((-> . *) -> . *)
2022   ;;    (((forall (a) (-> a))) (a) ...code that does it single-valued-ly...))
2023   ;;
2024   ;; This would make it possible to propagate the (single) result type from
2025   ;; the thunk to the enclosing expression. Unfortunately the simplification in
2026   ;; the first validation renames typevars, so the second validation will have
2027   ;; non-matching names.
2028   (map (lambda (spec)
2029	  (if (and (list? spec) (list? (first spec)))
2030	      (let* ((args
2031		      (map (lambda (t) 
2032			     (let-values (((t2 pred pure) (validate-type t #f)))
2033			       (or t2
2034				   (error "invalid argument type in specialization" 
2035					  t spec name))))
2036			   (first spec)))
2037		     (typevars (unzip1 (append-map type-typeenv args))))
2038		(cons
2039		 args
2040		 (case (length spec)
2041		   ((2) (cdr spec))
2042		   ((3) 
2043		    (cond ((list? (second spec))
2044			   (cons
2045			    (map (lambda (t)
2046				   (let-values (((t2 pred pure) (validate-type t #f)))
2047				     (or t2
2048					 (error "invalid result type in specialization" 
2049						t spec name))))
2050				 (second spec))
2051			    (cddr spec)))
2052			  ((eq? '* (second spec)) (cdr spec))
2053			  (else (fail spec))))
2054		   (else (fail spec)))))
2055	      (fail spec)))
2056	specs)))
2057
2058
2059;;; Canonicalize complex pair/list type for matching with "list-of"
2060;
2061; Returns an equivalent (list ...) form, or the original argument if no
2062; canonicalization could be done.
2063
2064(define (canonicalize-list-type t)
2065  (cond ((not (pair? t)) t)
2066	((eq? 'pair (car t))
2067	 (let ((tcar (second t))
2068	       (tcdr (third t)))
2069	   (let rec ((tr tcdr) (ts (list tcar)))
2070	     (cond ((eq? 'null tr)
2071		    `(list ,@(reverse ts)))
2072		   ((and (pair? tr) (eq? 'pair (first tr)))
2073		    (rec (third tr) (cons (second tr) ts)))
2074		   ((and (pair? tr) (eq? 'list (first tr)))
2075		    `(list ,@(reverse ts) ,@(cdr tr)))
2076		   (else t)))))
2077	(else t)))
2078
2079
2080;;; Drop namespace from module-prefixed symbol:
2081
2082(define (strip-namespace sym)
2083  (let* ((s (symbol->string sym))
2084	 (n (string-length s)))
2085    (let loop ((i 0))
2086      (cond ((eq? i n) sym)
2087	    ((eq? (##core#inline "C_subchar" s i) #\#)
2088	     (##sys#intern-symbol (##sys#substring s (fx+ i 1) n)))
2089	    (else (loop (fx+ i 1)))))))
2090
2091
2092;;; hardcoded result types for certain primitives
2093
2094(define-syntax define-special-case
2095  (syntax-rules ()
2096    ((_ name handler)
2097     (##sys#put! 'name '##compiler#special-result-type handler))))
2098
2099(define-special-case ##sys#make-structure
2100  (lambda (node args loc rtypes)
2101    (or (and-let* ((subs (node-subexpressions node))
2102                   ((>= (length subs) 2))
2103                   (arg1 (second subs))
2104                   ((eq? 'quote (node-class arg1)))
2105                   (val (first (node-parameters arg1)))
2106                   ((symbol? val)))
2107          ;;XXX a dirty hack - we should remove the distinct
2108          ;;    "pointer-vector" type.
2109          (if (eq? 'pointer-vector val)
2110              '(pointer-vector)
2111              `((struct ,(strip-namespace val)))))
2112	rtypes)))
2113
2114(let ()
2115  (define (known-length-vector-index node args loc expected-argcount)
2116    (and-let* ((subs (node-subexpressions node))
2117	       ((= (length subs) (add1 expected-argcount)))
2118	       (arg1 (walked-result (second args)))
2119	       ((pair? arg1))
2120	       ((eq? 'vector (car arg1)))
2121	       (index (third subs))
2122	       ((eq? 'quote (node-class index)))
2123	       (val (first (node-parameters index)))
2124	       ((fixnum? val)) ; Standard type warning otherwise
2125	       (vector-length (length (cdr arg1))))
2126      (if (and (>= val 0) (< val vector-length))
2127	  val
2128	  (begin
2129	    (r-index-out-of-range loc node val vector-length "vector")
2130	    #f))))
2131
2132  ;; These are a bit hacky, since they mutate the node.  These special
2133  ;; cases are really only intended for determining result types...
2134  (define (vector-ref-result-type node args loc rtypes)
2135    (or (and-let* ((index (known-length-vector-index node args loc 2))
2136		   (arg1 (walked-result (second args)))
2137		   (vector (second (node-subexpressions node))))
2138	  (mutate-node! node `(##sys#slot ,vector ',index))
2139	  (list (list-ref (cdr arg1) index)))
2140	rtypes))
2141
2142  (define-special-case scheme#vector-ref vector-ref-result-type)
2143  (define-special-case ##sys#vector-ref vector-ref-result-type)
2144
2145  (define-special-case scheme#vector-set!
2146    (lambda (node args loc rtypes)
2147      (or (and-let* ((index (known-length-vector-index node args loc 3))
2148		     (subs (node-subexpressions node))
2149		     (vector (second subs))
2150		     (new-value (fourth subs))
2151		     (new-value-type (walked-result (fourth args)))
2152		     (setter (if (type-always-immediate? new-value-type)
2153				 '##sys#setislot
2154				 '##sys#setslot)))
2155	    (mutate-node! node `(,setter ,vector ',index ,new-value))
2156	    '(undefined))
2157	  rtypes))))
2158
2159;; TODO: Also special-case vector-length?  Makes little sense though.
2160
2161
2162;;; List-related special cases
2163;
2164; Preserve known element types for:
2165;
2166;   list-ref, list-tail
2167
2168(let ()
2169  (define (list-or-null a)
2170    (if (null? a) 'null `(list ,@a)))
2171
2172  ;; Split a list or pair type form at index i, calling k with the two
2173  ;; sections of the type or returning #f if it doesn't match that far.
2174  ;; Note that "list-of" is handled by "forall" entries in types.db
2175  (define (split-list-type l i k)
2176    (cond ((not (pair? l))
2177	   (and (fx= i 0) (eq? l 'null) (k l l)))
2178	  ((eq? (first l) 'list)
2179	   (and (fx< i (length l))
2180		(receive (left right) (split-at (cdr l) i)
2181		  (k (list-or-null left)
2182		     (list-or-null right)))))
2183	  ((eq? (first l) 'pair)
2184	   (let lp ((a '()) (l l) (i i))
2185	     (cond ((fx= i 0)
2186		    (k (list-or-null (reverse a)) l))
2187		   ((and (pair? l)
2188			 (eq? (first l) 'pair))
2189		    (lp (cons (second l) a)
2190                        (third l)
2191                        (sub1 i)))
2192		   (else #f))))
2193	  (else #f)))
2194
2195  ;; canonicalize-list-type will have taken care of converting (pair
2196  ;; (pair ...)) to (list ...) or (list-of ...) for proper lists.
2197  (define (proper-list-type-length t)
2198    (cond ((eq? t 'null) 0)
2199	  ((and (pair? t) (eq? (car t) 'list)) (length (cdr t)))
2200	  (else #f)))
2201
2202  (define (list+index-call-result-type-special-case k)
2203    (lambda (node args loc rtypes)
2204      (or (and-let* ((subs (node-subexpressions node))
2205		     ((= (length subs) 3))
2206		     (arg1 (walked-result (second args)))
2207		     (index (third subs))
2208		     ((eq? 'quote (node-class index)))
2209		     (val (first (node-parameters index)))
2210		     ((fixnum? val))) ; Standard type warning otherwise
2211	    (cond ((negative? val)
2212		   (r-index-out-of-range loc node val 'not-used "list")
2213		   #f)
2214		  ((split-list-type arg1 val k))
2215		  ;; Warn only if it's a known proper list.  This avoids
2216		  ;; false warnings due to component smashing.
2217		  ((proper-list-type-length arg1) =>
2218		   (lambda (length)
2219		     (r-index-out-of-range loc node val length "list")
2220		     #f))
2221		  (else #f)))
2222	  rtypes)))
2223
2224  (define-special-case scheme#list-ref
2225    (list+index-call-result-type-special-case
2226     (lambda (_ result-type)
2227       (and (pair? result-type)
2228	    (list (cadr result-type))))))
2229
2230  (define-special-case scheme#list-tail
2231    (list+index-call-result-type-special-case
2232     (lambda (_ result-type) (list result-type)))))
2233
2234(define-special-case scheme#list
2235  (lambda (node args loc rtypes)
2236    (if (null? (cdr args))
2237	'(null)
2238	`((list ,@(map walked-result (cdr args)))))))
2239
2240(define-special-case ##sys#list
2241  (lambda (node args loc rtypes)
2242    (if (null? (cdr args))
2243	'(null)
2244	`((list ,@(map walked-result (cdr args)))))))
2245
2246(define-special-case scheme#vector
2247  (lambda (node args loc rtypes)
2248    `((vector ,@(map walked-result (cdr args))))))
2249
2250(define-special-case ##sys#vector
2251  (lambda (node args loc rtypes)
2252    `((vector ,@(map walked-result (cdr args))))))
2253
2254(define-special-case scheme#reverse
2255  (lambda (node args loc rtypes)
2256    (or (and-let* ((subs (node-subexpressions node))
2257		   ((= (length subs) 2))
2258		   (arg1 (walked-result (second args)))
2259		   ((pair? arg1))
2260		   ((eq? (car arg1) 'list)))
2261	  `((list ,@(reverse (cdr arg1)))))
2262	rtypes)))
2263
2264(let ()
2265  (define (append-special-case node args loc rtypes)
2266    (define (potentially-proper-list? l) (match-types l 'list '()))
2267
2268    (define (derive-result-type)
2269      (let lp ((args (cdr args))
2270	       (index 1))
2271	(if (null? args)
2272	    'null
2273	    (let* ((arg1 (car args))
2274		   (arg1-t (walked-result arg1)))
2275	      (cond
2276	       ((and (pair? arg1-t) (eq? (car arg1-t) 'list))
2277		(and-let* ((rest-t (lp (cdr args) (add1 index))))
2278		  ;; decanonicalize, then recanonicalize to make it
2279		  ;; easy to append a variety of types.
2280		  (canonicalize-list-type
2281		   (foldl (lambda (rest t) `(pair ,t ,rest))
2282			  rest-t (reverse (cdr arg1-t))))))
2283
2284	       ((and (pair? arg1-t) (eq? (car arg1-t) 'list-of))
2285		(and-let* ((rest-t (lp (cdr args) (add1 index))))
2286		  ;; list-of's length unsurety is "contagious"
2287		  (simplify-type `(or ,arg1-t ,rest-t))))
2288
2289	       ;; TODO: (append (pair x (pair y z)) lst) =>
2290	       ;; (pair x (pair y (or z lst)))
2291	       ;; This is trickier than it sounds!
2292
2293	       (else
2294		;; The final argument may be an atom or improper list
2295		(unless (or (null? (cdr args))
2296			    (potentially-proper-list? arg1-t))
2297		  (r-proc-call-argument-type-mismatch
2298		   loc node index arg1 'list arg1-t
2299		   (variable-mark 'scheme#append '##compiler#type)))
2300		#f))))))
2301    (cond ((derive-result-type) => list)
2302	  (else rtypes)))
2303
2304  (define-special-case scheme#append append-special-case)
2305  (define-special-case ##sys#append append-special-case))
2306
2307;;; Special cases for make-list/make-vector with a known size
2308;
2309; e.g. (make-list 3 #\a) => (list char char char)
2310
2311(let ()
2312
2313  (define (complex-object-constructor-result-type-special-case type)
2314    (lambda (node args loc rtypes)
2315      (or (and-let* ((subs (node-subexpressions node))
2316		     (fill (case (length subs)
2317			     ((2) '*)
2318			     ((3) (walked-result (third args)))
2319			     (else #f)))
2320		     (sub2 (second subs))
2321		     ((eq? 'quote (node-class sub2)))
2322		     (size (first (node-parameters sub2)))
2323		     ((fixnum? size))
2324		     ((<= 0 size +maximal-complex-object-constructor-result-type-length+)))
2325	    `((,type ,@(make-list size fill))))
2326	  rtypes)))
2327
2328  (define-special-case scheme#make-vector
2329    (complex-object-constructor-result-type-special-case 'vector)))
2330
2331
2332;;; perform check over all typevar instantiations
2333;
2334; If "all" is #t all types in tlist must match, if #f then one or more.
2335
2336(define (over-all-instantiations tlist typeenv all process)
2337  (let ((insts '())
2338	(anyinst #f)
2339	(trail0 trail))
2340
2341    ;; restore trail and collect instantiations
2342    (define (restore)
2343      (ddd "restoring, trail: ~s, te: ~s" trail typeenv)
2344      (let ((is '()))
2345	(do ((tr trail (cdr tr)))
2346	    ((eq? tr trail0)
2347	     (set! trail tr)
2348	     (when (pair? is) (set! anyinst #t))
2349	     (set! insts (cons is insts)))
2350	  (set! is (alist-cons 
2351		    (car tr)
2352		    (resolve (car tr) typeenv)
2353		    is))
2354	  (ddd "  restoring ~a, insts: ~s" (car tr) insts)
2355	  (let ((a (assq (car tr) typeenv)))
2356	    (set-car! (cdr a) #f)))))
2357
2358    ;; collect candidates for each typevar
2359    (define (collect)
2360      (let* ((vars (delete-duplicates (concatenate (map unzip1 insts)) eq?))
2361	     (all (map (lambda (var)
2362			 (cons
2363			  var
2364			  (filter-map
2365			   (lambda (inst)
2366			     (cond ((assq var inst) => cdr)
2367				   ;;XXX is the following correct in all cases?
2368				   (all '*)
2369				   (else #f)))
2370			   insts)))
2371		       vars)))
2372	(ddd "  collected: ~s" all)
2373	all))
2374
2375    (ddd " over-all-instantiations: ~s all: ~a" tlist all)
2376    ;; process all tlist elements
2377    (let loop ((ts (delete-duplicates tlist eq?))
2378	       (ok #f))
2379      (cond ((null? ts)
2380	     (cond ((or ok (null? tlist))
2381		    (for-each 
2382		     (lambda (i)
2383		       (set! trail (cons (car i) trail))
2384		       (set-car! (cdr (assq (car i) typeenv))
2385				 (simplify-type `(or ,@(cdr i)))))
2386		     (collect))
2387		    #t)
2388		   (else #f)))
2389	    ((process (car ts))
2390	     (restore)
2391	     (loop (cdr ts) #t))
2392	    (all
2393	     (restore)
2394	     #f)
2395	    (else 
2396	     (restore)
2397	     (loop (cdr ts) ok))))))
2398
2399;;; Report helpers
2400
2401(define (multiples n)
2402  (if (= n 1) "" "s"))
2403
2404(define (string-add-indent str #!optional (indent "  "))
2405  (let* ((ls (string-split str "\n" #t))
2406	 (s (string-intersperse
2407	     (map (lambda (l)
2408		    (if (string=? "" l)
2409			l
2410			(string-append indent l)))
2411		  ls)
2412	     "\n")))
2413    (if (eq? #\newline (string-ref str (sub1 (string-length str))))
2414	(string-append s "\n")
2415	s)))
2416
2417(define (type->pp-string t)
2418  (define (pp-tv tv)
2419    (let ((r (get tv '##core#tv-root)))
2420      (assert r (list tv: tv))
2421      (list 'quote (string->symbol r))))
2422  (define (conv t #!optional (tv-replacements '()))
2423    (define (R t) (conv t tv-replacements))
2424    (cond
2425      ((not (pair? t))
2426       (or (alist-ref t tv-replacements eq?) t))
2427      ((refinement-type? t)
2428       (string->symbol
2429	(sprintf "~a-~a" (string-intersperse (map conc (second t)) "/") (third t))))
2430      (else
2431       (let ((tcar (and (pair? t) (car t))))
2432	 (cond
2433	   ((and (eq? 'forall tcar) (every symbol? (second t))) ; no constraints
2434	    (let ((tvs (map (lambda (tv) (cons tv (pp-tv tv))) (second t))))
2435	      (conv (third t) tvs)))
2436	   ((eq? 'forall tcar) t) ; forall with constraints, do nothing
2437	   ((memq tcar '(or not list vector pair list-of vector-of))
2438	    `(,tcar ,@(map R (cdr t))))
2439	   ((eq? 'struct tcar) t)
2440	   ((eq? 'procedure tcar)
2441	    (let ((args (map R (procedure-arguments t)))
2442		  (res (let ((res (procedure-results t)))
2443			 (if (eq? '* res)
2444			     #f
2445			     (map R res)))))
2446	      (if (not res) ; '. *' return type not supported by ->
2447		  `(procedure ,args ,@(or res '*))
2448		  `(,@args ,(if (and-let* ((pn (procedure-name t))
2449					   ((variable-mark pn '##compiler#pure))))
2450				'--> '->)
2451			   ,@res))))
2452	   (else (bomb "type->pp-string: unhandled type" t)))))))
2453  (let ((t* (conv (strip-syntax t))))
2454    (string-add-indent
2455     (string-chomp
2456      (with-output-to-string
2457       (lambda () (pp t*)))))))
2458
2459(define (fragment x)
2460  (let ((x (build-expression-tree (source-node-tree x))))
2461    (let walk ((x x) (d 0))
2462      (cond ((atom? x) (strip-syntax x))
2463	    ((>= d +fragment-max-depth+) '...)
2464	    ((list? x)
2465	     (let* ((len (length x))
2466		    (xs (if (< +fragment-max-length+ len)
2467			    (append (take x +fragment-max-length+) '(...))
2468			    x)))
2469	       (map (cute walk <> (add1 d)) xs)))
2470	    (else (strip-syntax x))))))
2471
2472(define (pp-fragment x)
2473  (string-add-indent
2474   (string-chomp
2475    (with-output-to-string
2476      (lambda ()
2477	(pp (fragment x)))))))
2478
2479(define (node-source-prefix n)
2480  (let ((line (node-line-number n)))
2481    (if (not line) "" (sprintf "In file `~a'," line))))
2482
2483(define (location-name loc #!optional (indent "  "))
2484  (define (lname loc1)
2485    (if loc1
2486	(sprintf "In procedure `~a'," (real-name loc1))
2487	"In a local procedure,"))
2488  (if (null? loc)
2489      (conc "At the toplevel,\n" indent)
2490      (let rec ((loc loc)
2491		(msgs (list "")))
2492	(if (null? (cdr loc))
2493	    (string-intersperse
2494	     (cons (if (car loc)
2495		       ;; If the first location is of format 'bar#foo'
2496		       ;; consider it as being being procedure 'foo' in
2497		       ;; module 'bar'.
2498		       (receive (var mod) (variable-and-module (real-name (car loc)))
2499			 (conc (if mod (sprintf "In module `~a',~%~a" mod indent) "")
2500			       (sprintf "In procedure `~a'," var)))
2501		       "In a toplevel procedure,") msgs)
2502	     (conc "\n" indent))
2503	    (rec (cdr loc)
2504		 (cons (lname (car loc)) msgs))))))
2505
2506(define (variable-and-module name) ; -> (values var module-or-false)
2507  (let* ((str-name (if (symbol? name) (symbol->string name) name))
2508	 (r (string-split str-name "#" #t)))
2509    (if (pair? (cdr r))
2510	(values (string->symbol (second r)) (string->symbol (first r)))
2511	(values (string->symbol str-name) #f))))
2512
2513(define (variable-from-module sym)
2514  (receive (var mod) (variable-and-module sym)
2515    (if mod
2516	(sprintf "`~a' from module `~a'" var mod)
2517	(sprintf "`~a'" var))))
2518
2519(define (describe-expression node)
2520  (define (p-expr n)
2521    (sprintf (string-append "This is the expression:" "~%~%" "~a")
2522	     (pp-fragment n)))
2523  (define (p-node n)
2524    (cond ((and (eq? '##core#call (node-class n))
2525		(let ((pnode (first (node-subexpressions n))))
2526		  (and-let* (((eq? '##core#variable (node-class pnode)))
2527			     (pname (car (node-parameters pnode)))
2528			     (ptype (variable-mark pname '##compiler#type)))
2529		    (sprintf (string-append
2530			      "It is a call to ~a which has this type:"
2531			      "~%~%"
2532			      "~a"
2533			      "~%~%"
2534			      "~a")
2535			     (variable-from-module pname)
2536			     (type->pp-string ptype)
2537			     (p-expr n))))))
2538	  ((eq? '##core#the/result (node-class n)) ; walk through
2539	   (p-node (first (node-subexpressions n))))
2540	  (else (p-expr n))))
2541  (p-node (source-node-tree node)))
2542
2543(define (call-node-procedure-name node)
2544  (fragment (first (node-subexpressions node))))
2545
2546(define (report2 short report-f location-node-candidates loc msg . args)
2547  (define (file-location)
2548    (any (lambda (n) (and (not (string=? "" (node-source-prefix n)))
2549		     (node-source-prefix n)))
2550	 location-node-candidates))
2551  (when *complain?*
2552    (report-f
2553     (conc
2554      short
2555      (string-add-indent
2556       (conc (let ((l (file-location))) (if l (conc "\n" l) "")) "\n"
2557	     (location-name loc "")
2558	     (sprintf "~?" msg args))
2559       "  ")))
2560    (flush-output)))
2561
2562(define (report-notice reason location-node-candidates loc msg . args)
2563  (apply report2 reason ##sys#notice location-node-candidates loc msg args))
2564
2565;;; Reports
2566
2567(define (r-invalid-called-procedure-type loc call-node xptype p-node ptype)
2568  (define (variable-node-name n)
2569    (cond ((eq? '##core#the/result (node-class n))
2570	   (variable-node-name (first (node-subexpressions n))))
2571	  ((eq? '##core#variable (node-class n)) (car (node-parameters n)))
2572	  (else #f)))
2573  (if (variable-node-name p-node)
2574      (report2
2575       "Invalid procedure"
2576       warning
2577       (list p-node call-node)
2578       loc
2579       (string-append
2580	"In procedure call:"
2581	"~%~%"
2582	"~a"
2583	"~%~%"
2584	"Variable ~a is not a procedure."
2585	"~%~%"
2586	"It has this type:"
2587	"~%~%"
2588	"~a")
2589       (pp-fragment call-node)
2590       (variable-from-module (variable-node-name p-node))
2591       (type->pp-string ptype))
2592      (report2
2593       "Invalid procedure"
2594       warning
2595       (list p-node call-node)
2596       loc
2597       (string-append
2598	"In procedure call:"
2599	"~%~%"
2600	"~a"
2601	"~%~%"
2602	"The procedure expression does not appear to be a callable."
2603	"~%~%"
2604	"~a"
2605	"~%~%"
2606	"The expected type is:"
2607	"~%~%"
2608	"~a"
2609	"~%~%"
2610	"The actual type is:"
2611	"~%~%"
2612	"~a")
2613       (pp-fragment call-node)
2614       (describe-expression p-node)
2615       (type->pp-string xptype)
2616       (type->pp-string ptype))))
2617
2618(define (r-proc-call-argument-count-mismatch loc node exp-count argc ptype)
2619  (define pname (call-node-procedure-name node))
2620  (report2
2621   "Wrong number of arguments"
2622   warning
2623   (list node)
2624   loc
2625   (string-append
2626    "In procedure call:"
2627    "~%~%"
2628    "~a"
2629    "~%~%"
2630    "Procedure `~a' is called with ~a argument~a but ~a argument~a ~a expected."
2631    "~%~%"
2632    "Procedure ~a has this type:"
2633    "~%~%"
2634    "~a")
2635   (pp-fragment node)
2636   (strip-namespace pname)
2637   argc (multiples argc)
2638   exp-count (multiples exp-count)
2639   (if (= exp-count 1) "is" "are")
2640   (variable-from-module pname)
2641   (type->pp-string ptype)))
2642
2643(define (r-proc-call-argument-type-mismatch loc node i arg-node xptype atype ptype)
2644  (define pname (call-node-procedure-name node))
2645  (report2
2646   "Invalid argument"
2647   warning
2648   (list node)
2649   loc
2650   (string-append
2651    "In procedure call:"
2652    "~%~%"
2653    "~a"
2654    "~%~%"
2655    "Argument #~a to procedure `~a' has an invalid type:"
2656    "~%~%"
2657    "~a"
2658    "~%~%"
2659    "The expected type is:"
2660    "~%~%"
2661    "~a"
2662    "~%~%"
2663    "~a"
2664    "~%~%"
2665    "Procedure ~a has this type:"
2666    "~%~%"
2667    "~a")
2668   (pp-fragment node)
2669   i
2670   (strip-namespace pname)
2671   (type->pp-string atype)
2672   (type->pp-string xptype)
2673   (describe-expression arg-node)
2674   (variable-from-module pname)
2675   (type->pp-string ptype)))
2676
2677(define (r-proc-call-argument-value-count loc call-node i arg-node atype)
2678  (define pname (call-node-procedure-name call-node))
2679  (define (p short long)
2680    (report2
2681     short
2682     warning
2683     (list arg-node call-node)
2684     loc
2685     (string-append
2686      "In procedure call:"
2687      "~%~%"
2688      "~a"
2689      "~%~%"
2690      "Argument #~a to procedure~a ~a"
2691      "~%~%"
2692      "~a")
2693     (pp-fragment call-node)
2694     i
2695     (if (zero? i) "" (sprintf " `~a'" (strip-namespace pname)))
2696     long
2697     (describe-expression arg-node)))
2698  (if (zero? (length atype))
2699      (p "Not enough argument values"
2700	 "does not return any values.")
2701      (p "Too many argument values"
2702	 (sprintf "returns ~a values but 1 is expected." (length atype)))))
2703
2704(define (r-index-out-of-range loc node idx obj-length obj-name)
2705  ;; Negative indices should always generate a warning
2706  (define pname (call-node-procedure-name node))
2707  (report2
2708   (if (negative? idx)
2709       (sprintf "Negative ~a index" obj-name)
2710       (sprintf "~a~a index out of range"
2711		(char-upcase (string-ref obj-name 0))
2712		(substring obj-name 1)))
2713   warning
2714   (list node)
2715   loc
2716   (string-append
2717    "In procedure call:"
2718    "~%~%"
2719    "~a"
2720    "~%~%"
2721    "Procedure ~a is called with ~a")
2722   (pp-fragment node)
2723   (variable-from-module pname)
2724   (if (negative? idx)
2725       (sprintf "a negative index ~a." idx)
2726       (sprintf "index `~a' for a ~a of length `~a'." idx obj-name obj-length))))
2727
2728(define (r-conditional-value-count-invalid loc if-node test-node atype)
2729  (define (p short long)
2730    (report2 short warning (list test-node if-node)
2731	     loc
2732	     (string-append
2733	      "In conditional:"
2734	      "~%~%"
2735	      "~a"
2736	      "~%~%"
2737	      "The test expression ~a"
2738	      "~%~%"
2739	      "~a")
2740	     (pp-fragment if-node)
2741	     long
2742	     (describe-expression test-node)))
2743  (if (zero? (length atype))
2744      (p "Zero values for conditional"
2745	 "returns 0 values.")
2746      (p "Too many values for conditional"
2747	 (sprintf "returns ~a values." (length atype)))))
2748
2749(define (r-let-value-count-invalid loc var let-node val-node atype)
2750  (define (p short long)
2751    (report2 short warning (list val-node let-node)
2752	     loc
2753	     (string-append
2754	      "In let expression:"
2755	      "~%~%"
2756	      "~a"
2757	      "~%~%"
2758	      "Variable `~a' is bound to an expression that ~a"
2759	      "~%~%"
2760	      "~a")
2761	     (pp-fragment let-node)
2762	     (real-name var)
2763	     long
2764	     (describe-expression val-node)))
2765  (if (zero? (length atype))
2766      (p (sprintf "Let binding to `~a' has zero values" (real-name var))
2767	 "returns 0 values.")
2768      (p (sprintf "Let binding to `~a' has ~a values" (real-name var) (length atype))
2769	 (sprintf "returns ~a values." (length atype)))))
2770
2771(define (r-assignment-value-count-invalid loc var set-node val-node atype)
2772  (define (p short long)
2773    (report2 short warning (list val-node set-node)
2774	     loc
2775	     (string-append
2776	      "In assignment:"
2777	      "~%~%"
2778	      "~a"
2779	      "~%~%"
2780	      "Variable `~a' is assigned from expression that ~a"
2781	      "~%~%"
2782	      "~a")
2783	     (pp-fragment set-node)
2784	     (strip-namespace var)
2785	     long
2786	     (describe-expression val-node)))
2787  (if (zero? (length atype))
2788      (p (sprintf "Assignment to `~a' has zero values" (strip-namespace var))
2789	 "returns 0 values.")
2790      (p (sprintf "Assignment to `~a' has ~a values" (strip-namespace var) (length atype))
2791	 (sprintf "returns ~a values." (length atype)))))
2792
2793(define (r-pred-call-always-true loc node pred-type atype)
2794  (define pname (call-node-procedure-name node))
2795  (report-notice
2796   "Predicate is always true"
2797   (list node)
2798   loc
2799   (string-append
2800    "In procedure call:"
2801    "~%~%"
2802    "~a"
2803    "~%~%"
2804    "The predicate will always return true."
2805    "~%~%"
2806    "Procedure ~a is a predicate for:"
2807    "~%~%"
2808    "~a"
2809    "~%~%"
2810    "The given argument has this type:"
2811    "~%~%"
2812    "~a")
2813   (pp-fragment node)
2814   (variable-from-module pname)
2815   (type->pp-string pred-type)
2816   (type->pp-string atype)))
2817
2818(define (r-pred-call-always-false loc node pred-type atype)
2819  (define pname (call-node-procedure-name node))
2820  (report-notice
2821   "Predicate is always false"
2822   (list node)
2823   loc
2824   (string-append
2825    "In procedure call:"
2826    "~%~%"
2827    "~a"
2828    "~%~%"
2829    "The predicate will always return false."
2830    "~%~%"
2831    "Procedure ~a is a predicate for:"
2832    "~%~%"
2833    "~a"
2834    "~%~%"
2835    "The given argument has this type:"
2836    "~%~%"
2837    "~a")
2838   (pp-fragment node)
2839   (variable-from-module pname)
2840   (type->pp-string pred-type)
2841   (type->pp-string atype)))
2842
2843(define (r-cond-test-always-true loc if-node test-node t)
2844  (report-notice
2845   "Test is always true"
2846   (list test-node if-node)
2847   loc
2848   (string-append
2849    "In conditional expression:"
2850    "~%~%"
2851    "~a"
2852    "~%~%"
2853    "Test condition has always true value of type:"
2854    "~%~%"
2855    "~a")
2856   (pp-fragment if-node)
2857   (type->pp-string t)))
2858
2859(define (r-cond-test-always-false loc if-node test-node)
2860  (report-notice
2861   "Test is always false"
2862   (list test-node if-node)
2863   loc
2864   (string-append
2865    "In conditional expression:"
2866    "~%~%"
2867    "~a"
2868    "~%~%"
2869    "Test condition is always false.")
2870   (pp-fragment if-node)))
2871
2872(define (r-zero-values-for-the loc node the-type)
2873  ;; (the t r) expects r returns exactly 1 value
2874  (report2
2875   "Not enough values"
2876   warning
2877   (list node)
2878   loc
2879   (string-append
2880    "In expression:"
2881    "~%~%"
2882    "~a"
2883    "~%~%"
2884    "Expression returns 0 values but is declared to return:"
2885    "~%~%"
2886    "~a")
2887   (pp-fragment node)
2888   (type->pp-string the-type)))
2889
2890(define (r-too-many-values-for-the loc node the-type rtypes)
2891  (report2
2892   "Too many values"
2893   warning
2894   (list node)
2895   loc
2896   (string-append
2897    "In expression:"
2898    "~%~%"
2899    "~a"
2900    "~%~%"
2901    "Expression returns too many values."
2902    "~%~%"
2903    "The expression returns ~a values but is declared to return:"
2904    "~%~%"
2905    "~a")
2906   (pp-fragment node)
2907   (length rtypes)
2908   (type->pp-string the-type)))
2909
2910(define (r-type-mismatch-in-the loc node atype the-type)
2911  (report2
2912   "Type mismatch"
2913   warning
2914   (list node)
2915   loc
2916   (string-append
2917    "In expression:"
2918    "~%~%"
2919    "~a"
2920    "~%~%"
2921    "Expression's declared and actual types do not match."
2922    "~%~%"
2923    "The declared type is:"
2924    "~%~%"
2925    "~a"
2926    "~%~%"
2927    "The actual type is:"
2928    "~%~%"
2929    "~a")
2930   (pp-fragment node)
2931   (type->pp-string the-type)
2932   (type->pp-string atype)))
2933
2934(define (fail-compiler-typecase loc node atype ct-types)
2935  (define (pp-type t) (string-add-indent (type->pp-string t) "  "))
2936  (quit-compiling
2937   (string-append
2938    "No typecase match"
2939    "~%"
2940    "~a"
2941    "~a"
2942    "In `compiler-typecase' expression:"
2943    "~%~%"
2944    "  ~a"
2945    "~%~%"
2946    "  Tested expression does not match any case."
2947    "~%~%"
2948    "  The expression has this type:"
2949    "~%~%"
2950    "~a"
2951    "~%~%"
2952    "  The specified type cases are these:"
2953    "~%~%"
2954    "~a")
2955   (if (string=? "" (node-source-prefix node))
2956       "\n"
2957       (conc "  " (node-source-prefix node) "\n  "))
2958   (location-name loc)
2959   (pp-fragment node)
2960   (pp-type atype)
2961   (string-intersperse (map pp-type ct-types) "\n\n")))
2962
2963(define (r-cond-branch-value-count-mismatch loc node c-node a-node c-types a-types)
2964  (report2
2965   "Branch values mismatch"
2966   warning
2967   (list a-node node)
2968   loc
2969   (string-append
2970    "In conditional expression:"
2971    "~%~%"
2972    "~a"
2973    "~%~%"
2974    "The branches have different numbers of values."
2975    "~%~%"
2976    "The true branch returns ~a value~a:"
2977    "~%~%"
2978    "~a"
2979    "~%~%"
2980    "The false branch returns ~a value~a:"
2981    "~%~%"
2982    "~a")
2983   (pp-fragment node)
2984   (length c-types) (multiples (length c-types))
2985   (pp-fragment c-node)
2986   (length a-types) (multiples (length a-types))
2987   (pp-fragment a-node)))
2988
2989(define (r-toplevel-var-assignment-type-mismatch loc node atype var xptype value-node)
2990  (report2
2991   "Invalid assignment"
2992   warning
2993   (list node value-node)
2994   loc
2995   (string-append
2996    "In assignment:"
2997    "~%~%"
2998    "~a"
2999    "~%~%"
3000    "Variable `~a' is assigned invalid value."
3001    "~%~%"
3002    "The assigned value has this type:"
3003    "~%~%"
3004    "~a"
3005    "~%~%"
3006    "The declared type of ~a is:"
3007    "~%~%"
3008    "~a")
3009   (pp-fragment node)
3010   (strip-namespace var)
3011   (type->pp-string atype)
3012   (variable-from-module
3013    (let ((n (real-name var)))
3014      (if (symbol? n) n (string->symbol n))))
3015   (type->pp-string xptype)))
3016
3017(define (r-deprecated-identifier loc node id #!optional suggestion)
3018  (report2
3019   (sprintf "Deprecated identifier `~a'" (strip-namespace id))
3020   warning
3021   (list node)
3022   loc
3023   (string-append
3024    "In expression:"
3025    "~%~%"
3026    "~a"
3027    "~%~%"
3028    "Use of deprecated identifier ~a."
3029    "~a")
3030   (pp-fragment node) ;; TODO: parent node would be nice here
3031   (variable-from-module id)
3032   (if suggestion
3033       (sprintf "~%~%The suggested alternative is ~a."
3034		(variable-from-module suggestion))
3035       "")))
3036)