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.
14 (defun trace-table-entry (state)
15 (let ((label (gen-label)))
17 (push (cons label state) *trace-table-info*))
20 ;;; Convert the list of (label . state) entries into an ivector.
21 (eval-when (:compile-toplevel :load-toplevel :execute)
22 (defconstant tt-bits-per-state 3)
23 (defconstant tt-bytes-per-entry 2)
24 (defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits))
25 (defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state))
26 (defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset))))
28 `(unsigned-byte ,tt-bits-per-state))
30 `(unsigned-byte ,tt-bits-per-entry))
32 `(unsigned-byte ,tt-bits-per-offset))
33 (declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table))
34 (defun pack-trace-table (entries)
35 (declare (list entries))
36 #!-gengc (declare (ignore entries))
37 #!+gengc (let ((result (make-array (logandc2 (1+ (length entries)) 1)
38 :element-type 'tt-entry))
42 (declare (type index index last-posn)
43 (type tt-state last-state))
44 (flet ((push-entry (offset state)
45 (declare (type tt-offset offset)
46 (type tt-state state))
47 (when (>= index (length result))
50 (truncate (* (length result) 5) 4)
54 (setf (aref result index)
55 (logior (ash offset tt-bits-per-state) state))
57 (dolist (entry entries)
58 (let* ((posn (label-position (car entry)))
60 (declare (type index posn) (type tt-state state))
61 (assert (<= last-posn posn))
62 (do ((offset (- posn last-posn) (- offset tt-max-offset)))
63 ((< offset tt-max-offset)
64 (push-entry offset state))
65 (push-entry tt-max-offset last-state))
67 (setf last-state state)))
69 (push-entry 0 last-state)))
70 (if (eql (length result) index)
72 (subseq result 0 index)))
73 #!-gengc (make-array 0 :element-type 'tt-entry))