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 (file-comment
  15   "$Header$")
  16
  17 (defun trace-table-entry (state)
  18   (let ((label (gen-label)))
  19     (emit-label label)
  20     (push (cons label state) *trace-table-info*))
  21   (values))
  22
  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))))
  30 (deftype tt-state ()
  31   `(unsigned-byte ,tt-bits-per-state))
  32 (deftype tt-entry ()
  33   `(unsigned-byte ,tt-bits-per-entry))
  34 (deftype tt-offset ()
  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))
  42                  (index 0)
  43                  (last-posn 0)
  44                  (last-state 0))
  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))
  51                         (setf result
  52                               (replace (make-array
  53                                         (truncate (* (length result) 5) 4)
  54                                         :element-type
  55                                         'tt-entry)
  56                                        result)))
  57                       (setf (aref result index)
  58                             (logior (ash offset tt-bits-per-state) state))
  59                       (incf index)))
  60                (dolist (entry entries)
  61                  (let* ((posn (label-position (car entry)))
  62                         (state (cdr 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))
  69                    (setf last-posn posn)
  70                    (setf last-state state)))
  71                (when (oddp index)
  72                  (push-entry 0 last-state)))
  73              (if (eql (length result) index)
  74                result
  75                (subseq result 0 index)))
  76   #!-gengc (make-array 0 :element-type 'tt-entry))