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