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
  52                                                    (sane-package)))
  53                                     *lap-output-file*)
  54           (sb!assem:append-segment *code-segment* *elsewhere*)
  55           (setf *elsewhere* nil)
  56           (let ((length (sb!assem:finalize-segment *code-segment*)))
  57             (dump-assembler-routines *code-segment*
  58                                      length
  59                                      *fixups*
  60                                      *entry-points*
  61                                      *lap-output-file*))
  62           (setq won t))
  63       (close-fasl-file *lap-output-file* (not won)))
  64     won))
  65
  66 (defstruct (reg-spec (:copier nil))
  67   (kind :temp :type (member :arg :temp :res))
  68   (name nil :type symbol)
  69   (temp nil :type symbol)
  70   (scs nil :type (or list symbol))
  71   (offset nil))
  72 (def!method print-object ((spec reg-spec) stream)
  73   (print-unreadable-object (spec stream :type t)
  74     (format stream
  75             ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
  76             (reg-spec-kind spec)
  77             (reg-spec-name spec)
  78             (reg-spec-scs spec)
  79             (reg-spec-offset spec))))
  80
  81 (defun reg-spec-sc (spec)
  82   (if (atom (reg-spec-scs spec))
  83       (reg-spec-scs spec)
  84       (car (reg-spec-scs spec))))
  85
  86 (defun parse-reg-spec (kind name sc offset)
  87   (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
  88     (ecase kind
  89       (:temp)
  90       ((:arg :res)
  91        (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
  92     reg))
  93
  94 (defun emit-assemble (name options regs code)
  95   (collect ((decls))
  96     (loop
  97       (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
  98           (decls (pop code))
  99           (return)))
 100     `(let (,@(mapcar
 101               #'(lambda (reg)
 102                   `(,(reg-spec-name reg)
 103                     (make-random-tn
 104                      :kind :normal
 105                      :sc (sc-or-lose ',(reg-spec-sc reg))
 106                      :offset ,(reg-spec-offset reg))))
 107               regs))
 108        ,@(decls)
 109        (sb!assem:assemble (*code-segment* ',name)
 110          ,name
 111          (push (cons ',name ,name) *entry-points*)
 112          ,@code
 113          ,@(generate-return-sequence
 114             (or (cadr (assoc :return-style options)) :raw)))
 115        (when sb!xc:*compile-print*
 116          (format *error-output* "~S assembled~%" ',name)))))
 117
 118 (defun arg-or-res-spec (reg)
 119   `(,(reg-spec-name reg)
 120     :scs ,(if (atom (reg-spec-scs reg))
 121               (list (reg-spec-scs reg))
 122               (reg-spec-scs reg))
 123     ,@(unless (eq (reg-spec-kind reg) :res)
 124         `(:target ,(reg-spec-temp reg)))))
 125
 126 (defun emit-vop (name options vars)
 127   (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
 128          (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
 129          (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
 130          (return-style (or (cadr (assoc :return-style options)) :raw))
 131          (cost (or (cadr (assoc :cost options)) 247))
 132          (vop (make-symbol "VOP")))
 133     (unless (member return-style '(:raw :full-call :none))
 134       (error "unknown return-style for ~S: ~S" name return-style))
 135     (multiple-value-bind
 136         (call-sequence call-temps)
 137         (generate-call-sequence name return-style vop)
 138       `(define-vop ,(if (atom name) (list name) name)
 139          (:args ,@(mapcar #'arg-or-res-spec args))
 140          ,@(let ((index -1))
 141              (mapcar #'(lambda (arg)
 142                          `(:temporary (:sc ,(reg-spec-sc arg)
 143                                            :offset ,(reg-spec-offset arg)
 144                                            :from (:argument ,(incf index))
 145                                            :to (:eval 2))
 146                                       ,(reg-spec-temp arg)))
 147                      args))
 148          ,@(mapcar #'(lambda (temp)
 149                        `(:temporary (:sc ,(reg-spec-sc temp)
 150                                          :offset ,(reg-spec-offset temp)
 151                                          :from (:eval 1)
 152                                          :to (:eval 3))
 153                                     ,(reg-spec-name temp)))
 154                    temps)
 155          ,@call-temps
 156          (:vop-var ,vop)
 157          ,@(let ((index -1))
 158              (mapcar #'(lambda (res)
 159                          `(:temporary (:sc ,(reg-spec-sc res)
 160                                            :offset ,(reg-spec-offset res)
 161                                            :from (:eval 2)
 162                                            :to (:result ,(incf index))
 163                                            :target ,(reg-spec-name res))
 164                                       ,(reg-spec-temp res)))
 165                      results))
 166          (:results ,@(mapcar #'arg-or-res-spec results))
 167          (:ignore ,@(mapcar #'reg-spec-name temps)
 168                   ,@(apply #'append
 169                            (mapcar #'cdr
 170                                    (remove :ignore call-temps
 171                                            :test-not #'eq :key #'car))))
 172          ,@(remove-if #'(lambda (x)
 173                           (member x '(:return-style :cost)))
 174                       options
 175                       :key #'car)
 176          (:generator ,cost
 177            ,@(mapcar #'(lambda (arg)
 178                          #!+(or hppa alpha) `(move ,(reg-spec-name arg)
 179                                                    ,(reg-spec-temp arg))
 180                          #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
 181                                                    ,(reg-spec-name arg)))
 182                      args)
 183            ,@call-sequence
 184            ,@(mapcar #'(lambda (res)
 185                          #!+(or hppa alpha) `(move ,(reg-spec-temp res)
 186                                                    ,(reg-spec-name res))
 187                          #!-(or hppa alpha) `(move ,(reg-spec-name res)
 188                                                    ,(reg-spec-temp res)))
 189                      results))))))
 190
 191 (def!macro define-assembly-routine (name&options vars &body code)
 192   (multiple-value-bind (name options)
 193       (if (atom name&options)
 194           (values name&options nil)
 195         (values (car name&options)
 196                 (cdr name&options)))
 197     (let ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
 198       (if *do-assembly*
 199           (emit-assemble name options regs code)
 200           (emit-vop name options regs)))))