src/compiler/tn.lisp

   1 ;;;; This file contains utilities used for creating and manipulating
   2 ;;;; TNs, and some other more assorted IR2 utilities.
   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!C")
  14
  15 ;;; The component that is currently being compiled. TNs are allocated
  16 ;;; in this component.
  17 (defvar *component-being-compiled*)
  18
  19 (defmacro do-packed-tns ((tn component &optional result) &body body)
  20   #!+sb-doc
  21   "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
  22   Iterate over all packed TNs allocated in Component."
  23   (let ((n-component (gensym)))
  24     `(let ((,n-component (component-info ,component)))
  25        (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
  26            ((null ,tn))
  27          ,@body)
  28        (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
  29            ((null ,tn))
  30          ,@body)
  31        (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
  32            ((null ,tn)
  33             ,result)
  34          ,@body))))
  35 \f
  36 ;;; Remove all TNs with no references from the lists of unpacked TNs. We
  37 ;;; null out the Offset so that nobody will mistake deleted wired TNs for
  38 ;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs
  39 ;;; aren't considered to be unreferenced.
  40 (defun delete-unreferenced-tns (component)
  41   (let* ((2comp (component-info component))
  42          (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
  43                               :element-type 'bit :initial-element 0)))
  44     (labels ((delete-some (getter setter)
  45                (let ((prev nil))
  46                  (do ((tn (funcall getter 2comp) (tn-next tn)))
  47                      ((null tn))
  48                    (cond
  49                     ((or (used-p tn)
  50                          (and (eq (tn-kind tn) :specified-save)
  51                               (used-p (tn-save-tn tn))))
  52                      (setq prev tn))
  53                     (t
  54                      (delete-1 tn prev setter))))))
  55              (used-p (tn)
  56                (or (tn-reads tn) (tn-writes tn)
  57                    (member (tn-kind tn) '(:component :environment))
  58                    (not (zerop (sbit aliases (tn-number tn))))))
  59              (delete-1 (tn prev setter)
  60                (if prev
  61                    (setf (tn-next prev) (tn-next tn))
  62                    (funcall setter (tn-next tn) 2comp))
  63                (setf (tn-offset tn) nil)
  64                (case (tn-kind tn)
  65                  (:environment
  66                   (clear-live tn
  67                               #'ir2-physenv-live-tns
  68                               #'(setf ir2-physenv-live-tns)))
  69                  (:debug-environment
  70                   (clear-live tn
  71                               #'ir2-physenv-debug-live-tns
  72                               #'(setf ir2-physenv-debug-live-tns)))))
  73              (clear-live (tn getter setter)
  74                (let ((env (physenv-info (tn-physenv tn))))
  75                  (funcall setter (delete tn (funcall getter env)) env))))
  76       (declare (inline used-p delete-some delete-1 clear-live))
  77       (delete-some #'ir2-component-alias-tns
  78                    #'(setf ir2-component-alias-tns))
  79       (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
  80           ((null tn))
  81         (setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
  82       (delete-some #'ir2-component-normal-tns
  83                    #'(setf ir2-component-normal-tns))
  84       (delete-some #'ir2-component-restricted-tns
  85                    #'(setf ir2-component-restricted-tns))
  86       (delete-some #'ir2-component-wired-tns
  87                    #'(setf ir2-component-wired-tns))))
  88   (values))
  89 \f
  90 ;;;; TN creation
  91
  92 ;;; Create a packed TN of the specified primitive-type in the
  93 ;;; *COMPONENT-BEING-COMPILED*. We use the SCs from the primitive type
  94 ;;; to determine which SCs it can be packed in.
  95 (defun make-normal-tn (type)
  96   (declare (type primitive-type type))
  97   (let* ((component (component-info *component-being-compiled*))
  98          (res (make-tn (incf (ir2-component-global-tn-counter component))
  99                        :normal type nil)))
 100     (push-in tn-next res (ir2-component-normal-tns component))
 101     res))
 102
 103 ;;; Create a normal packed TN with representation indicated by SCN.
 104 (defun make-representation-tn (ptype scn)
 105   (declare (type primitive-type ptype) (type sc-number scn))
 106   (let* ((component (component-info *component-being-compiled*))
 107          (res (make-tn (incf (ir2-component-global-tn-counter component))
 108                        :normal ptype
 109                        (svref *backend-sc-numbers* scn))))
 110     (push-in tn-next res (ir2-component-normal-tns component))
 111     res))
 112
 113 ;;; Create a TN wired to a particular location in an SC. We set the Offset
 114 ;;; and FSC to record where it goes, and then put it on the current component's
 115 ;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
 116 ;;; temporaries.
 117 (defun make-wired-tn (ptype scn offset)
 118   (declare (type (or primitive-type null) ptype)
 119            (type sc-number scn) (type unsigned-byte offset))
 120   (let* ((component (component-info *component-being-compiled*))
 121          (res (make-tn (incf (ir2-component-global-tn-counter component))
 122                        :normal ptype
 123                        (svref *backend-sc-numbers* scn))))
 124     (setf (tn-offset res) offset)
 125     (push-in tn-next res (ir2-component-wired-tns component))
 126     res))
 127
 128 ;;; Create a packed TN restricted to the SC with number SCN. Ptype is as
 129 ;;; for MAKE-WIRED-TN.
 130 (defun make-restricted-tn (ptype scn)
 131   (declare (type (or primitive-type null) ptype) (type sc-number scn))
 132   (let* ((component (component-info *component-being-compiled*))
 133          (res (make-tn (incf (ir2-component-global-tn-counter component))
 134                        :normal ptype
 135                        (svref *backend-sc-numbers* scn))))
 136     (push-in tn-next res (ir2-component-restricted-tns component))
 137     res))
 138
 139 ;;; Make TN be live throughout environment. Return TN. In the DEBUG
 140 ;;; case, the TN is treated normally in blocks in the environment
 141 ;;; which reference the TN, allowing targeting to/from the TN. This
 142 ;;; results in move efficient code, but may result in the TN sometimes
 143 ;;; not being live when you want it.
 144 (defun physenv-live-tn (tn env)
 145   (declare (type tn tn) (type physenv env))
 146   (aver (eq (tn-kind tn) :normal))
 147   (setf (tn-kind tn) :environment)
 148   (setf (tn-physenv tn) env)
 149   (push tn (ir2-physenv-live-tns (physenv-info env)))
 150   tn)
 151 (defun physenv-debug-live-tn (tn env)
 152   (declare (type tn tn) (type physenv env))
 153   (aver (eq (tn-kind tn) :normal))
 154   (setf (tn-kind tn) :debug-environment)
 155   (setf (tn-physenv tn) env)
 156   (push tn (ir2-physenv-debug-live-tns (physenv-info env)))
 157   tn)
 158
 159 ;;; Make TN be live throughout the current component. Return TN.
 160 (defun component-live-tn (tn)
 161   (declare (type tn tn))
 162   (aver (eq (tn-kind tn) :normal))
 163   (setf (tn-kind tn) :component)
 164   (push tn (ir2-component-component-tns (component-info
 165                                          *component-being-compiled*)))
 166   tn)
 167
 168 ;;; Specify that Save be used as the save location for TN. TN is returned.
 169 (defun specify-save-tn (tn save)
 170   (declare (type tn tn save))
 171   (aver (eq (tn-kind save) :normal))
 172   (aver (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
 173   (setf (tn-kind save) :specified-save)
 174   (setf (tn-save-tn tn) save)
 175   (setf (tn-save-tn save) tn)
 176   (push save
 177         (ir2-component-specified-save-tns
 178          (component-info *component-being-compiled*)))
 179   tn)
 180
 181 ;;; Create a constant TN. The implementation dependent
 182 ;;; Immediate-Constant-SC function is used to determine whether the constant
 183 ;;; has an immediate representation.
 184 (defun make-constant-tn (constant)
 185   (declare (type constant constant))
 186   (let* ((component (component-info *component-being-compiled*))
 187          (immed (immediate-constant-sc (constant-value constant)))
 188          (sc (svref *backend-sc-numbers*
 189                     (or immed (sc-number-or-lose 'constant))))
 190          (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
 191     (unless immed
 192       (let ((constants (ir2-component-constants component)))
 193         (setf (tn-offset res) (fill-pointer constants))
 194         (vector-push-extend constant constants)))
 195     (push-in tn-next res (ir2-component-constant-tns component))
 196     (setf (tn-leaf res) constant)
 197     res))
 198
 199 (defun make-load-time-value-tn (handle type)
 200   (let* ((component (component-info *component-being-compiled*))
 201          (sc (svref *backend-sc-numbers*
 202                     (sc-number-or-lose 'constant)))
 203          (res (make-tn 0 :constant (primitive-type type) sc))
 204          (constants (ir2-component-constants component)))
 205     (setf (tn-offset res) (fill-pointer constants))
 206     (vector-push-extend (cons :load-time-value handle) constants)
 207     (push-in tn-next res (ir2-component-constant-tns component))
 208     res))
 209
 210 ;;; Make a TN that aliases TN for use in local call argument passing.
 211 (defun make-alias-tn (tn)
 212   (declare (type tn tn))
 213   (let* ((component (component-info *component-being-compiled*))
 214          (res (make-tn (incf (ir2-component-global-tn-counter component))
 215                        :alias (tn-primitive-type tn) nil)))
 216     (setf (tn-save-tn res) tn)
 217     (push-in tn-next res
 218              (ir2-component-alias-tns component))
 219     res))
 220
 221 ;;; Return a load-time constant TN with the specified Kind and Info. If the
 222 ;;; desired Constants entry already exists, then reuse it, otherwise allocate a
 223 ;;; new load-time constant slot.
 224 (defun make-load-time-constant-tn (kind info)
 225   (declare (type keyword kind))
 226   (let* ((component (component-info *component-being-compiled*))
 227          (res (make-tn 0
 228                        :constant
 229                        *backend-t-primitive-type*
 230                        (svref *backend-sc-numbers*
 231                               (sc-number-or-lose 'constant))))
 232          (constants (ir2-component-constants component)))
 233
 234     (do ((i 0 (1+ i)))
 235         ((= i (length constants))
 236          (setf (tn-offset res) i)
 237          (vector-push-extend (cons kind info) constants))
 238       (let ((entry (aref constants i)))
 239         (when (and (consp entry)
 240                    (eq (car entry) kind)
 241                    (or (eq (cdr entry) info)
 242                        (and (consp info)
 243                             (equal (cdr entry) info))))
 244           (setf (tn-offset res) i)
 245           (return))))
 246
 247     (push-in tn-next res (ir2-component-constant-tns component))
 248     res))
 249 \f
 250 ;;;; TN referencing
 251
 252 ;;; Make a TN-Ref that references TN and return it. Write-P should be true
 253 ;;; if this is a write reference, otherwise false. All we do other than
 254 ;;; calling the constructor is add the reference to the TN's references.
 255 (defun reference-tn (tn write-p)
 256   (declare (type tn tn) (type boolean write-p))
 257   (let ((res (make-tn-ref tn write-p)))
 258     (if write-p
 259         (push-in tn-ref-next res (tn-writes tn))
 260         (push-in tn-ref-next res (tn-reads tn)))
 261     res))
 262
 263 ;;; Make TN-Refs to reference each TN in TNs, linked together by
 264 ;;; TN-Ref-Across. Write-P is the Write-P value for the refs. More is
 265 ;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
 266 ;;; result if there are no TNs.
 267 (defun reference-tn-list (tns write-p &optional more)
 268   (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
 269   (if tns
 270       (let* ((first (reference-tn (first tns) write-p))
 271              (prev first))
 272         (dolist (tn (rest tns))
 273           (let ((res (reference-tn tn write-p)))
 274             (setf (tn-ref-across prev) res)
 275             (setq prev res)))
 276         (setf (tn-ref-across prev) more)
 277         first)
 278       more))
 279
 280 ;;; Remove Ref from the references for its associated TN.
 281 (defun delete-tn-ref (ref)
 282   (declare (type tn-ref ref))
 283   (if (tn-ref-write-p ref)
 284       (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
 285       (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
 286   (values))
 287
 288 ;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
 289 ;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
 290 (defun change-tn-ref-tn (ref tn)
 291   (declare (type tn-ref ref) (type tn tn))
 292   (delete-tn-ref ref)
 293   (setf (tn-ref-tn ref) tn)
 294   (if (tn-ref-write-p ref)
 295       (push-in tn-ref-next ref (tn-writes tn))
 296       (push-in tn-ref-next ref (tn-reads tn)))
 297   (values))
 298 \f
 299 ;;;; miscellaneous utilities
 300
 301 ;;; Emit a move-like template determined at run-time, with X as the
 302 ;;; argument and Y as the result. Useful for move, coerce and
 303 ;;; type-check templates. If supplied, then insert before VOP,
 304 ;;; otherwise insert at then end of the block. Returns the last VOP
 305 ;;; inserted.
 306 (defun emit-move-template (node block template x y &optional before)
 307   (declare (type node node) (type ir2-block block)
 308            (type template template) (type tn x y))
 309   (let ((arg (reference-tn x nil))
 310         (result (reference-tn y t)))
 311     (multiple-value-bind (first last)
 312         (funcall (template-emit-function template) node block template arg
 313                  result)
 314       (insert-vop-sequence first last block before)
 315       last)))
 316
 317 ;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
 318 (defun emit-load-template (node block template x y info &optional before)
 319   (declare (type node node) (type ir2-block block)
 320            (type template template) (type tn x y))
 321   (let ((arg (reference-tn x nil))
 322         (result (reference-tn y t)))
 323     (multiple-value-bind (first last)
 324         (funcall (template-emit-function template) node block template arg
 325                  result info)
 326       (insert-vop-sequence first last block before)
 327       last)))
 328
 329 ;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
 330 (defun emit-move-arg-template (node block template x f y &optional before)
 331   (declare (type node node) (type ir2-block block)
 332            (type template template) (type tn x f y))
 333   (let ((x-ref (reference-tn x nil))
 334         (f-ref (reference-tn f nil))
 335         (y-ref (reference-tn y t)))
 336     (setf (tn-ref-across x-ref) f-ref)
 337     (multiple-value-bind (first last)
 338         (funcall (template-emit-function template) node block template x-ref
 339                  y-ref)
 340       (insert-vop-sequence first last block before)
 341       last)))
 342
 343 ;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
 344 (defun emit-context-template (node block template y &optional before)
 345   (declare (type node node) (type ir2-block block)
 346            (type template template) (type tn y))
 347   (let ((y-ref (reference-tn y t)))
 348     (multiple-value-bind (first last)
 349         (funcall (template-emit-function template) node block template nil
 350                  y-ref)
 351       (insert-vop-sequence first last block before)
 352       last)))
 353
 354 ;;; Return the label marking the start of Block, assigning one if necessary.
 355 (defun block-label (block)
 356   (declare (type cblock block))
 357   (let ((2block (block-info block)))
 358     (or (ir2-block-%label 2block)
 359         (setf (ir2-block-%label 2block) (gen-label)))))
 360
 361 ;;; Return true if Block is emitted immediately after the block ended by Node.
 362 (defun drop-thru-p (node block)
 363   (declare (type node node) (type cblock block))
 364   (let ((next-block (ir2-block-next (block-info (node-block node)))))
 365     (aver (eq node (block-last (node-block node))))
 366     (eq next-block (block-info block))))
 367
 368 ;;; Link a list of VOPs from First to Last into Block, Before the specified
 369 ;;; VOP. If Before is NIL, insert at the end.
 370 (defun insert-vop-sequence (first last block before)
 371   (declare (type vop first last) (type ir2-block block)
 372            (type (or vop null) before))
 373   (if before
 374       (let ((prev (vop-prev before)))
 375         (setf (vop-prev first) prev)
 376         (if prev
 377             (setf (vop-next prev) first)
 378             (setf (ir2-block-start-vop block) first))
 379         (setf (vop-next last) before)
 380         (setf (vop-prev before) last))
 381       (let ((current (ir2-block-last-vop block)))
 382         (setf (vop-prev first) current)
 383         (setf (ir2-block-last-vop block) last)
 384         (if current
 385             (setf (vop-next current) first)
 386             (setf (ir2-block-start-vop block) first))))
 387   (values))
 388
 389 ;;; Delete all of the TN-Refs associated with VOP and remove VOP from the IR2.
 390 (defun delete-vop (vop)
 391   (declare (type vop vop))
 392   (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
 393       ((null ref))
 394     (delete-tn-ref ref))
 395
 396   (let ((prev (vop-prev vop))
 397         (next (vop-next vop))
 398         (block (vop-block vop)))
 399     (if prev
 400         (setf (vop-next prev) next)
 401         (setf (ir2-block-start-vop block) next))
 402     (if next
 403         (setf (vop-prev next) prev)
 404         (setf (ir2-block-last-vop block) prev)))
 405
 406   (values))
 407
 408 ;;; Return a list of N normal TNs of the specified primitive type.
 409 (defun make-n-tns (n ptype)
 410   (declare (type unsigned-byte n) (type primitive-type ptype))
 411   (collect ((res))
 412     (dotimes (i n)
 413       (res (make-normal-tn ptype)))
 414     (res)))
 415
 416 ;;; Return true if X and Y are packed in the same location, false otherwise.
 417 ;;; This is false if either operand is constant.
 418 (defun location= (x y)
 419   (declare (type tn x y))
 420   (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
 421        (eql (tn-offset x) (tn-offset y))
 422        (not (or (eq (tn-kind x) :constant)
 423                 (eq (tn-kind y) :constant)))))
 424
 425 ;;; Return the value of an immediate constant TN.
 426 (defun tn-value (tn)
 427   (declare (type tn tn))
 428   (aver (member (tn-kind tn) '(:constant :cached-constant)))
 429   (constant-value (tn-leaf tn)))
 430
 431 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
 432 ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
 433 ;;; but since we change the SC to an unbounded one, we should always succeed in
 434 ;;; packing it in that SC.
 435 (defun force-tn-to-stack (tn)
 436   (declare (type tn tn))
 437   (let ((sc (tn-sc tn)))
 438     (unless (and (not (sc-save-p sc))
 439                  (eq (sb-kind (sc-sb sc)) :unbounded))
 440       (dolist (alt (sc-alternate-scs sc)
 441                    (error "SC ~S has no :unbounded :save-p NIL alternate SC."
 442                           (sc-name sc)))
 443         (when (and (not (sc-save-p alt))
 444                    (eq (sb-kind (sc-sb alt)) :unbounded))
 445           (setf (tn-sc tn) alt)
 446           (return)))))
 447   (values))
 448