src/assembly/assemfile.lisp

   1 ;;;; the extra code necessary to feed an entire file of assembly code
   2 ;;;; to the assembler
   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 \f
  15 ;;; If non-NIL, emit assembly code. If NIL, emit VOP templates.
  16 (defvar *emit-assembly-code-not-vops-p* nil)
  17
  18 ;;; a list of (NAME . LABEL) for every entry point
  19 (defvar *entry-points* nil)
  20
  21 ;;; Set this to NIL to inhibit assembly-level optimization. (For
  22 ;;; compiler debugging, rather than policy control.)
  23 (defvar *assembly-optimize* t)
  24
  25 ;;; Note: You might think from the name that this would act like
  26 ;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down
  27 ;;; to the return convention. It LOADs a file, then writes out any
  28 ;;; assembly code created by the process.
  29 (defun assemble-file (name
  30                       &key
  31                       (output-file (make-pathname :defaults name
  32                                                   :type "assem")))
  33   ;; FIXME: Consider nuking the filename defaulting logic here.
  34   (let* ((*emit-assembly-code-not-vops-p* t)
  35          (name (pathname name))
  36          ;; the fasl file currently being output to
  37          (lap-fasl-output (open-fasl-output (pathname output-file) name))
  38          (*entry-points* nil)
  39          (won nil)
  40          (*code-segment* nil)
  41          (*elsewhere* nil)
  42          (*assembly-optimize* nil)
  43          (*fixup-notes* nil))
  44     (unwind-protect
  45         (let ((*features* (cons :sb-assembling *features*)))
  46           (init-assembler)
  47           (load (merge-pathnames name (make-pathname :type "lisp")))
  48           (sb!assem:append-segment *code-segment* *elsewhere*)
  49           (setf *elsewhere* nil)
  50           (let ((length (sb!assem:finalize-segment *code-segment*)))
  51             (dump-assembler-routines *code-segment*
  52                                      length
  53                                      *fixup-notes*
  54                                      *entry-points*
  55                                      lap-fasl-output))
  56           (setq won t))
  57       (close-fasl-output lap-fasl-output (not won)))
  58     won))
  59
  60 (defstruct (reg-spec (:copier nil))
  61   (kind :temp :type (member :arg :temp :res))
  62   (name nil :type symbol)
  63   (temp nil :type symbol)
  64   (scs nil :type (or list symbol))
  65   (offset nil))
  66 (def!method print-object ((spec reg-spec) stream)
  67   (print-unreadable-object (spec stream :type t)
  68     (format stream
  69             ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
  70             (reg-spec-kind spec)
  71             (reg-spec-name spec)
  72             (reg-spec-scs spec)
  73             (reg-spec-offset spec))))
  74
  75 (defun reg-spec-sc (spec)
  76   (if (atom (reg-spec-scs spec))
  77       (reg-spec-scs spec)
  78       (car (reg-spec-scs spec))))
  79
  80 (defun parse-reg-spec (kind name sc offset)
  81   (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
  82     (ecase kind
  83       (:temp)
  84       ((:arg :res)
  85        (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
  86     reg))
  87
  88 (defun emit-assemble (name options regs code)
  89   (collect ((decls))
  90     (loop
  91       (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
  92           (decls (pop code))
  93           (return)))
  94     `(let ,(mapcar (lambda (reg)
  95                      `(,(reg-spec-name reg)
  96                        (make-random-tn
  97                         :kind :normal
  98                         :sc (sc-or-lose ',(reg-spec-sc reg))
  99                         :offset ,(reg-spec-offset reg))))
 100                    regs)
 101        ,@(decls)
 102        (sb!assem:assemble (*code-segment* ',name)
 103          ,name
 104          (push (cons ',name ,name) *entry-points*)
 105          ,@code
 106          ,@(generate-return-sequence
 107             (or (cadr (assoc :return-style options)) :raw)))
 108        (when sb!xc:*compile-print*
 109          (format *error-output* "~S assembled~%" ',name)))))
 110
 111 (defun arg-or-res-spec (reg)
 112   `(,(reg-spec-name reg)
 113     :scs ,(if (atom (reg-spec-scs reg))
 114               (list (reg-spec-scs reg))
 115               (reg-spec-scs reg))
 116     ,@(unless (eq (reg-spec-kind reg) :res)
 117         `(:target ,(reg-spec-temp reg)))))
 118
 119 (defun emit-assemble-vop (name options vars)
 120   (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq))
 121          (temps (remove :temp vars :key #'reg-spec-kind :test #'neq))
 122          (results (remove :res vars :key #'reg-spec-kind :test #'neq))
 123          (return-style (or (cadr (assoc :return-style options)) :raw))
 124          (cost (or (cadr (assoc :cost options)) 247))
 125          (vop (make-symbol "VOP")))
 126     (unless (member return-style '(:raw :full-call :none))
 127       (error "unknown return-style for ~S: ~S" name return-style))
 128     (multiple-value-bind (call-sequence call-temps)
 129         (generate-call-sequence name return-style vop)
 130       `(define-vop ,(if (atom name) (list name) name)
 131          (:args ,@(mapcar #'arg-or-res-spec args))
 132          ,@(let ((index -1))
 133              (mapcar (lambda (arg)
 134                        `(:temporary (:sc ,(reg-spec-sc arg)
 135                                      :offset ,(reg-spec-offset arg)
 136                                      :from (:argument ,(incf index))
 137                                      :to (:eval 2))
 138                                     ,(reg-spec-temp arg)))
 139                      args))
 140          ,@(mapcar (lambda (temp)
 141                      `(:temporary (:sc ,(reg-spec-sc temp)
 142                                    :offset ,(reg-spec-offset temp)
 143                                    :from (:eval 1)
 144                                    :to (:eval 3))
 145                                   ,(reg-spec-name temp)))
 146                    temps)
 147          (:vop-var ,vop)
 148          ,@(let ((index -1))
 149              (mapcar (lambda (res)
 150                        `(:temporary (:sc ,(reg-spec-sc res)
 151                                      :offset ,(reg-spec-offset res)
 152                                      :from (:eval 2)
 153                                      :to (:result ,(incf index))
 154                                      :target ,(reg-spec-name res))
 155                                     ,(reg-spec-temp res)))
 156                      results))
 157          (:results ,@(mapcar #'arg-or-res-spec results))
 158          ;; call-temps are allowed to inject random clauses into the vop
 159          ;; definition, including one or more :IGNORE options, which made
 160          ;; little sense because for one thing it is stylistically wrong -
 161          ;; DEFINE-VOP itself considers only the last of a repeated option.
 162          ;; More to the point, nobody needs the ability to ignore more TNs
 163          ;; than were auto-ignored. Indeed, we want to un-ignore some,
 164          ;; which is achieved by putting an empty :IGNORE in call-temps.
 165          ;; Instead of unioning the :IGNOREs, call-temps always prevails.
 166          (:ignore ,@(mapcar #'reg-spec-name temps))
 167          ,@call-temps
 168          ;; This too is a tad sleazy - because of how VOP parsing works,
 169          ;; any :SAVE-P specified in options supersedes one from call-temps.
 170          ;; It would be wiser to signal an error about duplicate options.
 171          ,@(remove-if (lambda (x)
 172                         (member x '(:return-style :cost)))
 173                       options
 174                       :key #'car)
 175          (:generator ,cost
 176            ,@(mapcar (lambda (arg)
 177                        #!+(or hppa alpha) `(move ,(reg-spec-name arg)
 178                                                  ,(reg-spec-temp arg))
 179                        #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
 180                                                  ,(reg-spec-name arg)))
 181                      args)
 182            ,@call-sequence
 183            ,@(mapcar (lambda (res)
 184                        #!+(or hppa alpha) `(move ,(reg-spec-temp res)
 185                                                  ,(reg-spec-name res))
 186                        #!-(or hppa alpha) `(move ,(reg-spec-name res)
 187                                                  ,(reg-spec-temp res)))
 188                      results))))))
 189
 190 (def!macro define-assembly-routine (name&options vars &body code)
 191   (multiple-value-bind (name options)
 192       (if (atom name&options)
 193           (values name&options nil)
 194           (values (car name&options)
 195                   (cdr name&options)))
 196     (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var)) vars)))
 197       (if *emit-assembly-code-not-vops-p*
 198           (emit-assemble name options regs code)
 199           (emit-assemble-vop name options regs)))))