Skip to content
Snippets Groups Projects
globaldb.lisp 34.5 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;;    This file provides a functional interface to global information about
;;; named things in the system.  Information is considered to be global if it
;;; must persist between invocations of the compiler.  The use of a functional
;;; interface eliminates the need for the compiler to worry about the actual
;;; representation.   This is important, since the information may well have
;;; several representations.   This code also deals with the need for multiple
;;; "global" environments, so that changing something in the compiler doesn't
;;; trash the running Lisp environment.
;;;
;;;    The database contains arbitrary Lisp values, addressed by a combination
;;; of Name, Class and Type.  The Name is a EQUAL-thing which is the name of
;;; the thing we are recording information about.  Class is the kind of object
;;; involved.  Typical classes are Function, Variable, Type, ...  A Type names
;;; a particular piece of information within a given class.  Class and Type are
;;; symbols, but are compared with STRING=.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package "C")
(use-package "EXTENSIONS")
(use-package "SYSTEM")

(deftype index () `(integer 0 ,most-positive-fixnum))

;;; Undefined-Value  --  Public
;;;
;;;    This is here until we figure out what to do with it.
;;;
(proclaim '(inline undefined-value))
(defun undefined-value ()
  '%undefined%)

(in-package "EXTENSIONS")
(export '(info clear-info define-info-class define-info-type
	       make-info-environment do-info *info-environment*
	       compact-info-environment))

(in-package "C")

;;; The defvar for this appears later.
(proclaim '(special *universal-type*))
(proclaim '(type list type-specifier-symbols))


;;; PRIMIFY  --  Internal
;;;
;;;    Given any non-negative integer, return a prime number >= to it.
;;;
(defun primify (x)
  (declare (type unsigned-byte x))
  (do ((n (logior x 1) (+ n 2)))
      ((system:primep n) n)))



;;;; Defining info types:

(eval-when (compile load eval)

(defstruct (class-info
	    (:constructor make-class-info (name))
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore d))
	       (format stream "#<Class-Info ~S>" (class-info-name s)))))
  ;;
  ;; String name of this class.
  (name nil :type simple-string)
  ;;
  ;; List of Type-Info structures for each type in this class.
  (types () :type list))


;;; At run-time, we represent the type of info that we want by a small
;;; non-negative integer.
;;;
(defconstant type-number-bits 6)
(deftype type-number () `(unsigned-byte ,type-number-bits))
;;;
;;; Also initialized in GLOBALDB-INIT...
(defvar *type-counter* 0)
(defvar *type-numbers*
  (make-array (ash 1 type-number-bits)  :initial-element nil))


(defstruct (type-info
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore d))
	       (format stream "#<Type-Info ~S ~S, Number = ~D>"
		       (class-info-name (type-info-class s))
		       (type-info-name s)
		       (type-info-number s)))))
			     
  ;;
  ;; String name of this type.
  (name nil :type simple-string)
  ;;
  ;; This type's class.
  (class nil :type class-info)
  ;;
  ;; A number that uniquely identifies this type (and implicitly its class.)
  (number nil :type type-number)
  ;;
  ;; Type specifier which info of this type must satisfy.
  (type nil :type t)
  ;;
  ;; Function called when there is no information of this type.  Null at
  ;; meta-compile time.
  (default nil :type (or function null)))


