| ... |
... |
@@ -119,7 +119,7 @@ |
|
119
|
119
|
:cmu
|
|
120
|
120
|
:cmu21
|
|
121
|
121
|
:cmu21d
|
|
122
|
|
- ;;:double-double
|
|
|
122
|
+ :double-double
|
|
123
|
123
|
:sse2
|
|
124
|
124
|
:relocatable-stacks
|
|
125
|
125
|
:unicode
|
| ... |
... |
@@ -131,7 +131,8 @@ |
|
131
|
131
|
:long-float :new-random :small
|
|
132
|
132
|
:alien-callback
|
|
133
|
133
|
:modular-arith
|
|
134
|
|
- :double-double))
|
|
|
134
|
+ ;;:double-double
|
|
|
135
|
+ ))
|
|
135
|
136
|
|
|
136
|
137
|
(print c::*target-backend*)
|
|
137
|
138
|
(print (c::backend-features c::*target-backend*))
|
| ... |
... |
@@ -200,8 +201,75 @@ |
|
200
|
201
|
OLD-X86:PENDING-INTERRUPT-TRAP
|
|
201
|
202
|
OLD-X86:HALT-TRAP
|
|
202
|
203
|
OLD-X86:FUNCTION-END-BREAKPOINT-TRAP
|
|
|
204
|
+
|
|
|
205
|
+ OLD-X86:UNBOUND-MARKER-TYPE
|
|
203
|
206
|
))
|
|
204
|
207
|
|
|
|
208
|
+(in-package :vm)
|
|
|
209
|
+(defun fixup-code-object (code offset fixup kind)
|
|
|
210
|
+ (declare (type index offset))
|
|
|
211
|
+ (flet ((add-fixup (code offset)
|
|
|
212
|
+ ;; Although this could check for and ignore fixups for code
|
|
|
213
|
+ ;; objects in the read-only and static spaces, this should
|
|
|
214
|
+ ;; only be the case when *enable-dynamic-space-code* is
|
|
|
215
|
+ ;; True.
|
|
|
216
|
+ (when lisp::*enable-dynamic-space-code*
|
|
|
217
|
+ (incf *num-fixups*)
|
|
|
218
|
+ (let ((fixups (code-header-ref code code-constants-offset)))
|
|
|
219
|
+ (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
|
|
|
220
|
+ (let ((new-fixups
|
|
|
221
|
+ (adjust-array fixups (1+ (length fixups))
|
|
|
222
|
+ :element-type '(unsigned-byte 32))))
|
|
|
223
|
+ (setf (aref new-fixups (length fixups)) offset)
|
|
|
224
|
+ (setf (code-header-ref code code-constants-offset)
|
|
|
225
|
+ new-fixups)))
|
|
|
226
|
+ (t
|
|
|
227
|
+ (unless (or (eq (get-type fixups) vm:unbound-marker-type)
|
|
|
228
|
+ (zerop fixups))
|
|
|
229
|
+ (format t "** Init. code FU = ~s~%" fixups))
|
|
|
230
|
+ (setf (code-header-ref code code-constants-offset)
|
|
|
231
|
+ (make-array 1 :element-type '(unsigned-byte 32)
|
|
|
232
|
+ :initial-element offset))))))))
|
|
|
233
|
+ (system:without-gcing
|
|
|
234
|
+ (let* ((sap (truly-the system-area-pointer
|
|
|
235
|
+ (kernel:code-instructions code)))
|
|
|
236
|
+ (obj-start-addr (logand (kernel:get-lisp-obj-address code)
|
|
|
237
|
+ #xfffffff8))
|
|
|
238
|
+ #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
|
|
|
239
|
+ (code-start-addr (sys:sap-int (kernel:code-instructions code)))
|
|
|
240
|
+ (ncode-words (kernel:code-header-ref code 1))
|
|
|
241
|
+ (code-end-addr (+ code-start-addr (* ncode-words 8))))
|
|
|
242
|
+ (unless (member kind '(:absolute :relative))
|
|
|
243
|
+ (error (intl:gettext "Unknown code-object-fixup kind ~s.") kind))
|
|
|
244
|
+ (ecase kind
|
|
|
245
|
+ (:absolute
|
|
|
246
|
+ ;; Word at sap + offset contains a value to be replaced by
|
|
|
247
|
+ ;; adding that value to fixup.
|
|
|
248
|
+ (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
|
|
|
249
|
+ ;; Record absolute fixups that point within the code object.
|
|
|
250
|
+ (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
|
|
|
251
|
+ (add-fixup code offset)))
|
|
|
252
|
+ (:relative
|
|
|
253
|
+ ;; Fixup is the actual address wanted.
|
|
|
254
|
+ ;;
|
|
|
255
|
+ ;; Record relative fixups that point outside the code
|
|
|
256
|
+ ;; object.
|
|
|
257
|
+ (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
|
|
|
258
|
+ (add-fixup code offset))
|
|
|
259
|
+ ;; Replace word with value to add to that loc to get there.
|
|
|
260
|
+ (let* ((loc-sap (+ (sap-int sap) offset))
|
|
|
261
|
+ (rel-val (- fixup loc-sap 4)))
|
|
|
262
|
+ (declare (type (unsigned-byte 32) loc-sap)
|
|
|
263
|
+ (type (signed-byte 32) rel-val))
|
|
|
264
|
+ (setf (signed-sap-ref-32 sap offset) rel-val))))))
|
|
|
265
|
+ nil))
|
|
|
266
|
+(export 'fixup-code-object)
|
|
|
267
|
+
|
|
|
268
|
+(defun sanctify-for-execution (component)
|
|
|
269
|
+ (declare (ignore component))
|
|
|
270
|
+ nil)
|
|
|
271
|
+(export 'sanctify-for-execution)
|
|
|
272
|
+
|
|
205
|
273
|
(in-package :cl-user)
|
|
206
|
274
|
|
|
207
|
275
|
(load "target:tools/comcom")
|