/[cmucl]/src/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp
ViewVC logotype

Contents of /src/bootfiles/19c/boot-2006-06-1-cross-dd-ppc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Jun 30 18:41:21 2006 UTC (7 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, 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, 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, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2007-01, snapshot-2007-02, release-19e, release-19d, GIT-CONVERSION, unicode-utf16-sync-2008-12, cross-sol-x86-merged, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, RELEASE_20b, snapshot-2008-04, 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, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, 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, pre-merge-intl-branch, release-19d-base, release-19e-pre1, 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, label-2009-03-25, cross-sol-x86-2010-12-20, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, sse2-merge-with-2008-11, sse2-merge-with-2008-10, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, cross-sparc-branch-base, release-19e-base, intl-branch-base, unicode-utf16-base, portable-clx-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-07, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, release-19d-branch, sse2-packed-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +245 -0 lines
This large checkin merges the double-double float support to HEAD.
The merge is from the tag "double-double-irrat-end".  The
double-double branch is now obsolete.

The code should build without double-double support (tested on sparc)
as well as build with double-double support (tested also on sparc).
1 (in-package :cl-user)
2
3 ;;; Rename the X86 package and backend so that new-backend does the
4 ;;; right thing.
5 (rename-package "PPC" "OLD-PPC")
6 (setf (c:backend-name c:*native-backend*) "OLD-PPC")
7
8 (c::new-backend "PPC"
9 ;; Features to add here
10 '(:ppc
11 :new-assembler
12 :conservative-float-type
13 :hash-new
14 :random-mt19937
15 :darwin :bsd
16 :cmu :cmu19 :cmu19c
17 :relative-package-names ; Relative package names from Allegro
18 :linkage-table
19 :modular-arith
20 :double-double ; Double-double float support
21 :gencgc ; Generational gc
22 )
23 ;; Features to remove from current *features* here
24 '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro
25 :propagate-fun-type :propagate-float-type :constrain-float-type
26 :openbsd :freebsd :glibc2 :linux :pentium :elf :mp
27 :stack-checking :heap-overflow-check
28 :cgc :long-float :new-random :small))
29
30 ;;; Extern-alien-name for the new backend.
31 (in-package :vm)
32 (defun extern-alien-name (name)
33 (declare (type simple-string name))
34 (concatenate 'string "_" name))
35 (export 'extern-alien-name)
36 (export 'fixup-code-object)
37 (export 'sanctify-for-execution)
38
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 ;;; Things needed to cross-compile double-double changes.
41 (in-package "KERNEL")
42
43 (eval-when (compile load eval)
44 (c:defknown double-double-float-p (t)
45 boolean
46 (c:movable c:foldable c:flushable))
47 )
48
49 (eval-when (compile load eval)
50 (handler-bind ((error (lambda (c)
51 (declare (ignore c))
52 (invoke-restart 'continue))))
53 (defconstant type-test-ordering
54 '(fixnum single-float double-float integer #+long-float long-float
55 double-double-float bignum
56 complex ratio))
57 ))
58
59 (eval-when (compile load eval)
60 (handler-bind ((error (lambda (c)
61 (declare (ignore c))
62 (invoke-restart 'continue))))
63 (defconstant float-formats
64 '(double-double-float long-float double-float single-float short-float))))
65
66 (in-package "LISP")
67 (define-fop (fop-double-double-float 67)
68 (prepare-for-fast-read-byte *fasl-file*
69 (prog1
70 (let ((hi-lo (fast-read-u-integer 4))
71 (hi-hi (fast-read-s-integer 4))
72 (lo-lo (fast-read-u-integer 4))
73 (lo-hi (fast-read-s-integer 4)))
74 (kernel::make-double-double-float
75 (make-double-float hi-hi hi-lo)
76 (make-double-float lo-hi lo-lo)))
77 (done-with-fast-read-byte))))
78 ;; End changes for double-double
79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80
81 ;;; Compile the new backend.
82 (pushnew :bootstrap *features*)
83 (pushnew :building-cross-compiler *features*)
84 (load "target:tools/comcom")
85
86 ;;; Load the new backend.
87 (setf (search-list "c:")
88 '("target:compiler/"))
89 (setf (search-list "vm:")
90 '("c:ppc/" "c:generic/"))
91 (setf (search-list "assem:")
92 '("target:assembly/" "target:assembly/ppc/"))
93
94 ;; Load the backend of the compiler.
95
96 (in-package "C")
97
98 (load "vm:vm-macs")
99 (load "vm:parms")
100 (load "vm:objdef")
101 (load "vm:interr")
102 (load "assem:support")
103
104 (load "target:compiler/srctran")
105 (load "vm:vm-typetran")
106 (load "target:compiler/float-tran")
107 (load "target:compiler/saptran")
108
109 (load "vm:macros")
110 (load "vm:utils")
111
112 (load "vm:vm")
113 (load "vm:insts")
114 (load "vm:primtype")
115 (load "vm:move")
116 (load "vm:sap")
117 (load "vm:system")
118 (load "vm:char")
119 (load "vm:float")
120
121 (load "vm:memory")
122 (load "vm:static-fn")
123 (load "vm:arith")
124 (load "vm:cell")
125 (load "vm:subprim")
126 (load "vm:debug")
127 (load "vm:c-call")
128 (load "vm:print")
129 (load "vm:alloc")
130 (load "vm:call")
131 (load "vm:nlx")
132 (load "vm:values")
133 (load "vm:array")
134 (load "vm:pred")
135 (load "vm:type-vops")
136
137 (load "assem:assem-rtns")
138
139 (load "assem:array")
140 (load "assem:arith")
141 (load "assem:alloc")
142
143 (load "c:pseudo-vops")
144
145 (check-move-function-consistency)
146
147 (load "vm:new-genesis")
148
149 ;;; OK, the cross compiler backend is loaded.
150
151 (setf *features* (remove :building-cross-compiler *features*))
152
153 ;;; Info environment hacks.
154 (macrolet ((frob (&rest syms)
155 `(progn ,@(mapcar #'(lambda (sym)
156 `(handler-bind ((error #'(lambda (c)
157 (declare (ignore c))
158 (invoke-restart 'kernel::continue))))
159 (defconstant ,sym
160 (symbol-value
161 (find-symbol ,(symbol-name sym)
162 :vm)))))
163 syms))))
164 (frob OLD-PPC:BYTE-BITS OLD-PPC:WORD-BITS
165 #+long-float OLD-PPC:SIMPLE-ARRAY-LONG-FLOAT-TYPE
166 OLD-PPC:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
167 OLD-PPC:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
168 #+long-float OLD-PPC:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
169 OLD-PPC:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
170 OLD-PPC:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
171 OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
172 OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
173 OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
174 OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
175 OLD-PPC:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
176 OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
177 OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
178 OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
179 OLD-PPC:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
180 OLD-PPC:SIMPLE-BIT-VECTOR-TYPE
181 OLD-PPC:SIMPLE-STRING-TYPE OLD-PPC:SIMPLE-VECTOR-TYPE
182 OLD-PPC:SIMPLE-ARRAY-TYPE OLD-PPC:VECTOR-DATA-OFFSET
183 ))
184
185 (let ((function (symbol-function 'kernel:error-number-or-lose)))
186 (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
187 (setf (symbol-function 'kernel:error-number-or-lose) function)
188 (setf (info function kind 'kernel:error-number-or-lose) :function)
189 (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
190
191 (defun fix-class (name)
192 (let* ((new-value (find-class name))
193 (new-layout (kernel::%class-layout new-value))
194 (new-cell (kernel::find-class-cell name))
195 (*info-environment* (c:backend-info-environment c:*target-backend*)))
196 (remhash name kernel::*forward-referenced-layouts*)
197 (kernel::%note-type-defined name)
198 (setf (info type kind name) :instance)
199 (setf (info type class name) new-cell)
200 (setf (info type compiler-layout name) new-layout)
201 new-value))
202 (fix-class 'c::vop-parse)
203 (fix-class 'c::operand-parse)
204
205 #+random-mt19937
206 (declaim (notinline kernel:random-chunk))
207
208 (setf c:*backend* c:*target-backend*)
209
210 ;;; Extern-alien-name for the new backend.
211 (in-package :vm)
212 (defun extern-alien-name (name)
213 (declare (type simple-string name))
214 (concatenate 'string "_" name))
215 (export 'extern-alien-name)
216 (export 'fixup-code-object)
217 (export 'sanctify-for-execution)
218
219 (in-package :cl-user)
220
221 ;;; Don't load compiler parts from the target compilation
222
223 (defparameter *load-stuff* nil)
224
225 ;; hack, hack, hack: Make old-x86::any-reg the same as
226 ;; x86::any-reg as an SC. Do this by adding old-x86::any-reg
227 ;; to the hash table with the same value as x86::any-reg.
228
229 (let ((ht (c::backend-sc-names c::*target-backend*)))
230 (setf (gethash 'old-ppc::any-reg ht)
231 (gethash 'ppc::any-reg ht)))
232
233 ;; A hack for ppc. Make sure the vop, move-double-to-int-arg, is
234 ;; available in both the OLD-PPC and new PPC package. (I don't know
235 ;; why this is needed, but it seems to be.)
236 (let ((ht (c::backend-template-names c::*target-backend*)))
237 (dolist (syms '((old-ppc::move-double-to-int-arg
238 ppc::move-double-to-int-arg)
239 (old-ppc::move-single-to-int-arg
240 ppc::move-single-to-int-arg)))
241 (destructuring-bind (old new)
242 syms
243 (setf (gethash old
244 ht)
245 (gethash new ht)))))

  ViewVC Help
Powered by ViewVC 1.1.5