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 OFFSET) for every entry point
  19 (defvar *entry-points* nil)
  20
  21 ;;; Note: You might think from the name that this would act like
  22 ;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down
  23 ;;; to the return convention. It LOADs a file, then writes out any
  24 ;;; assembly code created by the process.
  25 (defun assemble-file (name
  26                       &key
  27                       (output-file (make-pathname :defaults name
  28                                                   :type "assem")))
  29   (when sb-cold::*compile-for-effect-only*
  30     (return-from assemble-file t))
  31   ;; FIXME: Consider nuking the filename defaulting logic here.
  32   (let* ((*emit-assembly-code-not-vops-p* t)
  33          (name (pathname name))
  34          ;; the fasl file currently being output to
  35          (lap-fasl-output (open-fasl-output (pathname output-file) name))
  36          (*entry-points* nil)
  37          (won nil)
  38          (*code-segment* nil)
  39          (*elsewhere* nil)
  40          (*assembly-optimize* nil)
  41          (*fixup-notes* nil)
  42          #!+immobile-code (*code-is-immobile* t)
  43          #!+inline-constants (*unboxed-constants* 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           #!+inline-constants
  51           (emit-inline-constants)
  52           (let ((length (sb!assem:finalize-segment *code-segment*)))
  53             (dump-assembler-routines *code-segment*
  54                                      length
  55                                      *fixup-notes*
  56                                      *entry-points*
  57                                      lap-fasl-output))
  58           (setq won t))
  59       (close-fasl-output lap-fasl-output (not won)))
  60     won))
  61
  62 (defstruct (reg-spec (:copier nil))
  63   (kind :temp :type (member :arg :temp :res))
  64   (name nil :type symbol)
  65   (temp nil :type symbol)
  66   (scs nil :type (or list symbol))
  67   (offset nil))
  68 (defmethod print-object ((spec reg-spec) stream)
  69   (print-unreadable-object (spec stream :type t)
  70     (format stream
  71             ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
  72             (reg-spec-kind spec)
  73             (reg-spec-name spec)
  74             (reg-spec-scs spec)
  75             (reg-spec-offset spec))))
  76
  77 (defun reg-spec-sc (spec)
  78   (if (atom (reg-spec-scs spec))
  79       (reg-spec-scs spec)
  80       (car (reg-spec-scs spec))))
  81
  82 (defun parse-reg-spec (kind name sc offset)
  83   (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
  84     (ecase kind
  85       (:temp)
  86       ((:arg :res)
  87        (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
  88     reg))
  89
  90 (defun expand-one-export-spec (export)
  91   (if (symbolp export)
  92       `(list ',export ,export 0)
  93       (destructuring-bind
  94           (name (operator base-label offset))
  95           export
  96         ;; KLUDGE: Presume that all compound export specs are of the
  97         ;; form (NAME (OPERATOR BASE-LABEL OFFSET)), where OPERATOR is
  98         ;; + or -, BASE-LABEL is a LABEL in the present scope, and
  99         ;; OFFSET evaluates to an integer.  Ideally, we should be
 100         ;; smarter about this.
 101         `(list ',name ,base-label (,operator ,offset)))))
 102
 103 (defun expand-export-option (exports)
 104   (loop
 105     for export in exports
 106     collect `(push ,(expand-one-export-spec export) *entry-points*)))
 107
 108 (defun expand-align-option (align)
 109   (when align
 110     `((emit-alignment ,align))))
 111
 112 (defun emit-assemble (name options regs code)
 113   (collect ((decls))
 114     (loop
 115       (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
 116           (decls (pop code))
 117           (return)))
 118     `(let ,(mapcar (lambda (reg)
 119                      `(,(reg-spec-name reg)
 120                        (make-random-tn
 121                         :kind :normal
 122                         :sc (sc-or-lose ',(reg-spec-sc reg))
 123                         :offset ,(reg-spec-offset reg))))
 124                    regs)
 125        ,@(decls)
 126        (sb!assem:assemble (*code-segment* ',name)
 127          ,@(expand-align-option (cadr (assoc :align options)))
 128          ,name
 129          (push (list ',name ,name 0) *entry-points*)
 130          ,@(expand-export-option (cdr (assoc :export options)))
 131          ,@code
 132          ,@(generate-return-sequence
 133             (or (cadr (assoc :return-style options)) :raw))
 134          (emit-alignment sb!vm:n-lowtag-bits))
 135        (when *compile-print*
 136          (format *error-output* "~S assembled~%" ',name)))))
 137
 138 (defun arg-or-res-spec (reg)
 139   `(,(reg-spec-name reg)
 140     :scs ,(if (atom (reg-spec-scs reg))
 141               (list (reg-spec-scs reg))
 142               (reg-spec-scs reg))
 143     ,@(unless (eq (reg-spec-kind reg) :res)
 144         `(:target ,(reg-spec-temp reg)))))
 145
 146 (defun emit-assemble-vop (name options vars)
 147   (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq))
 148          (temps (remove :temp vars :key #'reg-spec-kind :test #'neq))
 149          (results (remove :res vars :key #'reg-spec-kind :test #'neq))
 150          (return-style (or (cadr (assoc :return-style options)) :raw))
 151          (cost (or (cadr (assoc :cost options)) 247))
 152          (vop (make-symbol "VOP")))
 153     (unless (member return-style '(:raw :full-call :none))
 154       (error "unknown return-style for ~S: ~S" name return-style))
 155     (multiple-value-bind (call-sequence call-temps)
 156         (generate-call-sequence name return-style vop options)
 157       `(define-vop ,(if (atom name) (list name) name)
 158          (:args ,@(mapcar #'arg-or-res-spec args))
 159          ,@(let ((index -1))
 160              (mapcar (lambda (arg)
 161                        `(:temporary (:sc ,(reg-spec-sc arg)
 162                                      :offset ,(reg-spec-offset arg)
 163                                      :from (:argument ,(incf index))
 164                                      :to (:eval 2))
 165                                     ,(reg-spec-temp arg)))
 166                      args))
 167          ,@(mapcar (lambda (temp)
 168                      `(:temporary (:sc ,(reg-spec-sc temp)
 169                                    :offset ,(reg-spec-offset temp)
 170                                    :from (:eval 1)
 171                                    :to (:eval 3))
 172                                   ,(reg-spec-name temp)))
 173                    temps)
 174          (:vop-var ,vop)
 175          ,@(let ((index -1))
 176              (mapcar (lambda (res)
 177                        `(:temporary (:sc ,(reg-spec-sc res)
 178                                      :offset ,(reg-spec-offset res)
 179                                      :from (:eval 2)
 180                                      :to (:result ,(incf index))
 181                                      :target ,(reg-spec-name res))
 182                                     ,(reg-spec-temp res)))
 183                      results))
 184          (:results ,@(mapcar #'arg-or-res-spec results))
 185          ;; This formerly unioned in the contents of an :ignore clause from
 186          ;; the value of the 'call-temps' variable, for no good reason afaict.
 187          (:ignore ,@(sort (set-difference (mapcar #'reg-spec-name temps)
 188                                           (cdr (assoc :call-temps options)))
 189                           #'string<))
 190          ,@call-temps
 191          ;; This too is a tad sleazy - because of how VOP parsing works,
 192          ;; any :SAVE-P specified in options supersedes one from call-temps.
 193          ;; It would be wiser to signal an error about duplicate options.
 194          ,@(remove-if (lambda (x)
 195                         (member x '(:return-style :cost :call-temps)))
 196                       options
 197                       :key #'car)
 198          (:generator ,cost
 199            ,@(mapcar (lambda (arg)
 200                        #!+(or hppa alpha) `(move ,(reg-spec-name arg)
 201                                                  ,(reg-spec-temp arg))
 202                        #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
 203                                                  ,(reg-spec-name arg)))
 204                      args)
 205            ,@call-sequence
 206            ,@(mapcar (lambda (res)
 207                        #!+(or hppa alpha) `(move ,(reg-spec-temp res)
 208                                                  ,(reg-spec-name res))
 209                        #!-(or hppa alpha) `(move ,(reg-spec-name res)
 210                                                  ,(reg-spec-temp res)))
 211                      results))))))