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 ;;; If non-NIL, emit assembly code. If NIL, emit VOP templates.
16 (defvar *do-assembly* nil)
18 ;;; a list of (NAME . LABEL) for every entry point
19 (defvar *entry-points* nil)
21 ;;; Set this to NIL to inhibit assembly-level optimization. (For
22 ;;; compiler debugging, rather than policy control.)
23 (defvar *assembly-optimize* t)
25 ;;; Note: You might think from the name that this would act like
26 ;;; COMPILE-FILE, but in fact it's arguably more like LOAD, even down
27 ;;; to the return convention. It LOADs a file, then writes out any
28 ;;; assembly code created by the process.
29 (defun assemble-file (name
31 (output-file (make-pathname :defaults name
33 ;; FIXME: Consider nuking the filename defaulting logic here.
34 (let* ((*do-assembly* t)
35 (name (pathname name))
36 ;; the fasl file currently being output to
37 (lap-fasl-output (open-fasl-output (pathname output-file) name))
42 (*assembly-optimize* nil)
45 (let ((*features* (cons :sb-assembling *features*)))
47 (load (merge-pathnames name (make-pathname :type "lisp")))
48 (fasl-dump-cold-load-form `(in-package ,(package-name
51 (sb!assem:append-segment *code-segment* *elsewhere*)
52 (setf *elsewhere* nil)
53 (let ((length (sb!assem:finalize-segment *code-segment*)))
54 (dump-assembler-routines *code-segment*
60 (close-fasl-output lap-fasl-output (not won)))
63 (defstruct (reg-spec (:copier nil))
64 (kind :temp :type (member :arg :temp :res))
65 (name nil :type symbol)
66 (temp nil :type symbol)
67 (scs nil :type (or list symbol))
69 (def!method print-object ((spec reg-spec) stream)
70 (print-unreadable-object (spec stream :type t)
72 ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
76 (reg-spec-offset spec))))
78 (defun reg-spec-sc (spec)
79 (if (atom (reg-spec-scs spec))
81 (car (reg-spec-scs spec))))
83 (defun parse-reg-spec (kind name sc offset)
84 (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
88 (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
91 (defun emit-assemble (name options regs code)
94 (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
99 `(,(reg-spec-name reg)
102 :sc (sc-or-lose ',(reg-spec-sc reg))
103 :offset ,(reg-spec-offset reg))))
106 (sb!assem:assemble (*code-segment* ',name)
108 (push (cons ',name ,name) *entry-points*)
110 ,@(generate-return-sequence
111 (or (cadr (assoc :return-style options)) :raw)))
112 (when sb!xc:*compile-print*
113 (format *error-output* "~S assembled~%" ',name)))))
115 (defun arg-or-res-spec (reg)
116 `(,(reg-spec-name reg)
117 :scs ,(if (atom (reg-spec-scs reg))
118 (list (reg-spec-scs reg))
120 ,@(unless (eq (reg-spec-kind reg) :res)
121 `(:target ,(reg-spec-temp reg)))))
123 (defun emit-vop (name options vars)
124 (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
125 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
126 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
127 (return-style (or (cadr (assoc :return-style options)) :raw))
128 (cost (or (cadr (assoc :cost options)) 247))
129 (vop (make-symbol "VOP")))
130 (unless (member return-style '(:raw :full-call :none))
131 (error "unknown return-style for ~S: ~S" name return-style))
133 (call-sequence call-temps)
134 (generate-call-sequence name return-style vop)
135 `(define-vop ,(if (atom name) (list name) name)
136 (:args ,@(mapcar #'arg-or-res-spec args))
138 (mapcar #'(lambda (arg)
139 `(:temporary (:sc ,(reg-spec-sc arg)
140 :offset ,(reg-spec-offset arg)
141 :from (:argument ,(incf index))
143 ,(reg-spec-temp arg)))
145 ,@(mapcar #'(lambda (temp)
146 `(:temporary (:sc ,(reg-spec-sc temp)
147 :offset ,(reg-spec-offset temp)
150 ,(reg-spec-name temp)))
155 (mapcar #'(lambda (res)
156 `(:temporary (:sc ,(reg-spec-sc res)
157 :offset ,(reg-spec-offset res)
159 :to (:result ,(incf index))
160 :target ,(reg-spec-name res))
161 ,(reg-spec-temp res)))
163 (:results ,@(mapcar #'arg-or-res-spec results))
164 (:ignore ,@(mapcar #'reg-spec-name temps)
167 (remove :ignore call-temps
168 :test-not #'eq :key #'car))))
169 ,@(remove-if #'(lambda (x)
170 (member x '(:return-style :cost)))
174 ,@(mapcar #'(lambda (arg)
175 #!+(or hppa alpha) `(move ,(reg-spec-name arg)
176 ,(reg-spec-temp arg))
177 #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
178 ,(reg-spec-name arg)))
181 ,@(mapcar #'(lambda (res)
182 #!+(or hppa alpha) `(move ,(reg-spec-temp res)
183 ,(reg-spec-name res))
184 #!-(or hppa alpha) `(move ,(reg-spec-name res)
185 ,(reg-spec-temp res)))
188 (def!macro define-assembly-routine (name&options vars &body code)
189 (multiple-value-bind (name options)
190 (if (atom name&options)
191 (values name&options nil)
192 (values (car name&options)
194 (let ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
196 (emit-assemble name options regs code)
197 (emit-vop name options regs)))))