src/compiler/codegen.lisp

   1 ;;;; the implementation-independent parts of the code generator. We use
   2 ;;;; functions and information provided by the VM definition to convert
   3 ;;;; IR2 into assembly code. After emitting code, we finish the
   4 ;;;; assembly and then do the post-assembly phase.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!C")
  16 \f
  17 ;;;; utilities used during code generation
  18
  19 ;;; the number of bytes used by the code object header
  20 (defun component-header-length (&optional
  21                                 (component *component-being-compiled*))
  22   (let* ((2comp (component-info component))
  23          (constants (ir2-component-constants 2comp))
  24          (num-consts (length constants)))
  25     (ash (logandc2 (1+ num-consts) 1) sb!vm:word-shift)))
  26
  27 ;;; the size of the NAME'd SB in the currently compiled component.
  28 ;;; This is useful mainly for finding the size for allocating stack
  29 ;;; frames.
  30 (defun sb-allocated-size (name)
  31   (finite-sb-current-size (sb-or-lose name)))
  32
  33 ;;; the TN that is used to hold the number stack frame-pointer in
  34 ;;; VOP's function, or NIL if no number stack frame was allocated
  35 (defun current-nfp-tn (vop)
  36   (unless (zerop (sb-allocated-size 'non-descriptor-stack))
  37     (let ((block (ir2-block-block (vop-block vop))))
  38     (when (ir2-physenv-number-stack-p
  39            (physenv-info
  40             (block-physenv block)))
  41       (ir2-component-nfp (component-info (block-component block)))))))
  42
  43 ;;; the TN that is used to hold the number stack frame-pointer in the
  44 ;;; function designated by 2ENV, or NIL if no number stack frame was
  45 ;;; allocated
  46 (defun callee-nfp-tn (2env)
  47   (unless (zerop (sb-allocated-size 'non-descriptor-stack))
  48     (when (ir2-physenv-number-stack-p 2env)
  49       (ir2-component-nfp (component-info *component-being-compiled*)))))
  50
  51 ;;; the TN used for passing the return PC in a local call to the function
  52 ;;; designated by 2ENV
  53 (defun callee-return-pc-tn (2env)
  54   (ir2-physenv-return-pc-pass 2env))
  55 \f
  56 ;;;; specials used during code generation
  57
  58 (defvar *code-segment* nil)
  59 (defvar *elsewhere* nil)
  60 (defvar *elsewhere-label* nil)
  61 \f
  62 ;;;; noise to emit an instruction trace
  63
  64 (defvar *prev-segment*)
  65 (defvar *prev-vop*)
  66
  67 (defun trace-instruction (segment vop inst &rest args)
  68   (declare (dynamic-extent args))
  69   (let ((*standard-output* *compiler-trace-output*))
  70     (unless (eq *prev-segment* segment)
  71       (format t "in the ~A segment:~%" (sb!assem:segment-type segment))
  72       (setf *prev-segment* segment))
  73     (unless (eq *prev-vop* vop)
  74       (when vop
  75         (format t "~%VOP ")
  76         (if (vop-p vop)
  77             (print-vop vop)
  78             (format *compiler-trace-output* "~S~%" vop)))
  79       (terpri)
  80       (setf *prev-vop* vop))
  81     (case inst
  82       (:label
  83        (format t "~A:~%" (car args)))
  84       (:align
  85        (format t "~0,8T.align~0,8T~A~%" (car args)))
  86       (t
  87        (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args))))
  88   (values))
  89 \f
  90 ;;;; GENERATE-CODE and support routines
  91
  92 ;;; standard defaults for slots of SEGMENT objects
  93 (defun default-segment-run-scheduler ()
  94   (and *assembly-optimize*
  95         (policy (lambda-bind
  96                  (block-home-lambda
  97                   (block-next (component-head *component-being-compiled*))))
  98                 (or (> speed compilation-speed) (> space compilation-speed)))))
  99 (defun default-segment-inst-hook ()
 100   (and *compiler-trace-output*
 101        #'trace-instruction))
 102
 103 (defun init-assembler ()
 104   (setf *code-segment*
 105         (sb!assem:make-segment :type :regular
 106                                :run-scheduler (default-segment-run-scheduler)
 107                                :inst-hook (default-segment-inst-hook)))
 108   #!+sb-dyncount
 109   (setf (sb!assem:segment-collect-dynamic-statistics *code-segment*)
 110         *collect-dynamic-statistics*)
 111   (setf *elsewhere*
 112         (sb!assem:make-segment :type :elsewhere
 113                                :run-scheduler (default-segment-run-scheduler)
 114                                :inst-hook (default-segment-inst-hook)
 115                                :alignment 0))
 116   #!+inline-constants
 117   (setf *unboxed-constants* (make-unboxed-constants))
 118   (values))
 119
 120 #!+inline-constants
 121 (defun emit-inline-constants (&aux (constant-holder *unboxed-constants*)
 122                                    (vector (constant-vector constant-holder)))
 123   (setf *unboxed-constants* nil)
 124   (unless (zerop (length vector))
 125     (let ((constants (sb!vm:sort-inline-constants vector)))
 126       (assemble ((constant-segment constant-holder))
 127         (map nil (lambda (constant)
 128                    (sb!vm:emit-inline-constant (car constant) (cdr constant)))
 129              constants))))
 130   ;; Always append the constant segment, because a zero-length vector
 131   ;; does not imply absence of unboxed data.
 132   ;; In particular the simple-fun offsets are in there.
 133   (setf *code-segment* (let ((seg (constant-segment constant-holder)))
 134                          (sb!assem:append-segment seg *code-segment*)
 135                          seg)))
 136
 137 ;;; If a constant is already loaded into a register use that register.
 138 (defun optimize-constant-loads (component)
 139   (let* ((register-sb (sb-or-lose 'sb!vm::registers))
 140          (loaded-constants
 141            (make-array (sb-size register-sb)
 142                        :initial-element nil)))
 143     (do-ir2-blocks (block component)
 144       (fill loaded-constants nil)
 145       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 146           ((null vop))
 147         (labels ((register-p (tn)
 148                    (and (tn-p tn)
 149                         (eq (sc-sb (tn-sc tn)) register-sb)))
 150                  (constant-eql-p (a b)
 151                    (or (eq a b)
 152                        (and (eq (sc-name (tn-sc a)) 'constant)
 153                             (eq (tn-sc a) (tn-sc b))
 154                             (eql (tn-offset a) (tn-offset b)))))
 155                  (remove-constant (tn)
 156                    (when (register-p tn)
 157                      (setf (svref loaded-constants (tn-offset tn)) nil)))
 158                  (remove-written-tns ()
 159                    (cond ((memq (vop-info-save-p (vop-info vop))
 160                                 '(t :force-to-stack))
 161                           (fill loaded-constants nil))
 162                          (t
 163                           (do ((ref (vop-results vop) (tn-ref-across ref)))
 164                               ((null ref))
 165                             (remove-constant (tn-ref-tn ref))
 166                             (remove-constant (tn-ref-load-tn ref)))
 167                           (do ((ref (vop-temps vop) (tn-ref-across ref)))
 168                               ((null ref))
 169                             (remove-constant (tn-ref-tn ref)))
 170                           (do ((ref (vop-args vop) (tn-ref-across ref)))
 171                               ((null ref))
 172                             (remove-constant (tn-ref-load-tn ref))))))
 173                  (compatible-scs-p (a b)
 174                    (or (eql a b)
 175                        (and (eq (sc-name a) 'sb!vm::control-stack)
 176                             (eq (sc-name b) 'sb!vm::descriptor-reg))
 177                        (and (eq (sc-name b) 'sb!vm::control-stack)
 178                             (eq (sc-name a) 'sb!vm::descriptor-reg))))
 179                  (find-constant-tn (constant sc)
 180                    (loop for (saved-constant . tn) across loaded-constants
 181                          when (and saved-constant
 182                                    (constant-eql-p saved-constant constant)
 183                                    (compatible-scs-p (tn-sc tn) sc))
 184                          return tn)))
 185           (case (vop-name vop)
 186             ((move sb!vm::move-arg)
 187              (let* ((args (vop-args vop))
 188                     (x (tn-ref-tn args))
 189                     (y (tn-ref-tn (vop-results vop)))
 190                     constant)
 191                (cond ((and (eq (vop-name vop) 'move)
 192                            (location= x y))
 193                       ;; Helps subsequent optimization of adjacent VOPs
 194                       (delete-vop vop))
 195                      ((or (eq (sc-name (tn-sc x)) 'null)
 196                           (not (eq (tn-kind x) :constant)))
 197                       (remove-written-tns))
 198                      ((setf constant (find-constant-tn x (tn-sc y)))
 199                       (when (register-p y)
 200                         (setf (svref loaded-constants (tn-offset y))
 201                               (cons x y)))
 202                       ;; XOR is more compact on x86oids and many
 203                       ;; RISCs have a zero register
 204                       (unless (and (constant-p (tn-leaf x))
 205                                    (eql (tn-value x) 0)
 206                                    (register-p y))
 207                         (setf (tn-ref-tn args) constant)
 208                         (setf (tn-ref-load-tn args) nil)))
 209                      ((register-p y)
 210                       (setf (svref loaded-constants (tn-offset y))
 211                             (cons x y)))
 212                      (t
 213                       (remove-written-tns)))))
 214             (t
 215              (remove-written-tns))))))))
 216
 217 (defun generate-code (component)
 218   (when *compiler-trace-output*
 219     (format *compiler-trace-output*
 220             "~|~%assembly code for ~S~2%"
 221             component))
 222   (let ((prev-env nil)
 223         (*prev-segment* nil)
 224         (*prev-vop* nil)
 225         (*fixup-notes* nil))
 226     (let ((label (sb!assem:gen-label)))
 227       (setf *elsewhere-label* label)
 228       (sb!assem:assemble (*elsewhere*)
 229         (sb!assem:emit-label label)))
 230     ;; Leave space for the unboxed words containing simple-fun offsets.
 231     ;; Each offset is a 32-bit integer. On 64-bit platforms, 1 offset
 232     ;; is stored in the header word as a 16-bit integer.
 233     ;; On 32-bit platforms there is an extra boxed slot in the code oject.
 234     (let* ((n-entries (length (ir2-component-entries (component-info component))))
 235            (ptrs-per-word (/ sb!vm:n-word-bytes 4)) ; either 1 or 2
 236            (n-words (ceiling (1- n-entries) ptrs-per-word)))
 237       (emit-skip #!-inline-constants *code-segment*
 238                  #!+inline-constants (constant-segment *unboxed-constants*)
 239                  ;; Preserve double-word alignment of the unboxed constants
 240                  (sb!vm:pad-data-block n-words)))
 241     ;;
 242     (do-ir2-blocks (block component)
 243       (let ((1block (ir2-block-block block)))
 244         (when (and (eq (block-info 1block) block)
 245                    (block-start 1block))
 246           (sb!assem:assemble (*code-segment*)
 247             ;; Align first emitted block of each loop: x86 and x86-64 both
 248             ;; like 16 byte alignment, however, since x86 aligns code objects
 249             ;; on 8 byte boundaries we cannot guarantee proper loop alignment
 250             ;; there (yet.)  Only x86-64 does something with ALIGNP, but
 251             ;; it may be useful in the future.
 252             (let ((alignp (let ((cloop (block-loop 1block)))
 253                             (when (and cloop
 254                                        (loop-tail cloop)
 255                                        (not (loop-info cloop)))
 256                               ;; Mark the loop as aligned by saving the IR1 block aligned.
 257                               (setf (loop-info cloop) 1block)
 258                               t))))
 259               (emit-block-header (block-label 1block)
 260                                  (ir2-block-%trampoline-label block)
 261                                  (ir2-block-dropped-thru-to block)
 262                                  alignp)))
 263           (let ((env (block-physenv 1block)))
 264             (unless (eq env prev-env)
 265               (let ((lab (gen-label)))
 266                 (setf (ir2-physenv-elsewhere-start (physenv-info env))
 267                       lab)
 268                 (emit-label-elsewhere lab))
 269               (setq prev-env env)))))
 270       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 271           ((null vop))
 272         (let ((gen (vop-info-generator-function (vop-info vop))))
 273           (cond ((not gen)
 274                  (format t
 275                          "missing generator for ~S~%"
 276                          (template-name (vop-info vop))))
 277                 #!+arm64
 278                 ((and (vop-next vop)
 279                       (eq (vop-name vop)
 280                           (vop-name (vop-next vop)))
 281                       (memq (vop-name vop) '(move move-operand sb!vm::move-arg))
 282                       (sb!vm::load-store-two-words vop (vop-next vop)))
 283                  (setf vop (vop-next vop)))
 284                 (t
 285                  (funcall gen vop))))))
 286     (sb!assem:append-segment *code-segment* *elsewhere*)
 287     (setf *elsewhere* nil)
 288     #!+inline-constants
 289     (emit-inline-constants)
 290     (values (sb!assem:finalize-segment *code-segment*)
 291             *fixup-notes*)))
 292
 293 (defun emit-label-elsewhere (label)
 294   (sb!assem:assemble (*elsewhere*)
 295     (sb!assem:emit-label label)))
 296
 297 (defun label-elsewhere-p (label-or-posn kind)
 298   (let ((elsewhere (label-position *elsewhere-label*))
 299         (label (etypecase label-or-posn
 300                  (label
 301                   (label-position label-or-posn))
 302                  (index
 303                   label-or-posn))))
 304     (if (memq kind '(:single-value-return
 305                      :unknown-return
 306                      :known-return))
 307         ;; We're interested in what precedes the return, not after
 308         (< elsewhere label)
 309         (<= elsewhere label))))
 310
 311 #!+inline-constants
 312 (defun register-inline-constant (&rest constant-descriptor)
 313   (declare (dynamic-extent constant-descriptor))
 314   (let ((constants *unboxed-constants*)
 315         (constant (sb!vm:canonicalize-inline-constant constant-descriptor)))
 316     (or (gethash constant (constant-table constants))
 317         (multiple-value-bind (label value) (sb!vm:inline-constant-value constant)
 318           (vector-push-extend (cons constant label) (constant-vector constants))
 319           (setf (gethash constant (constant-table constants)) value)))))