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 #!+inline-constants
  62 (progn
  63   (defvar *constant-segment* nil)
  64   (defvar *constant-table*   nil)
  65   (defvar *constant-vector*  nil))
  66
  67 \f
  68 ;;;; noise to emit an instruction trace
  69
  70 (defvar *prev-segment*)
  71 (defvar *prev-vop*)
  72
  73 (defun trace-instruction (segment vop inst args)
  74   (let ((*standard-output* *compiler-trace-output*))
  75     (unless (eq *prev-segment* segment)
  76       (format t "in the ~A segment:~%" (sb!assem:segment-type segment))
  77       (setf *prev-segment* segment))
  78     (unless (eq *prev-vop* vop)
  79       (when vop
  80         (format t "~%VOP ")
  81         (if (vop-p vop)
  82             (print-vop vop)
  83             (format *compiler-trace-output* "~S~%" vop)))
  84       (terpri)
  85       (setf *prev-vop* vop))
  86     (case inst
  87       (:label
  88        (format t "~A:~%" args))
  89       (:align
  90        (format t "~0,8T.align~0,8T~A~%" args))
  91       (t
  92        (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args))))
  93   (values))
  94 \f
  95 ;;;; GENERATE-CODE and support routines
  96
  97 ;;; standard defaults for slots of SEGMENT objects
  98 (defun default-segment-run-scheduler ()
  99   (and *assembly-optimize*
 100         (policy (lambda-bind
 101                  (block-home-lambda
 102                   (block-next (component-head *component-being-compiled*))))
 103                 (or (> speed compilation-speed) (> space compilation-speed)))))
 104 (defun default-segment-inst-hook ()
 105   (and *compiler-trace-output*
 106        #'trace-instruction))
 107
 108 (defun init-assembler ()
 109   (setf *code-segment*
 110         (sb!assem:make-segment :type :regular
 111                                :run-scheduler (default-segment-run-scheduler)
 112                                :inst-hook (default-segment-inst-hook)))
 113   #!+sb-dyncount
 114   (setf (sb!assem:segment-collect-dynamic-statistics *code-segment*)
 115         *collect-dynamic-statistics*)
 116   (setf *elsewhere*
 117         (sb!assem:make-segment :type :elsewhere
 118                                :run-scheduler (default-segment-run-scheduler)
 119                                :inst-hook (default-segment-inst-hook)
 120                                :alignment 0))
 121   #!+inline-constants
 122   (setf *constant-segment*
 123         (sb!assem:make-segment :type :elsewhere
 124                                :run-scheduler nil
 125                                :inst-hook (default-segment-inst-hook)
 126                                :alignment 0)
 127         *constant-table*  (make-hash-table :test #'equal)
 128         *constant-vector* (make-array 16 :adjustable t :fill-pointer 0))
 129   (values))
 130
 131 (defun generate-code (component)
 132   (when *compiler-trace-output*
 133     (format *compiler-trace-output*
 134             "~|~%assembly code for ~S~2%"
 135             component))
 136   (let ((prev-env nil)
 137         (*prev-segment* nil)
 138         (*prev-vop* nil)
 139         (*fixup-notes* nil))
 140     (let ((label (sb!assem:gen-label)))
 141       (setf *elsewhere-label* label)
 142       (sb!assem:assemble (*elsewhere*)
 143         (sb!assem:emit-label label)))
 144     (do-ir2-blocks (block component)
 145       (let ((1block (ir2-block-block block)))
 146         (when (and (eq (block-info 1block) block)
 147                    (block-start 1block))
 148           (sb!assem:assemble (*code-segment*)
 149             ;; Align first emitted block of each loop: x86 and x86-64 both
 150             ;; like 16 byte alignment, however, since x86 aligns code objects
 151             ;; on 8 byte boundaries we cannot guarantee proper loop alignment
 152             ;; there (yet.)  Only x86-64 does something with ALIGNP, but
 153             ;; it may be useful in the future.
 154             (let ((alignp (let ((cloop (block-loop 1block)))
 155                             (when (and cloop
 156                                        (loop-tail cloop)
 157                                        (not (loop-info cloop)))
 158                               ;; Mark the loop as aligned by saving the IR1 block aligned.
 159                               (setf (loop-info cloop) 1block)
 160                               t))))
 161               (emit-block-header (block-label 1block)
 162                                  (ir2-block-%trampoline-label block)
 163                                  (ir2-block-dropped-thru-to block)
 164                                  alignp)))
 165           (let ((env (block-physenv 1block)))
 166             (unless (eq env prev-env)
 167               (let ((lab (gen-label)))
 168                 (setf (ir2-physenv-elsewhere-start (physenv-info env))
 169                       lab)
 170                 (emit-label-elsewhere lab))
 171               (setq prev-env env)))))
 172       (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 173           ((null vop))
 174         (let ((gen (vop-info-generator-function (vop-info vop))))
 175           (if gen
 176             (funcall gen vop)
 177             (format t
 178                     "missing generator for ~S~%"
 179                     (template-name (vop-info vop)))))))
 180     (sb!assem:append-segment *code-segment* *elsewhere*)
 181     (setf *elsewhere* nil)
 182     #!+inline-constants
 183     (progn
 184       (unless (zerop (length *constant-vector*))
 185         (let ((constants (sb!vm:sort-inline-constants *constant-vector*)))
 186           (assemble (*constant-segment*)
 187             #+nil
 188             (sb!vm:emit-constant-segment-header
 189              *constant-segment*
 190              constants
 191              (do-ir2-blocks (2block component nil)
 192                (when (policy (block-last (ir2-block-block 2block))
 193                              (> speed space))
 194                  (return t))))
 195             (map nil (lambda (constant)
 196                        (sb!vm:emit-inline-constant (car constant) (cdr constant)))
 197                  constants)))
 198         (sb!assem:append-segment *constant-segment* *code-segment*)
 199         (setq *code-segment* *constant-segment*))
 200       (setf *constant-segment* nil
 201             *constant-vector*  nil
 202             *constant-table*   nil))
 203     (values (sb!assem:finalize-segment *code-segment*)
 204             *fixup-notes*)))
 205
 206 (defun emit-label-elsewhere (label)
 207   (sb!assem:assemble (*elsewhere*)
 208     (sb!assem:emit-label label)))
 209
 210 (defun label-elsewhere-p (label-or-posn kind)
 211   (let ((elsewhere (label-position *elsewhere-label*))
 212         (label (etypecase label-or-posn
 213                  (label
 214                   (label-position label-or-posn))
 215                  (index
 216                   label-or-posn))))
 217     (if (memq kind '(:single-value-return
 218                      :unknown-return
 219                      :known-return))
 220         ;; We're interested in what precedes the return, not after
 221         (< elsewhere label)
 222         (<= elsewhere label))))
 223
 224 #!+inline-constants
 225 (defun register-inline-constant (&rest constant-descriptor)
 226   (declare (dynamic-extent constant-descriptor))
 227   (let ((constant (sb!vm:canonicalize-inline-constant constant-descriptor)))
 228     (or (gethash constant *constant-table*)
 229         (multiple-value-bind (label value) (sb!vm:inline-constant-value constant)
 230           (vector-push-extend (cons constant label) *constant-vector*)
 231           (setf (gethash constant *constant-table*) value)))))