X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=5b95bc72ae0d6c02574ef39b7d93780497b465f5;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=7204f6f3a7c0548656cdf9af91b1128db4816a01;hpb=1ff04b3ba4e6f3a0fc6ceea524e98720ecea7888;p=sbcl.git diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 7204f6f..5b95bc7 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -121,7 +121,8 @@ #-no-ansi-print-object (:print-object (lambda (x s) (print-unreadable-object (x s :type t) - (prin1 (class-info-name x)))))) + (prin1 (class-info-name x))))) + (:copier nil)) ;; name of this class (name nil :type keyword :read-only t) ;; List of Type-Info structures for each type in this class. @@ -147,7 +148,8 @@ "~S ~S, Number = ~D" (class-info-name (type-info-class x)) (type-info-name x) - (type-info-number x)))))) + (type-info-number x))))) + (:copier nil)) ;; the name of this type (name (required-argument) :type keyword) ;; this type's class @@ -169,7 +171,7 @@ (eval-when (:compile-toplevel :execute) (setf *info-classes* (make-hash-table))) -;;; If Name is the name of a type in Class, then return the TYPE-INFO, +;;; If NAME is the name of a type in CLASS, then return the TYPE-INFO, ;;; otherwise NIL. (defun find-type-info (name class) (declare (type keyword name) (type class-info class)) @@ -181,12 +183,21 @@ (declaim (ftype (function (keyword) class-info) class-info-or-lose)) (defun class-info-or-lose (class) (declare (type keyword class)) - (or (gethash class *info-classes*) - (error "~S is not a defined info class." class))) + #+sb-xc (/noshow0 "entering CLASS-INFO-OR-LOSE, CLASS=..") + #+sb-xc (/nohexstr class) + (prog1 + (or (gethash class *info-classes*) + (error "~S is not a defined info class." class)) + #+sb-xc (/noshow0 "returning from CLASS-INFO-OR-LOSE"))) (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose)) (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))) + #+sb-xc (/noshow0 "entering TYPE-INFO-OR-LOSE, CLASS,TYPE=..") + #+sb-xc (/nohexstr class) + #+sb-xc (/nohexstr type) + (prog1 + (or (find-type-info type (class-info-or-lose class)) + (error "~S is not a defined info type." type)) + #+sb-xc (/noshow0 "returning from TYPE-INFO-OR-LOSE"))) ) ; EVAL-WHEN @@ -199,16 +210,17 @@ (eval-when (:compile-toplevel :execute) -;;; 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. +;;; Set up the data structures to support an info class. +;;; +;;; comment from CMU CL: +;;; We make sure that the class exists at compile time so that +;;; macros can use it, but we don't actually store the init function +;;; until load time so that we don't break the running compiler. +;;; KLUDGE: I don't think that's the way it is any more, but I haven't +;;; looked into it enough to write a better comment. -- WHN 2001-03-06 (#+sb-xc-host defmacro #-sb-xc-host sb!xc:defmacro define-info-class (class) - #!+sb-doc - "Define-Info-Class Class - Define a new class of global information." (declare (type keyword class)) `(progn ;; (We don't need to evaluate this at load time, compile time is @@ -310,7 +322,8 @@ ;;; 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 (:constructor nil)) +(defstruct (info-env (:constructor nil) + (:copier nil)) ;; some string describing what is in this environment, for ;; printing/debugging purposes only (name (required-argument) :type string)) @@ -372,7 +385,8 @@ (declare (ignorable ,type-var ,class-var ,value-var)) ,@body - (unless (zerop (logand ,n-info compact-info-entry-last)) + (unless (zerop (logand ,n-info + compact-info-entry-last)) (return-from ,PUNT)))))))))))))) ;;; Return code to iterate over a volatile info environment. @@ -467,7 +481,8 @@ ;;; 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) - #-sb-xc-host (:pure :substructure)) + #-sb-xc-host (:pure :substructure) + (:copier nil)) ;; 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) @@ -550,25 +565,27 @@ ;;; info environment in names/bucket (defconstant compact-info-environment-density 65) -;;; 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. -;;; -;;; When building the table, we sort the entries by POINTER< in an attempt -;;; to preserve any VM locality present in the original load order, rather than -;;; randomizing with the original hash function. +;;; Return a new compact info environment that holds the same +;;; information as ENV. (defun compact-info-environment (env &key (name (info-env-name env))) - #!+sb-doc - "Return a new compact info environment that holds the same information as - Env." (let ((name-count 0) (prev-name 0) (entry-count 0)) + (/show0 "before COLLECT in COMPACT-INFO-ENVIRONMENT") + + ;; 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. (collect ((names)) + + (/show0 "at head of COLLECT in COMPACT-INFO-ENVIRONMENT") (let ((types ())) (do-info (env :name name :type-number num :value value) + (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT") (unless (eq name prev-name) + (/noshow0 "not (EQ NAME PREV-NAME) case") (incf name-count) (unless (eql prev-name 0) (names (cons prev-name types))) @@ -577,8 +594,17 @@ (incf entry-count) (push (cons num value) types)) (unless (eql prev-name 0) + (/show0 "not (EQL PREV-NAME 0) case") (names (cons prev-name types)))) + ;; Now that we know how big the environment is, we can build + ;; a table to represent it. + ;; + ;; When building the table, we sort the entries by pointer + ;; comparison in an attempt to preserve any VM locality present + ;; in the original load order, rather than randomizing with the + ;; original hash function. + (/show0 "about to make/sort vectors in COMPACT-INFO-ENVIRONMENT") (let* ((table-size (primify (+ (truncate (* name-count 100) compact-info-environment-density) @@ -591,10 +617,12 @@ :element-type 'compact-info-entry)) (sorted (sort (names) #+sb-xc-host #'< + ;; (This MAKE-FIXNUM hack implements + ;; pointer comparison, as explained above.) #-sb-xc-host (lambda (x y) - ;; FIXME: What's going on here? (< (%primitive make-fixnum x) (%primitive make-fixnum y)))))) + (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT") (let ((entries-idx 0)) (dolist (types sorted) (let* ((name (first types)) @@ -620,12 +648,15 @@ (setf (aref entries-info entries-idx) num) (setf (aref entries entries-idx) value) (incf entries-idx))) + (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT") (unless (zerop entry-count) + (/show0 "nonZEROP ENTRY-COUNT") (setf (aref entries-info (1- entry-count)) (logior (aref entries-info (1- entry-count)) compact-info-entry-last))) + (/show0 "falling through to MAKE-COMPACT-INFO-ENV") (make-compact-info-env :name name :table table :index index @@ -634,22 +665,23 @@ ;;;; volatile environments -;;; This is a closed hashtable, with the bucket being computed by taking the -;;; GLOBALDB-SXHASHOID of the Name mod the table size. -(defstruct (volatile-info-env (:include info-env)) - ;; 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. +;;; This is a closed hashtable, with the bucket being computed by +;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size. +(defstruct (volatile-info-env (:include info-env) + (:copier nil)) + ;; 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. + ;; 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: + ;; vector of alists of alists of the form: ;; ((Name . ((Type-Number . Value) ...) ...) (table (required-argument) :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. + ;; 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. + ;; the number of names at which we should grow the table and rehash (threshold 0 :type index)) ;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment. @@ -1284,12 +1316,15 @@ (setf *info-types* (map 'vector (lambda (x) + (/show0 "in LAMBDA (X), X=..") + (/hexstr x) (when x (let* ((class-info (class-info-or-lose (second x))) (type-info (make-type-info :name (first x) :class class-info :number (third x) :type (fourth x)))) + (/show0 "got CLASS-INFO in LAMBDA (X)") (push type-info (class-info-types class-info)) type-info))) '#.(map 'list