1 ;;;; trace tables (from codegen.lisp in CMU CL sources)
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
17 (defun trace-table-entry (state)
18 (let ((label (gen-label)))
20 (push (cons label state) *trace-table-info*))
23 ;;; Convert the list of (label . state) entries into an ivector.
24 (eval-when (:compile-toplevel :load-toplevel :execute)
25 (defconstant tt-bits-per-state 3)
26 (defconstant tt-bytes-per-entry 2)
27 (defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits))
28 (defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state))
29 (defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset))))
31 `(unsigned-byte ,tt-bits-per-state))
33 `(unsigned-byte ,tt-bits-per-entry))
35 `(unsigned-byte ,tt-bits-per-offset))
36 (declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table))
37 (defun pack-trace-table (entries)
38 (declare (list entries))
39 #!-gengc (declare (ignore entries))
40 #!+gengc (let ((result (make-array (logandc2 (1+ (length entries)) 1)
41 :element-type 'tt-entry))
45 (declare (type index index last-posn)
46 (type tt-state last-state))
47 (flet ((push-entry (offset state)
48 (declare (type tt-offset offset)
49 (type tt-state state))
50 (when (>= index (length result))
53 (truncate (* (length result) 5) 4)
57 (setf (aref result index)
58 (logior (ash offset tt-bits-per-state) state))
60 (dolist (entry entries)
61 (let* ((posn (label-position (car entry)))
63 (declare (type index posn) (type tt-state state))
64 (assert (<= last-posn posn))
65 (do ((offset (- posn last-posn) (- offset tt-max-offset)))
66 ((< offset tt-max-offset)
67 (push-entry offset state))
68 (push-entry tt-max-offset last-state))
70 (setf last-state state)))
72 (push-entry 0 last-state)))
73 (if (eql (length result) index)
75 (subseq result 0 index)))
76 #!-gengc (make-array 0 :element-type 'tt-entry))