;;;; the implementation-independent parts of the code generator. We use
;;;; functions and information provided by the VM definition to convert
;;;; IR2 into assembly code. After emitting code, we finish the
;;;; assembly and then do the post-assembly phase.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-C")

;;;; utilities used during code generation

;;; the number of bytes used by the code object header
(defun component-header-length (&optional
                                (component *component-being-compiled*))
  (let* ((2comp (component-info component))
         (constants (ir2-component-constants 2comp)))
    (ash (align-up (length constants) code-boxed-words-align) sb-vm:word-shift)))

;;; the size of the NAME'd SB in the currently compiled component.
;;; This is useful mainly for finding the size for allocating stack
;;; frames.
(defun sb-allocated-size (name)
  (finite-sb-current-size (sb-or-lose name)))

;;; the TN that is used to hold the number stack frame-pointer in
;;; VOP's function, or NIL if no number stack frame was allocated
(defun current-nfp-tn (vop)
  (unless (zerop (sb-allocated-size 'non-descriptor-stack))
    (let ((block (ir2-block-block (vop-block vop))))
    (when (ir2-physenv-number-stack-p
           (physenv-info
            (block-physenv block)))
      (ir2-component-nfp (component-info (block-component block)))))))

;;; the TN that is used to hold the number stack frame-pointer in the
;;; function designated by 2ENV, or NIL if no number stack frame was
;;; allocated
(defun callee-nfp-tn (2env)
  (unless (zerop (sb-allocated-size 'non-descriptor-stack))
    (when (ir2-physenv-number-stack-p 2env)
      (ir2-component-nfp (component-info *component-being-compiled*)))))

;;; the TN used for passing the return PC in a local call to the function
;;; designated by 2ENV
(defun callee-return-pc-tn (2env)
  (ir2-physenv-return-pc-pass 2env))

;;;; noise to emit an instruction trace

(defun trace-instruction (section vop inst args state
                          &aux (*standard-output* *compiler-trace-output*))
  (macrolet ((prev-section () `(car state))
             (prev-vop () `(cdr state)))
    (unless (eq (prev-section) section)
      (format t "in the ~A section:~%" section)
      (setf (prev-section) section))
    (unless (eq (prev-vop) vop)
      (when vop
        (format t "~%VOP ")
        (if (vop-p vop)
            (print-vop vop)
            (format *compiler-trace-output* "~S~%" vop)))
      (terpri)
      (setf (prev-vop) vop))
    (case inst
      (:label
       (format t "~A:~%" args))
      (:align
       (format t "~0,8T.align~0,8T~A~%" args))
      (t
       (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args))))
  (values))

;;;; GENERATE-CODE and support routines

;;; standard defaults for slots of SEGMENT objects
(defun default-segment-run-scheduler ()
  (policy (lambda-bind
           (block-home-lambda
            (block-next (component-head *component-being-compiled*))))
          (or (> speed compilation-speed) (> space compilation-speed))))
(defun default-segment-inst-hook ()
  (and *compiler-trace-output*
       #'trace-instruction))

;;; Some platforms support unboxed constants immediately following the boxed
;;; code header. Such platform must implement supporting 4 functions:
;;; * CANONICALIZE-INLINE-CONSTANT: converts a constant descriptor (list) into
;;;    a canonical description, to be used as a key in an EQUAL hash table
;;;    and to guide the generation of the constant itself.
;;; * INLINE-CONSTANT-VALUE: given a canonical constant descriptor, computes
;;;    two values:
;;;     1. A label that will be used to emit the constant (usually a
;;;         sb-assem:label)
;;;     2. A value that will be returned to code generators referring to
;;;         the constant (on x86oids, an EA object)
;;; * SORT-INLINE-CONSTANTS: Receives a vector of unique constants;
;;;    the car of each entry is the constant descriptor, and the cdr the
;;;    corresponding label. Destructively returns a vector of constants
;;;    sorted in emission order. It could actually perform arbitrary
;;;    modifications to the vector, e.g. to fuse constants of different
;;;    size.
;;; * EMIT-INLINE-CONSTANT: receives a constant descriptor and its associated
;;;    label. Emits the constant.
;;;
;;; Implementing this feature lets VOP generators use sb-c:register-inline-constant
;;; to get handles (as returned by sb-vm:inline-constant-value) from constant
;;; descriptors.
;;;
#+(or x86 x86-64 arm64)
(defun register-inline-constant (&rest constant-descriptor)
  (declare (dynamic-extent constant-descriptor))
  (let ((asmstream *asmstream*)
        (constant (sb-vm:canonicalize-inline-constant constant-descriptor)))
    (ensure-gethash
     constant
     (asmstream-constant-table asmstream)
     (multiple-value-bind (label value) (sb-vm:inline-constant-value constant)
       (vector-push-extend (cons constant label)
                           (asmstream-constant-vector asmstream))
       value))))
#-(or x86 x86-64 arm64)
(progn (defun sb-vm:sort-inline-constants (constants) constants)
       (defun sb-vm:emit-inline-constant (&rest args)
         (error "EMIT-INLINE-CONSTANT called with ~S" args)))
;;; Return T if and only if there were any constants emitted.
(defun emit-inline-constants ()
  (let* ((asmstream *asmstream*)
         (constants (asmstream-constant-vector asmstream))
         (section (asmstream-data-section asmstream)))
    (when (plusp (length constants))
      (dovector (constant (sb-vm:sort-inline-constants constants) t)
        (sb-vm:emit-inline-constant section (car constant) (cdr constant))))))

;;; If a constant is already loaded into a register use that register.
(defun optimize-constant-loads (component)
  (let* ((register-sb (sb-or-lose 'sb-vm::registers))
         (loaded-constants
           (make-array (sb-size register-sb)
                       :initial-element nil)))
    (do-ir2-blocks (block component)
      (fill loaded-constants nil)
      (do ((vop (ir2-block-start-vop block) (vop-next vop)))
          ((null vop))
        (labels ((register-p (tn)
                   (and (tn-p tn)
                        (not (eq (tn-kind tn) :unused))
                        (eq (sc-sb (tn-sc tn)) register-sb)))
                 (constant-eql-p (a b)
                   (or (eq a b)
                       (and (eq (sc-name (tn-sc a)) 'constant)
                            (eq (tn-sc a) (tn-sc b))
                            (eql (tn-offset a) (tn-offset b)))))
                 (remove-constant (tn)
                   (when (register-p tn)
                     (setf (svref loaded-constants (tn-offset tn)) nil)))
                 (remove-written-tns ()
                   (cond ((memq (vop-info-save-p (vop-info vop))
                                '(t :force-to-stack))
                          (fill loaded-constants nil))
                         (t
                          (do ((ref (vop-results vop) (tn-ref-across ref)))
                              ((null ref))
                            (remove-constant (tn-ref-tn ref))
                            (remove-constant (tn-ref-load-tn ref)))
                          (do ((ref (vop-temps vop) (tn-ref-across ref)))
                              ((null ref))
                            (remove-constant (tn-ref-tn ref)))
                          (do ((ref (vop-args vop) (tn-ref-across ref)))
                              ((null ref))
                            (remove-constant (tn-ref-load-tn ref))))))
                 (compatible-scs-p (a b)
                   (or (eql a b)
                       (and (eq (sc-name a) 'sb-vm::control-stack)
                            (eq (sc-name b) 'sb-vm::descriptor-reg))
                       (and (eq (sc-name b) 'sb-vm::control-stack)
                            (eq (sc-name a) 'sb-vm::descriptor-reg))))
                 (find-constant-tn (constant sc)
                   (loop for (saved-constant . tn) across loaded-constants
                         when (and saved-constant
                                   (constant-eql-p saved-constant constant)
                                   (compatible-scs-p (tn-sc tn) sc))
                         return tn)))
          (case (vop-name vop)
            ((move sb-vm::move-arg)
             (let* ((args (vop-args vop))
                    (x (tn-ref-tn args))
                    (y (tn-ref-tn (vop-results vop)))
                    constant)
               (cond ((or (eq (sc-name (tn-sc x)) 'null)
                          (not (eq (tn-kind x) :constant)))
                      (remove-written-tns))
                     ((setf constant (find-constant-tn x (tn-sc y)))
                      (when (register-p y)
                        (setf (svref loaded-constants (tn-offset y))
                              (cons x y)))
                      ;; XOR is more compact on x86oids and many
                      ;; RISCs have a zero register
                      (unless (and (constant-p (tn-leaf x))
                                   (eql (tn-value x) 0)
                                   (register-p y))
                        (setf (tn-ref-tn args) constant)
                        (setf (tn-ref-load-tn args) nil)))
                     ((register-p y)
                      (setf (svref loaded-constants (tn-offset y))
                            (cons x y)))
                     (t
                      (remove-written-tns)))))
            (t
             (remove-written-tns))))))))

;; Collect "static" count of number of times each vop is employed.
;; (as opposed to "dynamic" - how many times its code is hit at runtime)
(defglobal *static-vop-usage-counts* nil)

(defun generate-code (component)
  (when *compiler-trace-output*
    (format *compiler-trace-output*
            "~|~%assembly code for ~S~2%"
            component))
  (let* ((prev-env nil)
         (asmstream (make-asmstream))
         (*asmstream* asmstream))

    (emit (asmstream-elsewhere-section asmstream)
          (asmstream-elsewhere-label asmstream))

    (do-ir2-blocks (block component)
      (let ((1block (ir2-block-block block)))
        (when (and (eq (block-info 1block) block)
                   (block-start 1block))
          (assemble (:code 'nil) ; bind **CURRENT-VOP** to nil
            ;; Align first emitted block of each loop: x86 and x86-64 both
            ;; like 16 byte alignment, however, since x86 aligns code objects
            ;; on 8 byte boundaries we cannot guarantee proper loop alignment
            ;; there (yet.)  Only x86-64 does something with ALIGNP, but
            ;; it may be useful in the future.
            (let ((alignp (let ((cloop (block-loop 1block)))
                            (when (and cloop
                                       (loop-tail cloop)
                                       (not (loop-info cloop)))
                              ;; Mark the loop as aligned by saving the IR1 block aligned.
                              (setf (loop-info cloop) 1block)
                              t))))
              (emit-block-header (block-label 1block)
                                 (ir2-block-%trampoline-label block)
                                 (ir2-block-dropped-thru-to block)
                                 alignp)))
          (let ((env (block-physenv 1block)))
            (unless (eq env prev-env)
              (let ((lab (gen-label)))
                (setf (ir2-physenv-elsewhere-start (physenv-info env))
                      lab)
                (emit (asmstream-elsewhere-section asmstream) lab))
              (setq prev-env env)))))
      (do ((vop (ir2-block-start-vop block) (vop-next vop)))
          ((null vop))
        (let ((gen (vop-info-generator-function (vop-info vop))))
          (awhen *static-vop-usage-counts*
            (let ((name (vop-info-name (vop-info vop))))
              (incf (gethash name it 0))))
          (assemble (:code vop)
            (cond ((not gen)
                   (format t
                           "missing generator for ~S~%"
                           (template-name (vop-info vop))))
                  #+arm64
                  ((and (vop-next vop)
                        (eq (vop-name vop)
                            (vop-name (vop-next vop)))
                        (memq (vop-name vop) '(move move-operand sb-vm::move-arg))
                        (sb-vm::load-store-two-words vop (vop-next vop)))
                   (setf vop (vop-next vop)))
                  (t
                   (funcall gen vop)))))))

    ;; Truncate the final assembly code buffer to length
    (sb-assem::truncate-section-to-length (asmstream-code-section asmstream))

    (coverage-mark-lowering-pass component asmstream)

    (emit-inline-constants)
    (let* ((info (component-info component))
           (simple-fun-labels
            (mapcar #'entry-info-offset (ir2-component-entries info)))
           (n-boxed (length (ir2-component-constants info)))
           ;; Skew is either 0 or N-WORD-BYTES depending on whether the boxed
           ;; header length is even or odd
           (skew (if (and (= code-boxed-words-align 1) (oddp n-boxed))
                     sb-vm:n-word-bytes
                     0)))
      (multiple-value-bind (segment text-length fixup-notes fun-table)
          (assemble-sections asmstream
                             simple-fun-labels
                             (make-segment :header-skew skew
                                           :run-scheduler (default-segment-run-scheduler)
                                           :inst-hook (default-segment-inst-hook)))
        (values segment text-length fun-table
                (asmstream-elsewhere-label asmstream) fixup-notes)))))

(defun label-elsewhere-p (label-or-posn kind)
  (let ((elsewhere (label-position *elsewhere-label*))
        (label (etypecase label-or-posn
                 (label
                  (label-position label-or-posn))
                 (index
                  label-or-posn))))
    (if (memq kind '(:single-value-return
                     :unknown-return
                     :known-return))
        ;; We're interested in what precedes the return, not after
        (< elsewhere label)
        (<= elsewhere label))))

;;; Translate .COVERAGE-MARK pseudo-op into machine assembly language,
;;; combining any number of consecutive operations with no intervening
;;; control flow into a single operation.
;;; FIXME: this pass runs even if no coverage instrumentation was generated.
(defun coverage-mark-lowering-pass (component asmstream)
  (declare (ignorable component asmstream))
  #+(or x86-64 x86)
  (let ((label (gen-label))
        ;; vector of lists of original source paths covered
        (src-paths (make-array 10 :fill-pointer 0))
        (previous-mark))
    (dolist (buffer (reverse (sb-assem::section-buf-chain
                              (asmstream-code-section asmstream))))
      (dotimes (i (length buffer))
        (let ((item (svref buffer i)))
          (typecase item
           (label
            (when (label-usedp item) ; control can transfer to here
              (setq previous-mark nil)))
           (function ; this can do anything, who knows
            (setq previous-mark nil))
           (t
            (let ((mnemonic (first item)))
              (when (vop-p mnemonic)
                (pop item)
                (setq mnemonic (first item)))
              (cond ((branch-opcode-p mnemonic) ; control flow kills mark combining
                     (setq previous-mark nil))
                    ((eq mnemonic '.coverage-mark)
                     (let ((path (second item)))
                       (cond ((not previous-mark) ; record a new path
                              (let ((mark-index
                                     (vector-push-extend (list path) src-paths)))
                                ;; have the backend lower it into a real instruction
                                (replace-coverage-instruction buffer i label mark-index))
                              (setq previous-mark t))
                             (t ; record that the already-emitted mark pertains
                                ; to an additional source path
                              (push path (elt src-paths (1- (fill-pointer src-paths))))
                              ;; turn this line into a (virtual) no-op
                              (rplaca item '.comment))))))))))))
    ;; Allocate space in the data section for coverage marks
    (let ((mark-index (length src-paths)))
      (when (plusp mark-index)
        (setf (label-usedp label) t)
        (let ((v (ir2-component-constants (component-info component))))
          ;; Nothing depends on the length of the constant vector at this
          ;; phase (codegen has not made use of component-header-length),
          ;; so extending can be done with impunity.
          (vector-push-extend
           (make-constant (cons 'coverage-map
                                (coerce src-paths 'simple-vector)))
           v))
        (emit (asmstream-data-section asmstream) label `(.skip ,mark-index))))))
