/[cmucl]/src/bootfiles/18d/boot4-cross-foreign-linkage-sparc.lisp
ViewVC logotype

Contents of /src/bootfiles/18d/boot4-cross-foreign-linkage-sparc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Oct 24 20:39:46 2002 UTC (11 years, 5 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, UNICODE-BRANCH, 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
Initial revision
1 (in-package "USER")
2
3 ;;; Rename the X86 package and backend so that new-backend does the
4 ;;; right thing.
5 (rename-package "SPARC" "OLD-SPARC")
6 (setf (c:backend-name c:*native-backend*) "OLD-SPARC")
7
8 ;;; Sparc to Sparc current cross compile.
9 ;#+nil
10 (c::new-backend "SPARC"
11 '(:new-assembler :complex-fp-vops :sparc-v9 :hash-new
12 :random-mt19937
13 :cmu18 :cmu18d :sparc
14 :relative-package-names
15 :linkage-table)
16 '(:gencgc :x86 :x86-bootstrap :alpha :osf1 :mips :pentium :cgc
17 :mp :i486 :long-float :new-random)
18 )
19
20 #|
21 (load "target:tools/setup" :if-source-newer :load-source)
22 (comf "target:tools/setup" :load t)
23 |#
24
25 (setf *interactive* nil)
26 (setf *gc-verbose* nil)
27
28 ;;; Extern-alien-name for the new backend.
29 (in-package "VM")
30 (defun extern-alien-name (name)
31 (declare (type simple-string name))
32 name)
33 (export 'extern-alien-name)
34 (export 'fixup-code-object)
35 (export 'sanctify-for-execution)
36
37 (in-package "USER")
38
39 ;;; So compilation of make-fixup will work.
40 (setf (get 'lisp::fop-foreign-data-fixup 'lisp::fop-code) 150)
41
42 ;;; Compile the new backend.
43 (pushnew :bootstrap *features*)
44 (pushnew :building-cross-compiler *features*)
45
46 (load "target:tools/comcom")
47 (comf "target:code/foreign-linkage")
48
49 ;;; Load the new backend.
50 (setf (search-list "c:")
51 '("target:compiler/"))
52 (setf (search-list "vm:")
53 '("c:sparc/" "c:generic/"))
54 (setf (search-list "assem:")
55 '("target:assembly/" "target:assembly/sparc/"))
56 ;;; Note: may need to add extra files to load to loadbackend, perhaps
57 ;;; float-tran and srctran; try to follow the order in comcom as this
58 ;;; is often important.
59
60 ;; Load the backend of the compiler.
61
62 (in-package "C")
63
64 (load "vm:vm-macs")
65 (load "vm:parms")
66 (load "vm:objdef")
67 (load "vm:interr")
68 (load "assem:support")
69
70 (load "target:compiler/srctran")
71 (load "vm:vm-typetran")
72 (load "target:compiler/float-tran")
73 (load "target:compiler/saptran")
74
75 (load "vm:macros")
76 (load "vm:utils")
77
78 (load "vm:vm")
79 (load "vm:insts")
80 (load "vm:primtype")
81 (load "vm:move")
82 (load "vm:sap")
83 (load "vm:system")
84 (load "vm:char")
85 (load "vm:float")
86
87 (load "vm:memory")
88 (load "vm:static-fn")
89 (load "vm:arith")
90 (load "vm:cell")
91 (load "vm:subprim")
92 (load "vm:debug")
93 (load "vm:c-call")
94 (load "vm:print")
95 (load "vm:alloc")
96 (load "vm:call")
97 (load "vm:nlx")
98 (load "vm:values")
99 (load "vm:array")
100 (load "vm:pred")
101 (load "vm:type-vops")
102
103 (load "assem:assem-rtns")
104
105 (load "assem:array")
106 (load "assem:arith")
107 (load "assem:alloc")
108
109 (load "c:pseudo-vops")
110
111 (check-move-function-consistency)
112
113 (load "target:code/foreign-linkage")
114 (load "target:compiler/dump")
115
116 (load "vm:new-genesis")
117
118 ;;; OK, the cross compiler backend is loaded.
119
120 (setf *features* (remove :building-cross-compiler *features*))
121
122 ;;; Info environment hacks.
123 (macrolet ((frob (&rest syms)
124 `(progn ,@(mapcar #'(lambda (sym)
125 `(defconstant ,sym
126 (symbol-value
127 (find-symbol ,(symbol-name sym)
128 :vm))))
129 syms))))
130 (frob OLD-SPARC:BYTE-BITS OLD-SPARC:WORD-BITS
131 #+long-float OLD-SPARC:SIMPLE-ARRAY-LONG-FLOAT-TYPE
132 OLD-SPARC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
133 OLD-SPARC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
134 #+long-float OLD-SPARC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
135 OLD-SPARC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
136 OLD-SPARC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
137 OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
138 OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
139 OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
140 OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
141 OLD-SPARC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
142 OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
143 OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
144 OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
145 OLD-SPARC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
146 OLD-SPARC:SIMPLE-BIT-VECTOR-TYPE
147 OLD-SPARC:SIMPLE-STRING-TYPE OLD-SPARC:SIMPLE-VECTOR-TYPE
148 OLD-SPARC:SIMPLE-ARRAY-TYPE OLD-SPARC:VECTOR-DATA-OFFSET
149 OLD-SPARC:CERROR-TRAP OLD-SPARC:ERROR-TRAP
150 OLD-SPARC::LOWTAG-BITS
151 OLD-SPARC:CATCH-BLOCK-SIZE
152 ))
153
154 (let ((function (symbol-function 'kernel:error-number-or-lose)))
155 (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
156 (setf (symbol-function 'kernel:error-number-or-lose) function)
157 (setf (info function kind 'kernel:error-number-or-lose) :function)
158 (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
159
160 (defun fix-class (name)
161 (let* ((new-value (find-class name))
162 (new-layout (kernel::class-layout new-value))
163 (new-cell (kernel::find-class-cell name))
164 (*info-environment* (c:backend-info-environment c:*target-backend*)))
165 (remhash name kernel::*forward-referenced-layouts*)
166 (kernel::%note-type-defined name)
167 (setf (info type kind name) :instance)
168 (setf (info type class name) new-cell)
169 (setf (info type compiler-layout name) new-layout)
170 new-value))
171 (fix-class 'c::vop-parse)
172 (fix-class 'c::operand-parse)
173
174 #+random-mt19937
175 (declaim (notinline kernel:random-chunk))
176
177 (setf c:*backend* c:*target-backend*)
178
179 ;;; Ready to build.
180 (pushnew :bootstrap *features*)
181
182 #+nil
183 (let* ((old-package :old-sparc)
184 (sym (find-symbol "ANY-REG" old-package)))
185 (unintern sym (symbol-package sym))
186 ;;(import sym :sparc)
187 (import sym old-package)
188 )
189
190 ;; hack, hack, hack: Make old-sparc::any-reg the same as
191 ;; sparc::any-reg as an SC. Do this by adding old-sparc::any-reg to
192 ;; the hash table with the same value as sparc::any-reg.
193 (let ((ht (c::backend-sc-names c::*target-backend*)))
194 (setf (gethash 'old-sparc::any-reg ht)
195 (gethash 'sparc::any-reg ht)))
196
197 (in-package "ALIEN")
198
199 (defun %def-alien-variable (lisp-name alien-name type)
200 (setf (info variable kind lisp-name) :alien)
201 (setf (info variable where-from lisp-name) :defined)
202 (clear-info variable constant-value lisp-name)
203 (setf (info variable alien-info lisp-name)
204 (make-heap-alien-info :type type
205 :sap-form `(foreign-symbol-address
206 ',alien-name :flavor :data))))
207 (defmacro extern-alien (name type)
208 "Access the alien variable named NAME, assuming it is of type TYPE. This
209 is setfable."
210 (let* ((alien-name (etypecase name
211 (symbol (guess-alien-name-from-lisp-name name))
212 (string name)))
213 (alien-type (parse-alien-type type))
214 (flavor (if (alien-function-type-p alien-type)
215 :code
216 :data)))
217 `(%heap-alien ',(make-heap-alien-info
218 :type alien-type
219 :sap-form `(foreign-symbol-address ',alien-name
220 :flavor ',flavor)))))
221
222 (defmacro with-alien (bindings &body body)
223 "Establish some local alien variables. Each BINDING is of the form:
224 VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
225 ALLOCATION should be one of:
226 :LOCAL (the default)
227 The alien is allocated on the stack, and has dynamic extent.
228 :STATIC
229 The alien is allocated on the heap, and has infinate extent. The alien
230 is allocated at load time, so the same piece of memory is used each time
231 this form executes.
232 :EXTERN
233 No alien is allocated, but VAR is established as a local name for
234 the external alien given by EXTERNAL-NAME."
235 (with-auxiliary-alien-types
236 (dolist (binding (reverse bindings))
237 (destructuring-bind
238 (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
239 binding
240 (let* ((alien-type (parse-alien-type type))
241 (flavor (if (alien-function-type-p alien-type)
242 :code
243 :data)))
244 (multiple-value-bind
245 (allocation initial-value)
246 (if opt2p
247 (values opt1 opt2)
248 (case opt1
249 (:extern
250 (values opt1 (guess-alien-name-from-lisp-name symbol)))
251 (:static
252 (values opt1 nil))
253 (t
254 (values :local opt1))))
255 (setf body
256 (ecase allocation
257 #+nil
258 (:static
259 (let ((sap
260 (make-symbol (concatenate 'string "SAP-FOR-"
261 (symbol-name symbol)))))
262 `((let ((,sap (load-time-value (%make-alien ...))))
263 (declare (type system-area-pointer ,sap))
264 (symbol-macrolet
265 ((,symbol (sap-alien ,sap ,type)))
266 ,@(when initial-value
267 `((setq ,symbol ,initial-value)))
268 ,@body)))))
269 (:extern
270 (let ((info (make-heap-alien-info
271 :type alien-type
272 :sap-form `(foreign-symbol-address
273 ',initial-value
274 :flavor ',flavor))))
275 `((symbol-macrolet
276 ((,symbol (%heap-alien ',info)))
277 ,@body))))
278 (:local
279 (let ((var (gensym))
280 (initval (if initial-value (gensym)))
281 (info (make-local-alien-info
282 :type alien-type)))
283 `((let ((,var (make-local-alien ',info))
284 ,@(when initial-value
285 `((,initval ,initial-value))))
286 (note-local-alien-type ',info ,var)
287 (multiple-value-prog1
288 (symbol-macrolet
289 ((,symbol (local-alien ',info ,var)))
290 ,@(when initial-value
291 `((setq ,symbol ,initval)))
292 ,@body)
293 (dispose-local-alien ',info ,var)
294 )))))))))))
295 (verify-local-auxiliaries-okay)
296 `(compiler-let ((*auxiliary-type-definitions*
297 ',(append *new-auxiliary-types*
298 *auxiliary-type-definitions*)))
299 ,@body)))
300
301 (defparameter cl-user::*load-stuff* nil)
302
303 #|
304 (load "target:tools/worldcom")
305 (load "target:tools/comcom")
306
307 ;;; If worldbuild produces a warning that "The C header file has
308 ;;; changed." then it will be necessary to recompile the C code, and
309 ;;; run worldload again.
310 (load "target:tools/worldbuild")
311 (quit)
312 |#

  ViewVC Help
Powered by ViewVC 1.1.5