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 *emit-assembly-code-not-vops-p
* 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* ((*emit-assembly-code-not-vops-p
* 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
))
97 `(let ,(mapcar (lambda (reg)
98 `(,(reg-spec-name reg
)
101 :sc
(sc-or-lose ',(reg-spec-sc reg
))
102 :offset
,(reg-spec-offset reg
))))
105 (sb!assem
:assemble
(*code-segment
* ',name
)
107 (push (cons ',name
,name
) *entry-points
*)
109 ,@(generate-return-sequence
110 (or (cadr (assoc :return-style options
)) :raw
)))
111 (when sb
!xc
:*compile-print
*
112 (format *error-output
* "~S assembled~%" ',name
)))))
114 (defun arg-or-res-spec (reg)
115 `(,(reg-spec-name reg
)
116 :scs
,(if (atom (reg-spec-scs reg
))
117 (list (reg-spec-scs reg
))
119 ,@(unless (eq (reg-spec-kind reg
) :res
)
120 `(:target
,(reg-spec-temp reg
)))))
122 (defun emit-vop (name options vars
)
123 (let* ((args (remove :arg vars
:key
#'reg-spec-kind
:test
#'neq
))
124 (temps (remove :temp vars
:key
#'reg-spec-kind
:test
#'neq
))
125 (results (remove :res vars
:key
#'reg-spec-kind
:test
#'neq
))
126 (return-style (or (cadr (assoc :return-style options
)) :raw
))
127 (cost (or (cadr (assoc :cost options
)) 247))
128 (vop (make-symbol "VOP")))
129 (unless (member return-style
'(:raw
:full-call
:none
))
130 (error "unknown return-style for ~S: ~S" name return-style
))
132 (call-sequence call-temps
)
133 (generate-call-sequence name return-style vop
)
134 `(define-vop ,(if (atom name
) (list name
) name
)
135 (:args
,@(mapcar #'arg-or-res-spec args
))
137 (mapcar (lambda (arg)
138 `(:temporary
(:sc
,(reg-spec-sc arg
)
139 :offset
,(reg-spec-offset arg
)
140 :from
(:argument
,(incf index
))
142 ,(reg-spec-temp arg
)))
144 ,@(mapcar (lambda (temp)
145 `(:temporary
(:sc
,(reg-spec-sc temp
)
146 :offset
,(reg-spec-offset temp
)
149 ,(reg-spec-name temp
)))
154 (mapcar (lambda (res)
155 `(:temporary
(:sc
,(reg-spec-sc res
)
156 :offset
,(reg-spec-offset res
)
158 :to
(:result
,(incf index
))
159 :target
,(reg-spec-name res
))
160 ,(reg-spec-temp res
)))
162 (:results
,@(mapcar #'arg-or-res-spec results
))
163 (:ignore
,@(mapcar #'reg-spec-name temps
)
166 (remove :ignore call-temps
167 :test
#'neq
:key
#'car
))))
168 ,@(remove-if (lambda (x)
169 (member x
'(:return-style
:cost
)))
173 ,@(mapcar (lambda (arg)
174 #!+(or hppa alpha
) `(move ,(reg-spec-name arg
)
175 ,(reg-spec-temp arg
))
176 #!-
(or hppa alpha
) `(move ,(reg-spec-temp arg
)
177 ,(reg-spec-name arg
)))
180 ,@(mapcar (lambda (res)
181 #!+(or hppa alpha
) `(move ,(reg-spec-temp res
)
182 ,(reg-spec-name res
))
183 #!-
(or hppa alpha
) `(move ,(reg-spec-name res
)
184 ,(reg-spec-temp res
)))
187 (def!macro define-assembly-routine
(name&options vars
&body code
)
188 (multiple-value-bind (name options
)
189 (if (atom name
&options
)
190 (values name
&options nil
)
191 (values (car name
&options
)
193 (let ((regs (mapcar (lambda (var) (apply #'parse-reg-spec var
)) vars
)))
194 (if *emit-assembly-code-not-vops-p
*
195 (emit-assemble name options regs code
)
196 (emit-vop name options regs
)))))