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 ;;; 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))))
  27 (deftype tt-state ()
  28   `(unsigned-byte ,tt-bits-per-state))
  29 (deftype tt-entry ()
  30   `(unsigned-byte ,tt-bits-per-entry))
  31 (deftype tt-offset ()
  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))
  39                  (index 0)
  40                  (last-posn 0)
  41                  (last-state 0))
  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))
  48                         (setf result
  49                               (replace (make-array
  50                                         (truncate (* (length result) 5) 4)
  51                                         :element-type
  52                                         'tt-entry)
  53                                        result)))
  54                       (setf (aref result index)
  55                             (logior (ash offset tt-bits-per-state) state))
  56                       (incf index)))
  57                (dolist (entry entries)
  58                  (let* ((posn (label-position (car entry)))
  59                         (state (cdr 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))
  66                    (setf last-posn posn)
  67                    (setf last-state state)))
  68                (when (oddp index)
  69                  (push-entry 0 last-state)))
  70              (if (eql (length result) index)
  71                result
  72                (subseq result 0 index)))
  73   #!-gengc (make-array 0 :element-type 'tt-entry))