;;; A hashtable from class names to Class-Info structures.  This data structure
;;; exists at compile time as well as run time.  Also initialized in
;;; GLOBALDB-INIT...
;;;
(defvar *info-classes* (make-hash-table :test #'equal))
(proclaim '(hash-table *info-classes*))


;;; FIND-TYPE-INFO  --  Internal
;;;
;;;    If Name is the name of a type in Class, then return the TYPE-INFO,
;;; otherwise NIL.
;;;
(defun find-type-info (name class)
  (declare (simple-string name) (type class-info class))
  (dolist (type (class-info-types class) nil)
    (when (string= (type-info-name type) name)
      (return type))))


;;; Class-Info-Or-Lose, Type-Info-Or-Lose --  Internal
;;;
;;;    Return the info structure for an info class or type, or die trying.
;;;
(proclaim '(function class-info-or-lose (string) class-info))
(defun class-info-or-lose (class)
  (or (gethash class *info-classes*)
      (error "~S is not a defined info class." class)))
;;;
(proclaim '(function type-info-or-lose (string string) type-info))
(defun type-info-or-lose (class type)
  (or (find-type-info type (class-info-or-lose class))
      (error "~S is not a defined info type." type)))


;;; Define-Info-Class  --  Public
;;;
;;;    Set up the data structures to support an info class.  We make sure that
;;; the class exists at compile time so that macros can use it, but don't
;;; actually store the init function until load time so that we don't break the
;;; running compiler.
;;;
(defmacro define-info-class (class)
  "Define-Info-Class Class
  Define a new class of global information."
  `(progn
     (eval-when (compile load eval)
       (%define-info-class ',(symbol-name class)))
     ',class))


;;; %Define-Info-Class  --  Internal
;;;
;;;    If there is no info for the class, then create it, otherwise do nothing.
;;;
(proclaim '(function %define-info-class (string) void))
(defun %define-info-class (class)
  (unless (gethash class *info-classes*)
    (setf (gethash class *info-classes*) (make-class-info class))))


;;; Define-Info-Type  --  Public
;;;
;;;    The main thing we do is determine the type's number.  We need to do this
;;; at macroexpansion time, since both the COMPILE and LOAD time calls to
;;; %DEFINE-INFO-TYPE must use the same type number.
;;;
(defmacro define-info-type (class type type-spec &optional default)
  "Define-Info-Type Class Type default Type-Spec
  Define a new type of global information for Class.  Type is the symbol name
  of the type, Default is the value for that type when it hasn't been set, and
  Type-Spec is a type-specifier which values of the type must satisfy.  The
  default expression is evaluated each time the information is needed, with
  Name bound to the name for which the information is being looked up.  If the
  default evaluates to something with the second value true, then the second
  value of Info will also be true."
  (let* ((class (symbol-name class))
	 (type (symbol-name type))
	 (old (find-type-info type (class-info-or-lose class))))
    `(progn
       (eval-when (compile load eval)
	 (%define-info-type ',class ',type ',type-spec
			    ,(if old
				 (type-info-number old)
				 (incf *type-counter*))))
       (eval-when (load eval)
	 (setf (type-info-default (type-info-or-lose ',class ',type))
	       #'(lambda (name) name ,default)))
       ',type)))


;;; %Define-Info-Type  --  Internal
;;;
;;;    If there is no such type, create it.  In any case, set the type
;;; specifier for the value.  The class must exist.  We bump *TYPE-COUNTER* to
;;; after our number so that it won't be reused by any new info type
;;; definition.
wlott's avatar
wlott committed
;;;
(defun %define-info-type (class type type-spec number)
  (declare (simple-string class type) (type type-number number))
  (setq *type-counter* (max *type-counter* (1+ number)))
wlott's avatar
wlott committed
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954
  (let* ((class-info (class-info-or-lose class))
	 (old (find-type-info type class-info))
	 (res (or old
		  (make-type-info :name type
				  :class class-info
				  :number number
				  :type type-spec)))
	 (num-old (svref *type-numbers* number)))
    (cond (old
	   (setf (type-info-type res) type-spec)
	   (unless (= (type-info-number res) number)
	     (cerror "Redefine it." "Changing type number for ~A ~A."
		     class type)
	     (setf (type-info-number res) number)))
	  (t
	   (push res (class-info-types class-info))))

    (unless (eq num-old res)
      (when num-old
	(cerror "Go for it." "Reusing type number for ~A ~A."
		(class-info-name (type-info-class num-old))
		(type-info-name num-old)))
      (setf (svref *type-numbers* number) res)))

  (undefined-value))

); eval-when (compile load eval)


;;;; Info environments:
;;;
;;;    We do info access relative to the current *info-environment*.  This is a
;;; list of INFO-ENVIRONMENT structures we search.  The variable is actually
;;; initialized in GLOBALDB-INIT.

(defvar *info-environment*)
(proclaim '(type list *info-environment*))


(defun %print-info-environment (s stream d)
  (declare (ignore d) (stream stream)) 
  (format stream "#<~S ~S>" (type-of s) (info-env-name s)))


;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping
;;; reasons.  If we access with accessors for the exact type, then the inline
;;; type check will win.  If the inline check didn't win, we would try to use
;;; the type system before it was properly initialized.
;;;
(defstruct (info-env (:print-function %print-info-environment))
  ;;
  ;; Some string describing what is in this environment, for printing purposes
  ;; only.
  (name nil :type string))


;;; INFO-HASH  --  Internal
;;;
;;;    Semantically equivalent to SXHASH, but optimized for legal function
;;; names.  Note: semantically equivalent does *not* mean that it always
;;; returns the same value as SXHASH, just that it satisfies the formal
;;; definition of SXHASH.
;;;
;;;    All we do for now is pick off the cases of a symbol and a list of two
;;; symbols [e.g. (SETF FOO)].  The symbol case is the same as what SXHASH
;;; does, but we get there more expeditiously.  With the two-list, we LOGXOR a
;;; random constant with the hash of the second symbol.
;;;
(proclaim '(inline info-hash))
(defun info-hash (x)
  (cond
   ((symbolp x)
    #-new-compiler
    (the fixnum (%primitive sxhash-simple-string (symbol-name x)))
    #+new-compiler
    (truly-the index (%primitive sxhash-simple-string (symbol-name x))))
   ((and (listp x)
	 (eq (car x) 'setf))
    (let ((next (cdr x)))
      (when (listp next)
	(let ((name (car next)))
	  (when (and (symbolp name) (null (cdr next)))
	    (return-from info-hash
			 (logxor #-new-compiler
				 (the fixnum
				      (%primitive sxhash-simple-string
						  (symbol-name name)))
				 #+new-compiler
				 (truly-the index
					    (%primitive sxhash-simple-string
							(symbol-name name)))
				 110680597))))))
    (sxhash x))
   (t
    (sxhash x))))


;;;; Generic interfaces:

;;; Info  --  Public
;;;
;;;    This is a macro so that we can resolve the Class and Type to a type
;;; number at compile time.  When we check the new-value's type directly in the
;;; SETF expansion, since the check can be done much more efficiently when the
;;; type is constant.
;;;
(defmacro info (class type name)
  "Return the information of the specified Type and Class for Name.
  The second value is true if there is any such information recorded.  If there
  is no information, the first value is the default and the second value is NIL."
  ;;
  ;; ### Should be a values type, but interpreter can't hack that now.
  (let* ((class (symbol-name class))
	 (type (symbol-name type))
	 (info (type-info-or-lose class type)))
    `(#+new-compiler truly-the #-new-compiler the
		     ,(type-info-type info)
		     (get-info-value ,name ,(type-info-number info)))))
;;;
(define-setf-method info (class type name)
  "Set the global information for Name."
  (let* ((n-name (gensym))
	 (n-value (gensym))
	 (class (symbol-name class))
	 (type (symbol-name type))
	 (info (type-info-or-lose class type)))
    (values
     `(,n-name)
     `(,name)
     `(,n-value)
     `(progn
	(check-type ,n-value ,(type-info-type info))
	(set-info-value ,n-name ,(type-info-number info) ,n-value))
     `(info ,class ,type ,n-name))))


;;; DO-INFO  --  Public
;;;
(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
			(type-number (gensym)) (value (gensym)))
		   &body body)
  "DO-INFO (Env &Key Name Class Type Value) Form*
  Iterate over all the values stored in the Info-Env Env.  Name is bound to
  the entry's name, Class and Type are bound to the class and type
  (represented as strings), and Value is bound to the entry's value."
  (once-only ((n-env env))
    `(if (typep ,n-env 'volatile-info-env)
	 ,(do-volatile-info name class type type-number value n-env body)
	 ,(do-compact-info name class type type-number value n-env body))))


(eval-when (compile load eval)

;;; DO-COMPACT-INFO  --  Internal
;;;
;;;    Return code to iterate over a compact info environment.
;;;
(defun do-compact-info (name-var class-var type-var type-number-var value-var
				 n-env body)
  (let ((n-index (gensym)) (n-type (gensym)) (punt (gensym)))
    (once-only ((n-table `(compact-info-env-table ,n-env))
		(n-entries-index `(compact-info-env-index ,n-env))
		(n-entries `(compact-info-env-entries ,n-env))
		(n-entries-info `(compact-info-env-entries-info ,n-env))
		(n-type-numbers '*type-numbers*))
      `(dotimes (,n-index (length ,n-table))
	 (declare (type index ,n-index))
	 (block ,PUNT
	   (let ((,name-var (svref ,n-table ,n-index)))
	     (unless (eql ,name-var 0)
	       (do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
				       (1+ ,n-type)))
			     (nil)
		 (declare (type index ,n-type))
		 ,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
		    `(let ((,type-number-var
			    (logand ,n-info compact-info-entry-type-mask)))
		       ,(once-only ((n-type-info
				     `(svref ,n-type-numbers
					     ,type-number-var)))
			  `(let ((,type-var (type-info-name ,n-type-info))
				 (,class-var (class-info-name
					      (type-info-class ,n-type-info)))
				 (,value-var (svref ,n-entries ,n-type)))
			     #+new-compiler
			     (declare (ignorable ,type-var ,class-var
						 ,value-var))
			     ,@body
			     (unless (zerop (logand ,n-info compact-info-entry-last))
			       (return-from ,PUNT))))))))))))))

;;; DO-VOLATILE-INFO  --  Internal
;;;
;;;    Return code to iterate over a volatile info environment.
;;;
(defun do-volatile-info (name-var class-var type-var type-number-var value-var
				  n-env body)
  (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
    (once-only ((n-table `(volatile-info-env-table ,n-env))
		(n-type-numbers '*type-numbers*))
      `(dotimes (,n-index (length ,n-table))
	 (do-anonymous ((,n-names (svref ,n-table ,n-index)
				  (cdr ,n-names)))
		       ((null ,n-names))
	   (let ((,name-var (caar ,n-names)))
	     #+new-compiler
	     (declare (ignorable ,name-var))
	     (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
			   ((null ,n-types))
	       (let ((,type-number-var (caar ,n-types)))
		 ,(once-only ((n-type `(svref ,n-type-numbers
					      ,type-number-var)))
		    `(let ((,type-var (type-info-name ,n-type))
			   (,class-var (class-info-name
					(type-info-class ,n-type)))
			   (,value-var (cdar ,n-types)))
		       #+new-compiler
		       (declare (ignorable ,type-var ,class-var ,value-var))
		       ,@body))))))))))


); Eval-When (Compile Load Eval)


;;;; Compact environments:

;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
;;;
(defconstant compact-info-env-entries-bits 16)
(deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))


;;; Type of the values in COMPACT-INFO-ENTRIES-INFO.
;;;
(deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))


;;; This is an open hashtable with rehashing.  Since modification is not
;;; allowed, we don't have to worry about deleted entries.  We indirect through
;;; a parallel vector to find the index in the ENTRIES at which the entries for
;;; a given name starts.
;;;
(defstruct (compact-info-env
	    (:include info-env)
	    (:print-function %print-info-environment))
  ;;
  ;; If this value is EQ to the name we want to look up, then the cache hit
  ;; function can be called instead of the lookup function.
  (cache-name 0)
  ;;
  ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no
  ;; entries.
  (cache-index nil :type (or compact-info-entries-index null))
  ;;
  ;; Hashtable of the names in this environment.  If a bucket is unused, it is
  ;; 0.
  (table nil :type simple-vector)
  ;;
  ;; Indirection vector parallel to TABLE, translating indices in TABLE to the
  ;; start of the ENTRIES for that name.  Unused entries are undefined.
  (index nil :type (simple-array compact-info-entries-index (*)))
  ;;
  ;; Vector contining in contiguous ranges the values of for all the types of
  ;; info for each name.
  (entries nil :type simple-vector)
  ;;
  ;; Vector parallel to ENTRIES, indicating the type number for the value
  ;; stored in that location and whether this location is the last type of info
  ;; stored for this name.  The type number is in the low TYPE-NUMBER-BITS
  ;; bits, and the next bit is set if this is the last entry.
  (entries-info nil :type (simple-array compact-info-entry (*))))


(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
(defconstant compact-info-entry-last (ash 1 type-number-bits))


;;; COMPACT-INFO-CACHE-HIT  --  Internal
;;;
;;;    Return the value of the type corresponding to Number for the currently
;;; cached name in Env.
;;;
(proclaim '(inline compact-info-cache-hit))
(defun compact-info-cache-hit (env number)
  (declare (type compact-info-env env) (type type-number number))
  (let ((entries-info (compact-info-env-entries-info env))
	(index (compact-info-env-cache-index env)))
    (if index
	(do ((index index (1+ index)))
	    (nil)
	  (declare (type index index))
	  (let ((info (aref entries-info index)))
	    (when (= (logand info compact-info-entry-type-mask) number)
	      (return (values (svref (compact-info-env-entries env) index)
			      t)))
	    (unless (zerop (logand compact-info-entry-last info))
	      (return (values nil nil)))))
	(values nil nil))))


;;; COMPACT-INFO-LOOKUP  --  Internal
;;;
;;;    Encache Name in the compact environment Env.  Hash is the INFO-HASH of
;;; Name.
;;;
(defun compact-info-lookup (env name hash)
  (declare (type compact-info-env env) (type index hash))
  (let* ((table (compact-info-env-table env))
	 (len (length table))
	 (len-2 (- len 2))
	 (hash2 (- len-2 (rem hash len-2))))
    (macrolet ((lookup (test)
		 `(do ((probe (rem hash len)
			      (rem (+ probe hash2) len)))
		      (nil)
		    (let ((entry (svref table probe)))
		      (when (eql entry 0)
			(return nil))
		      (when (,test entry name)
			(return (aref (compact-info-env-index env)
				      probe)))))))
      (setf (compact-info-env-cache-index env)
	    (if (symbolp name)
		(lookup eq)
		(lookup equal)))
      (setf (compact-info-env-cache-name env) name)))

  (undefined-value))


;;; Exact density (modulo rounding) of the hashtable in a compact info
;;; environment in names/bucket.
;;;
(defconstant compact-info-environment-density 0.65)


;;; COMPACT-INFO-ENVIRONMENT  --  Public
;;;
;;;    Iterate over the environment once to find out how many names and entries
;;; it has, then build the result.  This code assumes that all the entries for
;;; a name well be iterated over contiguously, which holds true for the
;;; implementation of iteration over both kinds of environments.
;;; 
(defun compact-info-environment (env &key (name (info-env-name env)))
  "Return a new compact info environment that holds the same information as
  Env."
  (let ((name-count 0)
	(prev-name 0)
	(entry-count 0))
    (do-info (env :name name)
      (unless (eq name prev-name)
	(incf name-count)
	(setq prev-name name))
      (incf entry-count))
    
    (let* ((table-size
	    (primify
	     (+
	      (truncate
	       (/ name-count compact-info-environment-density))
	      3)))
	   (table (make-array table-size :initial-element 0))
	   (index (make-array table-size
			      :element-type 'compact-info-entries-index))
	   (entries (make-array entry-count))
	   (entries-info (make-array entry-count
				     :element-type 'compact-info-entry)))

      (let ((prev-name 0)
	    (entries-idx 0))
	(do-info (env :name name :type-number num :value value)
	  (unless (eq prev-name name)
	    (setq prev-name name)
	    (let* ((hash (info-hash name))
		   (len-2 (- table-size 2))
		   (hash2 (- len-2 (rem hash len-2))))
	      (do ((probe (rem hash table-size)
			  (rem (+ probe hash2) table-size)))
		  (nil)
		(let ((entry (svref table probe)))
		  (when (eql entry 0)
		    (setf (svref table probe) name)
		    (setf (aref index probe) entries-idx)
		    (return))
		  (assert (not (equal entry name))))))
	    
	    (unless (zerop entries-idx)
	      (setf (aref entries-info (1- entries-idx)) 
		    (logior (aref entries-info (1- entries-idx))
			    compact-info-entry-last))))
	  
	  (setf (aref entries-info entries-idx) num)
	  (setf (aref entries entries-idx) value)
	  (incf entries-idx)))

      (unless (zerop entry-count)
	(setf (aref entries-info (1- entry-count)) 
	      (logior (aref entries-info (1- entry-count))
		      compact-info-entry-last)))
      
      (make-compact-info-env :name name
			     :table table
			     :index index
			     :entries entries
			     :entries-info entries-info))))
      
      

;;;; Volatile environments:

;;; This is a closed hashtable, with the bucket being computed by taking the
;;; INFO-HASH of the Name mod the table size.
;;;
(defstruct (volatile-info-env
	    (:include info-env)
	    (:print-function %print-info-environment))

  ;;
  ;; If this value is EQ to the name we want to look up, then the cache hit
  ;; function can be called instead of the lookup function.
  (cache-name 0)
  ;;
  ;; The alist translating type numbers to values for the currently cached
  ;; name.
  (cache-types nil :type list)
  ;;
  ;; Vector of alists of alists of the form:
  ;;    ((Name . ((Type-Number . Value) ...) ...)
  ;;
  (table nil :type simple-vector)
  ;;
  ;; The number of distinct names currently in this table (each name may have
  ;; multiple entries, since there can be many types of info.
  (count 0 :type index)
  ;;
  ;; The number of names at which we should grow the table and rehash.
  (threshold nil :type index))


;;; VOLATILE-INFO-CACHE-HIT  --  Internal
;;;
;;;    Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
;;;
(proclaim '(inline volatile-info-cache-hit))
(defun volatile-info-cache-hit (env number)
  (declare (type volatile-info-env env) (type type-number number))
  (dolist (type (volatile-info-env-cache-types env) (values nil nil))
    (when (eql (car type) number)
      (return (values (cdr type) t)))))  


;;; VOLATILE-INFO-LOOKUP  --  Internal
;;;
;;;    Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
;;;
(defun volatile-info-lookup (env name hash)
  (declare (type volatile-info-env env) (type index hash))
  (let ((table (volatile-info-env-table env)))
    (macrolet ((lookup (test)
		 `(dolist (entry (svref table (mod hash (length table))) ())
		    (when (,test (car entry) name)
		      (return (cdr entry))))))
      (setf (volatile-info-env-cache-types env)
	    (if (symbolp name)
		(lookup eq)
		(lookup equal)))
      (setf (volatile-info-env-cache-name env) name)))

  (undefined-value))


;;; WITH-INFO-BUCKET  --  Internal
;;;
;;;    Given a volatile environment Env, bind Table-Var the environment's table
;;; and Index-Var to the index of Name's bucket in the table.  We also flush
;;; the cache so that things will be consistent if body modifies something.
;;;
(eval-when (compile eval)
  (defmacro with-info-bucket ((table-var index-var name env) &body body)
    (once-only ((n-name name)
		(n-env env))
      `(progn
	 (setf (volatile-info-env-cache-name ,n-env) 0)
	 (let* ((,table-var (volatile-info-env-table ,n-env))
		(,index-var (mod (info-hash ,n-name) (length ,table-var))))
	   ,@body)))))


;;; GET-WRITE-INFO-ENV  --  Internal
;;;
;;;    Get the info environment that we use for write/modification operations.
;;; This is always the first environment in the list, and must be a
;;; VOLATILE-INFO-ENV.
;;;
(proclaim '(inline get-write-info-env))
(defun get-write-info-env ()
  (let ((env (car *info-environment*)))
    (unless env
      (error "No info environment?"))
    (unless (typep env 'volatile-info-env)
      (error "Cannot modify this environment: ~S." env))
    (the volatile-info-env env)))


;;; SET-INFO-VALUE  --  Internal
;;;
;;;    If Name is already present in the table, then just create or modify the
;;; specified type.  Otherwise, add the new name and type, checking for
;;; rehashing.
;;;
;;;    We rehash by making a new larger environment, copying all of the entries
;;; into it, then clobbering the old environment with the new environment's
;;; table.  We clear the old table to prevent it from holding onto garbage if
;;; it is statically allocated.
;;;
(defun set-info-value (name type new-value &optional
			    (env (get-write-info-env)))
  (declare (type type-number type) (type volatile-info-env env)
	   (inline assoc))
  (when (eql name 0)
    (error "0 is not a legal INFO name."))
  (with-info-bucket (table index name env)
    (let ((types (if (symbolp name)
		     (assoc name (svref table index) :test #'eq)
		     (assoc name (svref table index) :test #'equal))))
      (cond
       (types
	(let ((value (assoc type (cdr types))))
	  (if value
	      (setf (cdr value) new-value)
	      (push (cons type new-value) (cdr types)))))
       (t
	(push (cons name (list (cons type new-value)))
	      (svref table index))

	(let ((count (incf (volatile-info-env-count env))))
	  (when (>= count (volatile-info-env-threshold env))
	    (let ((new (make-info-environment :size (* count 2))))
	      (do-info (env :name entry-name :type-number entry-num
			    :value entry-val)
		(set-info-value entry-name entry-num entry-val new))
	      (fill (volatile-info-env-table env) nil)
	      (setf (volatile-info-env-table env)
		    (volatile-info-env-table new))
	      (setf (volatile-info-env-threshold env)
		    (volatile-info-env-threshold new)))))))))
	  
  new-value)


;;; The maximum density of the hashtable in a volatile env (in names/bucket).
;;;
(defconstant volatile-info-environment-density 0.5)


;;; MAKE-INFO-ENVIRONMENT  --  Public
;;;
;;;    Make a new volatile environment of the specified size.
;;;
(defun make-info-environment (&key (size 42) (name "Unknown"))
  (declare (type (integer 1) size))
  (let ((table-size
	 (primify
	  (truncate
	   (/ size volatile-info-environment-density)))))
    (make-volatile-info-env
     :name name
     :table (make-array table-size :initial-element nil)
     :threshold size)))


;;; CLEAR-INFO  --  Public
;;;
(defmacro clear-info (class type name)
  "Clear the information of the the specified Type and Class for Name in the
  current environment, allowing any inherited info to become visible.  We
  return true if there was any info."
  (let* ((class (symbol-name class))
	 (type (symbol-name type))
	 (info (type-info-or-lose class type)))
    `(clear-info-value ,name ,(type-info-number info))))
;;;
(defun clear-info-value (name type)
  (declare (type type-number type) (inline assoc))
  (with-info-bucket (table index name (get-write-info-env))
    (let ((types (assoc name (svref table index) :test #'equal)))
      (when (and types
		 (assoc type (cdr types)))
	(setf (cdr types)
	      (delete type (cdr types) :key #'car))
	t))))


;;; GET-INFO-VALUE  --  Internal
;;;
;;;    Return the value from the first environment which has it defined, or
;;; return the default if none does.  We have a cache for the last name looked
;;; up in each environment.  We don't compute the hash until the first time the
;;; cache misses.  When the cache does miss, we invalidate it before calling
;;; the lookup routine to eliminate the possiblity of the cache being
;;; partially updated if the lookup is interrupted.
;;;
(defun get-info-value (name type)
  (declare (type type-number type))
  (let ((hash nil))
    (dolist (env *info-environment*
		 (multiple-value-bind
		     (val winp)
		     (funcall (type-info-default (svref *type-numbers* type))
			       name)
		   (values val winp)))
      (macrolet ((frob (lookup cache slot)
		   `(progn
		      (unless (eq name (,slot env))
			(unless hash
			  (setq hash (info-hash name)))
			(setf (,slot env) 0)
			(,lookup env name hash))
		      (multiple-value-bind
			  (value winp)
			  (,cache env type)
			(when winp (return (values value t)))))))
      (if (typep env 'volatile-info-env)
	  (frob volatile-info-lookup volatile-info-cache-hit
	        volatile-info-env-cache-name)
	  (frob compact-info-lookup compact-info-cache-hit
	        compact-info-env-cache-name))))))


;;;; Initialization:

;;; GLOBALDB-INIT  --  Interface
;;;
;;;    Since the global enviornment database is used by top-level forms in this
;;; file, we must initialize the database before processing any top-level
;;; forms.  This requires a special initialization function that is called from
;;; %INITIAL-FUNCTION.  We replicate the init forms of the variables that
;;; maintain the class/type namespace.
;;;
(defun globaldb-init ()
  (setq *info-environment*
	(list (make-info-environment :name "Initial Global")))
  (unless (boundp '*info-classes*)
    (setq *info-classes* (make-hash-table :test #'equal))
    (setq *type-counter* 0)
    (setq *type-numbers*
	  (make-array (ash 1 type-number-bits)  :initial-element nil)))
  (function-info-init)
  (other-info-init))


;;;; Definitions for function information.

(defun function-info-init ()

(define-info-class function)

;;; The kind of functional object being described.  If null, Name isn't a known
;;; functional object.
(define-info-type function kind (member nil :function :macro :special-form)
  #+new-compiler
  (if (fboundp name) :function nil)
  #-new-compiler
  nil)

;;; The type specifier for this function.
(define-info-type function type ctype
  #+new-compiler
  (if (fboundp name)
      (let ((def (fdefinition name)))
	(let ((entry (if (eql (%primitive get-vector-subtype def)
			      %function-closure-subtype)
			 (%primitive header-ref def %function-name-slot)
			 def)))
	  (specifier-type
	   (%primitive header-ref entry %function-entry-type-slot))))
      (specifier-type 'function))
  #-new-compiler
  (specifier-type 'function))

;;; The Assumed-Type for this function, if we have to infer the type due to not
;;; having a declaration or definition.
(define-info-type function assumed-type (or approximate-function-type null))

;;; Where this information came from:
;;;  :declared, from a declaration.
;;;  :assumed, from uses of the object.
;;;  :defined, from examination of the definition.
(define-info-type function where-from (member :declared :assumed :defined)
  #+new-compiler
  (if (fboundp name) :defined :assumed)
  #-new-compiler
  :assumed)

;;; Lambda used for inline expansion of this function.
(define-info-type function inline-expansion list)

;;; Specifies whether this function may be expanded inline.  If null, we
;;; don't care.
(define-info-type function inlinep inlinep nil)

;;; A macro-like function which transforms a call to this function into some
;;; other Lisp form.  This expansion is inhibited if inline expansion is
;;; inhibited.
(define-info-type function source-transform (or function null))

;;; The macroexpansion function for this macro.
;;; ### For now, allow List, since in our bootstrapping environment, a List
;;; isn't function, but there also isn't any way to coerce a lambda-list to a
;;; function.
(define-info-type function macro-function (or function null list)
  nil)

;;; A function which converts this special form into IR1.
(define-info-type function ir1-convert (or function null))

;;; A function which gets a chance to do stuff to the IR1 for any call to this
;;; function.
(define-info-type function ir1-transform (or function null))

;;; If a function is an alien-operator, then this is the Alien-Info.
(define-info-type function alien-operator (or lisp::alien-info null) nil)

;;; If a function is a defstruct slot accessor or setter, then this is the
;;; defstruct-definition for the structure that it belongs to.
(define-info-type function accessor-for (or defstruct-description null)
  nil)

;;; If a function is "known" to the compiler, then this is FUNCTION-INFO
;;; structure containing the info used to special-case compilation.
(define-info-type function info (or function-info null) nil)

(define-info-type function documentation (or string null) nil)

wlott's avatar
wlott committed
); defun function-info-init

#|
  Other:
    Documentation?
|#

;;;; Definitions for other random information.

(defun other-info-init ()

(define-info-class variable)

;;; The kind of variable-like thing described.
(define-info-type variable kind (member :special :constant :global)
  #+new-compiler
  (if (or (eq (symbol-package name) (symbol-package :end))
	  (member name '(t nil)))
      :constant
      :global)
  #-new-compiler
  (if (constantp name)
      :constant
      :global))

;;; The declared type for this variable.
(define-info-type variable type ctype *universal-type*)

;;; Where this type and kind information came from.
(define-info-type variable where-from (member :declared :assumed :defined)
  :assumed)

;;; The the lisp object which is the value of this constant, if known.
(define-info-type variable constant-value t
  #+new-compiler
  (if (boundp name)
      (values (symbol-value name) t)
      (values nil nil))
  #-new-compiler
  (if (constantp name)
      (values (symbol-value name) t)
      (values nil nil)))

(define-info-type variable alien-value (or lisp::ct-a-val null) nil)