1 ;;;; the extra code necessary to feed an entire file of assembly code
4 ;;;; This software is part of the SBCL system. See the README file for
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.
15 (defvar *do-assembly* nil
16 #!+sb-doc "If non-NIL, emit assembly code. If NIL, emit VOP templates.")
18 (defvar *lap-output-file* nil
19 #!+sb-doc "the FASL file currently being output to")
21 (defvar *entry-points* nil
22 #!+sb-doc "a list of (name . label) for every entry point")
24 (defvar *assembly-optimize* t
26 "Set this to NIL to inhibit assembly-level optimization. For compiler
27 debugging, rather than policy control.")
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
33 (defun assemble-file (name
35 (output-file (make-pathname :defaults name
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))
45 (*assembly-optimize* nil)
48 (let ((*features* (cons :sb-assembling *features*)))
50 (load (merge-pathnames name (make-pathname :type "lisp")))
51 (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
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*
62 (close-fasl-file *lap-output-file* (not won)))
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))
71 (def!method print-object ((spec reg-spec) stream)
72 (print-unreadable-object (spec stream :type t)
74 ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
78 (reg-spec-offset spec))))
80 (defun reg-spec-sc (spec)
81 (if (atom (reg-spec-scs spec))
83 (car (reg-spec-scs spec))))
85 (defun parse-reg-spec (kind name sc offset)
86 (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
90 (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
93 (defun emit-assemble (name options regs code)
96 (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
101 `(,(reg-spec-name reg)
104 :sc (sc-or-lose ',(reg-spec-sc reg))
105 :offset ,(reg-spec-offset reg))))
108 (sb!assem:assemble (*code-segment* ',name)
110 (push (cons ',name ,name) *entry-points*)
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)))))
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))
122 ,@(unless (eq (reg-spec-kind reg) :res)
123 `(:target ,(reg-spec-temp reg)))))
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))
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))
140 (mapcar #'(lambda (arg)
141 `(:temporary (:sc ,(reg-spec-sc arg)
142 :offset ,(reg-spec-offset arg)
143 :from (:argument ,(incf index))
145 ,(reg-spec-temp arg)))
147 ,@(mapcar #'(lambda (temp)
148 `(:temporary (:sc ,(reg-spec-sc temp)
149 :offset ,(reg-spec-offset temp)
152 ,(reg-spec-name temp)))
157 (mapcar #'(lambda (res)
158 `(:temporary (:sc ,(reg-spec-sc res)
159 :offset ,(reg-spec-offset res)
161 :to (:result ,(incf index))
162 :target ,(reg-spec-name res))
163 ,(reg-spec-temp res)))
165 (:results ,@(mapcar #'arg-or-res-spec results))
166 (:ignore ,@(mapcar #'reg-spec-name temps)
169 (remove :ignore call-temps
170 :test-not #'eq :key #'car))))
171 ,@(remove-if #'(lambda (x)
172 (member x '(:return-style :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)))
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)))
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)
196 (let ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
198 (emit-assemble name options regs code)
199 (emit-vop name options regs)))))