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          #!+inline-constants
  43          *constant-segment*
  44          #!+inline-constants
  45          *constant-table*
  46          #!+inline-constants
  47          *constant-vector*)
  48     (unwind-protect
  49         (let ((*features* (cons :sb-assembling *features*)))
  50           (init-assembler)
  51           (load (merge-pathnames name (make-pathname :type "lisp")))
  52           (sb!assem:append-segment *code-segment* *elsewhere*)
  53           (setf *elsewhere* nil)
  54           #!+inline-constants
  55           (emit-inline-constants)
  56           (let ((length (sb!assem:finalize-segment *code-segment*)))
  57             (dump-assembler-routines *code-segment*
  58                                      length
  59                                      *fixup-notes*
  60                                      *entry-points*
  61                                      lap-fasl-output))
  62           (setq won t))
  63       (close-fasl-output lap-fasl-output (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 expand-one-export-spec (export)
  95   (if (symbolp export)
  96       `(list ',export ,export 0)
  97       (destructuring-bind
  98           (name (operator base-label offset))
  99           export
 100         ;; KLUDGE: Presume that all compound export specs are of the
 101         ;; form (NAME (OPERATOR BASE-LABEL OFFSET)), where OPERATOR is
 102         ;; + or -, BASE-LABEL is a LABEL in the present scope, and
 103         ;; OFFSET evaluates to an integer.  Ideally, we should be
 104         ;; smarter about this.
 105         `(list ',name ,base-label (,operator ,offset)))))
 106
 107 (defun expand-export-option (exports)
 108   (loop
 109     for export in exports
 110     collect `(push ,(expand-one-export-spec export) *entry-points*)))
 111
 112 (defun expand-align-option (align)
 113   (when align
 114     `((emit-alignment ,align))))
 115
 116 (defun emit-assemble (name options regs code)
 117   (collect ((decls))
 118     (loop
 119       (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
 120           (decls (pop code))
 121           (return)))
 122     `(let ,(mapcar (lambda (reg)
 123                      `(,(reg-spec-name reg)
 124                        (make-random-tn
 125                         :kind :normal
 126                         :sc (sc-or-lose ',(reg-spec-sc reg))
 127                         :offset ,(reg-spec-offset reg))))
 128                    regs)
 129        ,@(decls)
 130        (sb!assem:assemble (*code-segment* ',name)
 131          ,@(expand-align-option (cadr (assoc :align options)))
 132          ,name
 133          (push (list ',name ,name 0) *entry-points*)
 134          ,@(expand-export-option (cdr (assoc :export options)))
 135          ,@code
 136          ,@(generate-return-sequence
 137             (or (cadr (assoc :return-style options)) :raw))
 138          (emit-alignment sb!vm:n-lowtag-bits))
 139        (when sb!xc:*compile-print*
 140          (format *error-output* "~S assembled~%" ',name)))))
 141
 142 (defun arg-or-res-spec (reg)
 143   `(,(reg-spec-name reg)
 144     :scs ,(if (atom (reg-spec-scs reg))
 145               (list (reg-spec-scs reg))
 146               (reg-spec-scs reg))
 147     ,@(unless (eq (reg-spec-kind reg) :res)
 148         `(:target ,(reg-spec-temp reg)))))
 149
 150 (defun emit-assemble-vop (name options vars)
 151   (let* ((args (remove :arg vars :key #'reg-spec-kind :test #'neq))
 152          (temps (remove :temp vars :key #'reg-spec-kind :test #'neq))
 153          (results (remove :res vars :key #'reg-spec-kind :test #'neq))
 154          (return-style (or (cadr (assoc :return-style options)) :raw))
 155          (cost (or (cadr (assoc :cost options)) 247))
 156          (vop (make-symbol "VOP")))
 157     (unless (member return-style '(:raw :full-call :none))
 158       (error "unknown return-style for ~S: ~S" name return-style))
 159     (multiple-value-bind (call-sequence call-temps)
 160         (generate-call-sequence name return-style vop options)
 161       `(define-vop ,(if (atom name) (list name) name)
 162          (:args ,@(mapcar #'arg-or-res-spec args))
 163          ,@(let ((index -1))
 164              (mapcar (lambda (arg)
 165                        `(:temporary (:sc ,(reg-spec-sc arg)
 166                                      :offset ,(reg-spec-offset arg)
 167                                      :from (:argument ,(incf index))
 168                                      :to (:eval 2))
 169                                     ,(reg-spec-temp arg)))
 170                      args))
 171          ,@(mapcar (lambda (temp)
 172                      `(:temporary (:sc ,(reg-spec-sc temp)
 173                                    :offset ,(reg-spec-offset temp)
 174                                    :from (:eval 1)
 175                                    :to (:eval 3))
 176                                   ,(reg-spec-name temp)))
 177                    temps)
 178          (:vop-var ,vop)
 179          ,@(let ((index -1))
 180              (mapcar (lambda (res)
 181                        `(:temporary (:sc ,(reg-spec-sc res)
 182                                      :offset ,(reg-spec-offset res)
 183                                      :from (:eval 2)
 184                                      :to (:result ,(incf index))
 185                                      :target ,(reg-spec-name res))
 186                                     ,(reg-spec-temp res)))
 187                      results))
 188          (:results ,@(mapcar #'arg-or-res-spec results))
 189          ;; This formerly unioned in the contents of an :ignore clause from
 190          ;; the value of the 'call-temps' variable, for no good reason afaict.
 191          (:ignore ,@(sort (set-difference (mapcar #'reg-spec-name temps)
 192                                           (cdr (assoc :call-temps options)))
 193                           #'string<))
 194          ,@call-temps
 195          ;; This too is a tad sleazy - because of how VOP parsing works,
 196          ;; any :SAVE-P specified in options supersedes one from call-temps.
 197          ;; It would be wiser to signal an error about duplicate options.
 198          ,@(remove-if (lambda (x)
 199                         (member x '(:return-style :cost :call-temps)))
 200                       options
 201                       :key #'car)
 202          (:generator ,cost
 203            ,@(mapcar (lambda (arg)
 204                        #!+(or hppa alpha) `(move ,(reg-spec-name arg)
 205                                                  ,(reg-spec-temp arg))
 206                        #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
 207                                                  ,(reg-spec-name arg)))
 208                      args)
 209            ,@call-sequence
 210            ,@(mapcar (lambda (res)
 211                        #!+(or hppa alpha) `(move ,(reg-spec-temp res)
 212                                                  ,(reg-spec-name res))
 213                        #!-(or hppa alpha) `(move ,(reg-spec-name res)
 214                                                  ,(reg-spec-temp res)))
 215                      results))))))