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