/[cmucl]/src/assembly/assemfile.lisp
ViewVC logotype

Contents of /src/assembly/assemfile.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (show annotations)
Mon Jan 6 15:10:15 2003 UTC (11 years, 3 months ago) by toy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.37: +2 -2 lines
Precede compiler messages with a semi-colon.  Error messages don't
have the semi-colon prefix.
1 ;;; -*- Package: C -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/assembly/assemfile.lisp,v 1.38 2003/01/06 15:10:15 toy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the extra code necessary to feed an entire file of
13 ;;; assembly code to the assembler.
14 ;;;
15 (in-package "C")
16
17 (export '(define-assembly-routine))
18
19
20 (defvar *do-assembly* nil
21 "If non-NIL, emit assembly code. If NIL, emit VOP templates.")
22
23 (defvar *lap-output-file* nil
24 "The FASL file currently being output to.")
25
26 (defvar *assembler-routines* nil
27 "A List of (name . label) for every entry point.")
28
29 (defun assemble-file (name &key
30 (output-file
31 (make-pathname :defaults name
32 :type "assem"))
33 trace-file)
34 (let* ((*do-assembly* t)
35 (name (pathname name))
36 (*lap-output-file* (open-fasl-file (pathname output-file) name))
37 (*assembler-routines* nil)
38 (*load-verbose* nil)
39 (won nil)
40 (*code-segment* nil)
41 (*elsewhere* nil)
42 (*assembly-optimize* nil)
43 (*compiler-trace-output* nil)
44 (*fixups* nil)
45 (*coalesce-constants* t))
46 (unwind-protect
47 (let ((*features* (cons :assembler (backend-features *backend*))))
48 (when trace-file
49 (setf *compiler-trace-output*
50 (open (if (eq trace-file t)
51 (make-pathname :defaults name
52 :type "trace")
53 trace-file)
54 :direction :output
55 :if-exists :supersede)))
56 (init-assembler)
57 (load (merge-pathnames name (make-pathname :type "lisp")))
58 (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
59 *lap-output-file*)
60 (new-assem:append-segment *code-segment* *elsewhere*)
61 (setf *elsewhere* nil)
62 (let ((length (new-assem:finalize-segment *code-segment*)))
63 (dump-assembler-routines *code-segment*
64 length
65 *fixups*
66 *assembler-routines*
67 *lap-output-file*))
68 (setq won t))
69 (new-assem:release-segment *code-segment*)
70 (when *elsewhere*
71 (new-assem:release-segment *elsewhere*))
72 (when *compiler-trace-output*
73 (close *compiler-trace-output*))
74 (close-fasl-file *lap-output-file* (not won)))
75 won))
76
77
78
79 (defstruct (reg-spec
80 (:print-function %print-reg-spec))
81 (kind :temp :type (member :arg :temp :res))
82 (name nil :type symbol)
83 (temp nil :type symbol)
84 (scs nil :type (or list symbol))
85 (offset nil))
86
87 (defun %print-reg-spec (spec stream depth)
88 (declare (ignore depth))
89 (format stream
90 "#<reg ~S ~S scs=~S offset=~S>"
91 (reg-spec-kind spec)
92 (reg-spec-name spec)
93 (reg-spec-scs spec)
94 (reg-spec-offset spec)))
95
96 (defun reg-spec-sc (spec)
97 (if (atom (reg-spec-scs spec))
98 (reg-spec-scs spec)
99 (car (reg-spec-scs spec))))
100
101 (defun parse-reg-spec (kind name sc offset)
102 (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
103 (ecase kind
104 (:temp)
105 ((:arg :res)
106 (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
107 reg))
108
109
110 (defun emit-assemble (name options regs code)
111 (collect ((decls))
112 (loop
113 (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
114 (decls (pop code))
115 (return)))
116 `(let (,@(mapcar
117 #'(lambda (reg)
118 `(,(reg-spec-name reg)
119 (make-random-tn
120 :kind :normal
121 :sc (sc-or-lose ',(reg-spec-sc reg))
122 :offset ,(reg-spec-offset reg))))
123 regs))
124 ,@(decls)
125 (new-assem:assemble (*code-segment* ',name)
126 ,name
127 (push (cons ',name ,name) *assembler-routines*)
128 ,@code
129 ,@(generate-return-sequence
130 (or (cadr (assoc :return-style options)) :raw)))
131 (when *compile-print*
132 (format *error-output* "; ~S assembled~%" ',name)))))
133
134 (defun arg-or-res-spec (reg)
135 `(,(reg-spec-name reg)
136 :scs ,(if (atom (reg-spec-scs reg))
137 (list (reg-spec-scs reg))
138 (reg-spec-scs reg))
139 ,@(unless (eq (reg-spec-kind reg) :res)
140 `(:target ,(reg-spec-temp reg)))))
141
142 (defun emit-vop (name options vars)
143 (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
144 (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
145 (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
146 (return-style (or (cadr (assoc :return-style options)) :raw))
147 (cost (or (cadr (assoc :cost options)) 247))
148 (vop (make-symbol "VOP")))
149 (unless (member return-style '(:raw :full-call :none))
150 (error "Unknown return-style for ~S: ~S" name return-style))
151 (multiple-value-bind
152 (call-sequence call-temps)
153 (let ((*backend* *target-backend*))
154 (generate-call-sequence name return-style vop))
155 `(define-vop ,(if (atom name) (list name) name)
156 (:args ,@(mapcar #'arg-or-res-spec args))
157 ,@(let ((index -1))
158 (mapcar #'(lambda (arg)
159 `(:temporary (:sc ,(reg-spec-sc arg)
160 :offset ,(reg-spec-offset arg)
161 :from (:argument ,(incf index))
162 :to (:eval 2))
163 ,(reg-spec-temp arg)))
164 args))
165 ,@(mapcar #'(lambda (temp)
166 `(:temporary (:sc ,(reg-spec-sc temp)
167 :offset ,(reg-spec-offset temp)
168 :from (:eval 1)
169 :to (:eval 3))
170 ,(reg-spec-name temp)))
171 temps)
172 ,@call-temps
173 (:vop-var ,vop)
174 ,@(let ((index -1))
175 (mapcar #'(lambda (res)
176 `(:temporary (:sc ,(reg-spec-sc res)
177 :offset ,(reg-spec-offset res)
178 :from (:eval 2)
179 :to (:result ,(incf index))
180 :target ,(reg-spec-name res))
181 ,(reg-spec-temp res)))
182 results))
183 (:results ,@(mapcar #'arg-or-res-spec results))
184 (:ignore ,@(mapcar #'reg-spec-name temps)
185 ,@(apply #'append
186 (mapcar #'cdr
187 (remove :ignore call-temps
188 :test-not #'eq :key #'car))))
189 ,@(remove-if #'(lambda (x)
190 (member x '(:return-style :cost)))
191 options
192 :key #'car)
193 (:generator ,cost
194 ,@(mapcar #'(lambda (arg)
195 (if (or (target-featurep :hppa)
196 (target-featurep :alpha))
197 `(move ,(reg-spec-name arg)
198 ,(reg-spec-temp arg))
199 `(move ,(reg-spec-temp arg)
200 ,(reg-spec-name arg))))
201 args)
202 ,@call-sequence
203 ,@(mapcar #'(lambda (res)
204 (if (or (target-featurep :hppa)
205 (target-featurep :alpha))
206 `(move ,(reg-spec-temp res)
207 ,(reg-spec-name res))
208 `(move ,(reg-spec-name res)
209 ,(reg-spec-temp res))))
210 results))))))
211
212 (defmacro define-assembly-routine (name&options vars &rest code)
213 (multiple-value-bind (name options)
214 (if (atom name&options)
215 (values name&options nil)
216 (values (car name&options)
217 (cdr name&options)))
218 (let* ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
219 (if *do-assembly*
220 (emit-assemble name options regs code)
221 (emit-vop name options regs)))))

  ViewVC Help
Powered by ViewVC 1.1.5