src/compiler/trace-table.lisp

   1 ;;;; trace tables (from codegen.lisp in CMU CL sources)
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!C")
  13
  14 (defun trace-table-entry (state)
  15   (let ((label (gen-label)))
  16     (emit-label label)
  17     (push (cons label state) *trace-table-info*))
  18   (values))
  19
  20 (defconstant tt-bits-per-state 3)
  21 (defconstant tt-bytes-per-entry 2)
  22 (defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits))
  23 (defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state))
  24 (defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset)))
  25
  26 (deftype tt-state ()
  27   `(unsigned-byte ,tt-bits-per-state))
  28 (deftype tt-entry ()
  29   `(unsigned-byte ,tt-bits-per-entry))
  30 (deftype tt-offset ()
  31   `(unsigned-byte ,tt-bits-per-offset))
  32
  33 ;;; Convert the list of (LABEL . STATE) entries into an ivector.
  34 (declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table))
  35 (defun pack-trace-table (entries)
  36   (declare (list entries))
  37   #!-gengc (declare (ignore entries))
  38   #!+gengc (let ((result (make-array (logandc2 (1+ (length entries)) 1)
  39                                      :element-type 'tt-entry))
  40                  (index 0)
  41                  (last-posn 0)
  42                  (last-state 0))
  43              (declare (type index index last-posn)
  44              (type tt-state last-state))
  45              (flet ((push-entry (offset state)
  46                       (declare (type tt-offset offset)
  47                                (type tt-state state))
  48                       (when (>= index (length result))
  49                         (setf result
  50                               (replace (make-array
  51                                         (truncate (* (length result) 5) 4)
  52                                         :element-type
  53                                         'tt-entry)
  54                                        result)))
  55                       (setf (aref result index)
  56                             (logior (ash offset tt-bits-per-state) state))
  57                       (incf index)))
  58                (dolist (entry entries)
  59                  (let* ((posn (label-position (car entry)))
  60                         (state (cdr entry)))
  61                    (declare (type index posn) (type tt-state state))
  62                    (assert (<= last-posn posn))
  63                    (do ((offset (- posn last-posn) (- offset tt-max-offset)))
  64                    ((< offset tt-max-offset)
  65                     (push-entry offset state))
  66                    (push-entry tt-max-offset last-state))
  67                    (setf last-posn posn)
  68                    (setf last-state state)))
  69                (when (oddp index)
  70                  (push-entry 0 last-state)))
  71              (if (eql (length result) index)
  72                result
  73                (subseq result 0 index)))
  74   #!-gengc (make-array 0 :element-type 'tt-entry))