UPGRADED-ARRAY-ELEMENT-TYPE: more thoroughly signal errors on unknown types.

[sbcl.git] / src / compiler / trace-table.lisp

diff --git a/src/compiler/trace-table.lisp b/src/compiler/trace-table.lisp
index 80c217c..f006add 100644 (file)
--- a/src/compiler/trace-table.lisp
+++ b/src/compiler/trace-table.lisp
@@ -11,66 +11,32 @@
 
 (in-package "SB!C")
 
-(file-comment
-  "$Header$")
-
 (defun trace-table-entry (state)
+  (declare (special *trace-table-info*))
   (let ((label (gen-label)))
     (emit-label label)
     (push (cons label state) *trace-table-info*))
   (values))
 
-;;; Convert the list of (label . state) entries into an ivector.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defconstant tt-bits-per-state 3)
-  (defconstant tt-bytes-per-entry 2)
-  (defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits))
-  (defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state))
-  (defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset))))
+(def!constant tt-bits-per-state 3)
+(def!constant tt-bytes-per-entry 2)
+(def!constant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:n-byte-bits))
+(def!constant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state))
+(def!constant tt-max-offset (1- (ash 1 tt-bits-per-offset)))
+
 (deftype tt-state ()
   `(unsigned-byte ,tt-bits-per-state))
 (deftype tt-entry ()
   `(unsigned-byte ,tt-bits-per-entry))
 (deftype tt-offset ()
   `(unsigned-byte ,tt-bits-per-offset))
+
+;;; Convert the list of (LABEL . STATE) entries into an ivector.
 (declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table))
 (defun pack-trace-table (entries)
   (declare (list entries))
-  #!-gengc (declare (ignore entries))
-  #!+gengc (let ((result (make-array (logandc2 (1+ (length entries)) 1)
-                                    :element-type 'tt-entry))
-                (index 0)
-                (last-posn 0)
-                (last-state 0))
-            (declare (type index index last-posn)
-            (type tt-state last-state))
-            (flet ((push-entry (offset state)
-                     (declare (type tt-offset offset)
-                              (type tt-state state))
-                     (when (>= index (length result))
-                       (setf result
-                             (replace (make-array
-                                       (truncate (* (length result) 5) 4)
-                                       :element-type
-                                       'tt-entry)
-                                      result)))
-                     (setf (aref result index)
-                           (logior (ash offset tt-bits-per-state) state))
-                     (incf index)))
-              (dolist (entry entries)
-                (let* ((posn (label-position (car entry)))
-                       (state (cdr entry)))
-                  (declare (type index posn) (type tt-state state))
-                  (assert (<= last-posn posn))
-                  (do ((offset (- posn last-posn) (- offset tt-max-offset)))
-                  ((< offset tt-max-offset)
-                   (push-entry offset state))
-                  (push-entry tt-max-offset last-state))
-                  (setf last-posn posn)
-                  (setf last-state state)))
-              (when (oddp index)
-                (push-entry 0 last-state)))
-            (if (eql (length result) index)
-              result
-              (subseq result 0 index)))
-  #!-gengc (make-array 0 :element-type 'tt-entry))
+  (declare (ignore entries))
+  ;; (This was interesting under the old CMU CL generational garbage
+  ;; collector (GENGC) but is trivial under the GC implementations
+  ;; used in SBCL.)
+  (make-array 0 :element-type 'tt-entry))