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