src/compiler/generic/utils.lisp

   1 ;;;; utility functions and macros needed by the back end to generate
   2 ;;;; code
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14 \f
  15 ;;; Make a fixnum out of NUM. (I.e. shift by two bits if it will fit.)
  16 (defun fixnumize (num)
  17   (if (fixnump num)
  18       (ash num n-fixnum-tag-bits)
  19       (error "~W is too big for a fixnum." num)))
  20
  21 ;;; Determining whether a constant offset fits in an addressing mode.
  22 #!+(or x86 x86-64)
  23 (defun foldable-constant-offset-p (element-size lowtag data-offset offset)
  24   (if (< element-size n-byte-bits)
  25       nil
  26       (multiple-value-bind (min max)
  27           (sb!impl::displacement-bounds lowtag element-size data-offset)
  28         (<= min offset max))))
  29
  30 \f
  31 ;;;; routines for dealing with static symbols
  32
  33 (defun static-symbol-p (symbol)
  34   (or (null symbol)
  35       (and (find symbol +static-symbols+) t)))
  36
  37 ;;; the byte offset of the static symbol SYMBOL
  38 (defun static-symbol-offset (symbol)
  39   (if symbol
  40       (let ((posn (position symbol +static-symbols+)))
  41         (unless posn (error "~S is not a static symbol." symbol))
  42         (+ (* posn (pad-data-block symbol-size))
  43            (pad-data-block (1- symbol-size))
  44            other-pointer-lowtag
  45            (- list-pointer-lowtag)))
  46       0))
  47
  48 ;;; Return the (byte) offset from NIL to the start of the fdefn object
  49 ;;; for the static function NAME.
  50 (defun static-fdefn-offset (name)
  51   (let ((static-fun-index
  52          (or (position name #.(concatenate 'vector +c-callable-fdefns+ +static-fdefns+))
  53              (error "~S isn't a static function." name))))
  54     (+ (* (length +static-symbols+) (pad-data-block symbol-size))
  55        (pad-data-block (1- symbol-size))
  56        (- list-pointer-lowtag)
  57        (* static-fun-index (pad-data-block fdefn-size))
  58        other-pointer-lowtag)))
  59
  60 ;;; Return absolute address of the 'fun' slot in static fdefn NAME.
  61 (defun static-fdefn-fun-addr (name)
  62   (+ nil-value
  63      (static-fdefn-offset name)
  64      (- other-pointer-lowtag)
  65      (ash fdefn-fun-slot word-shift)))
  66
  67 ;;; Return the (byte) offset from NIL to the raw-addr slot of the
  68 ;;; fdefn object for the static function NAME.
  69 (defun static-fun-offset (name)
  70   (+ (static-fdefn-offset name)
  71      (- other-pointer-lowtag)
  72      (* fdefn-raw-addr-slot n-word-bytes)))
  73 \f
  74 ;;; Various error-code generating helpers
  75 (defvar *adjustable-vectors* nil)
  76
  77 (defmacro with-adjustable-vector ((var) &rest body)
  78   `(let ((,var (or (pop *adjustable-vectors*)
  79                    (make-array 16
  80                                :element-type '(unsigned-byte 8)
  81                                :fill-pointer 0
  82                                :adjustable t))))
  83      ;; Don't declare the length - if it gets adjusted and pushed back
  84      ;; onto the freelist, it's anyone's guess whether it was expanded.
  85      ;; This code was wrong for >12 years, so nobody must have needed
  86      ;; more than 16 elements. Maybe we should make it nonadjustable?
  87      (declare (type (vector (unsigned-byte 8)) ,var))
  88      (setf (fill-pointer ,var) 0)
  89      (unwind-protect
  90          (progn
  91            ,@body)
  92        (push ,var *adjustable-vectors*))))
  93
  94 ;;;; interfaces to IR2 conversion
  95
  96 ;;; Return a wired TN describing the N'th full call argument passing
  97 ;;; location.
  98 (defun standard-arg-location (n)
  99   (declare (type unsigned-byte n))
 100   (if (< n register-arg-count)
 101       (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
 102                      (nth n *register-arg-offsets*))
 103       (make-wired-tn *backend-t-primitive-type* control-stack-sc-number n)))
 104
 105 (defun standard-arg-location-sc (n)
 106   (declare (type unsigned-byte n))
 107   (if (< n register-arg-count)
 108       (make-sc-offset descriptor-reg-sc-number
 109                       (nth n *register-arg-offsets*))
 110       (make-sc-offset control-stack-sc-number n)))
 111
 112 ;;; Make a TN to hold the number-stack frame pointer.  This is allocated
 113 ;;; once per component, and is component-live.
 114 (defun make-nfp-tn ()
 115   #!+c-stack-is-control-stack
 116   (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)
 117   #!-c-stack-is-control-stack
 118   (component-live-tn
 119    (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
 120
 121 ;;; Make an environment-live stack TN for saving the SP for NLX entry.
 122 (defun make-nlx-sp-tn (env)
 123   (physenv-live-tn
 124    (make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
 125    env))
 126
 127 (defun make-stack-pointer-tn ()
 128   (make-normal-tn *fixnum-primitive-type*))
 129
 130 (defun make-number-stack-pointer-tn ()
 131   #!+c-stack-is-control-stack
 132   (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)
 133   #!-c-stack-is-control-stack
 134   (make-normal-tn *fixnum-primitive-type*))
 135
 136 ;;; Return a list of TNs that can be used to represent an unknown-values
 137 ;;; continuation within a function.
 138 (defun make-unknown-values-locations ()
 139   (list (make-stack-pointer-tn)
 140         (make-normal-tn *fixnum-primitive-type*)))
 141
 142 ;;; This function is called by the ENTRY-ANALYZE phase, allowing
 143 ;;; VM-dependent initialization of the IR2-COMPONENT structure. We
 144 ;;; push placeholder entries in the CONSTANTS to leave room for
 145 ;;; additional noise in the code object header.
 146 (defun select-component-format (component)
 147   (declare (type component component))
 148   (dotimes (i code-constants-offset)
 149     (vector-push-extend nil
 150                         (ir2-component-constants (component-info component))))
 151   (values))
 152
 153