[Git][cmucl/cmucl][rtoy-amd64-p1] 3 commits: More fixups
Raymond Toy
gitlab at common-lisp.net
Sun Apr 5 18:56:39 UTC 2020
Raymond Toy pushed to branch rtoy-amd64-p1 at cmucl / cmucl
Commits:
0f51a429 by Raymond Toy at 2020-04-05T11:54:45-07:00
More fixups
* Enable `:double-double`. I think it will be hard to build without it
now.
* Frob `unbound-marker-type` too
* Implement `fixup-code-object` and `sanctify-for-execution`. (Copied
from amd64-vm.lisp)
- - - - -
9781b724 by Raymond Toy at 2020-04-05T11:55:59-07:00
Get rid of dylan-function-header
It's never used anywhere. Use #+double-double to enable double-double
objects.
- - - - -
1459e4fd by Raymond Toy at 2020-04-05T11:56:26-07:00
Get rid of dylan-function-header from function-header-types
- - - - -
3 changed files:
- src/compiler/amd64/type-vops.lisp
- src/compiler/generic/objdef.lisp
- src/tools/cross-scripts/cross-x86-amd64.lisp
Changes:
=====================================
src/compiler/amd64/type-vops.lisp
=====================================
@@ -32,7 +32,7 @@
(defparameter function-header-types
- (list funcallable-instance-header-type dylan-function-header-type
+ (list funcallable-instance-header-type
byte-code-function-type byte-code-closure-type
function-header-type closure-function-header-type
closure-header-type))
=====================================
src/compiler/generic/objdef.lisp
=====================================
@@ -48,7 +48,7 @@
simple-array-complex-double-float-type
simple-array-complex-long-float-type))
-#+#.(c::target-featurep :double-double)
+#+double-double
(export '(double-double-float double-double-float-type
complex-double-double-float-type
simple-array-double-double-float-type
@@ -166,7 +166,7 @@
funcallable-instance-header
byte-code-function
byte-code-closure
- #-double-double dylan-function-header
+ ;;#-double-double dylan-function-header
closure-function-header
#-gengc return-pc-header
#+gengc forwarding-pointer
@@ -549,7 +549,7 @@
(real :c-type "long double" :length #+x86 3 #+sparc 4)
(imag :c-type "long double" :length #+x86 3 #+sparc 4))
-#+#.(c:target-featurep :double-double)
+#+double-double
(define-primitive-object (double-double-float
:lowtag other-pointer-type
:header double-double-float-type)
@@ -557,7 +557,7 @@
(hi :c-type "double" :length 2)
(lo :c-type "double" :length 2))
-#+#.(c:target-featurep :double-double)
+#+double-double
(define-primitive-object (complex-double-double-float
:lowtag other-pointer-type
:header complex-double-double-float-type)
=====================================
src/tools/cross-scripts/cross-x86-amd64.lisp
=====================================
@@ -119,7 +119,7 @@
:cmu
:cmu21
:cmu21d
- ;;:double-double
+ :double-double
:sse2
:relocatable-stacks
:unicode
@@ -131,7 +131,8 @@
:long-float :new-random :small
:alien-callback
:modular-arith
- :double-double))
+ ;;:double-double
+ ))
(print c::*target-backend*)
(print (c::backend-features c::*target-backend*))
@@ -200,8 +201,75 @@
OLD-X86:PENDING-INTERRUPT-TRAP
OLD-X86:HALT-TRAP
OLD-X86:FUNCTION-END-BREAKPOINT-TRAP
+
+ OLD-X86:UNBOUND-MARKER-TYPE
))
+(in-package :vm)
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (flet ((add-fixup (code offset)
+ ;; Although this could check for and ignore fixups for code
+ ;; objects in the read-only and static spaces, this should
+ ;; only be the case when *enable-dynamic-space-code* is
+ ;; True.
+ (when lisp::*enable-dynamic-space-code*
+ (incf *num-fixups*)
+ (let ((fixups (code-header-ref code code-constants-offset)))
+ (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
+ (let ((new-fixups
+ (adjust-array fixups (1+ (length fixups))
+ :element-type '(unsigned-byte 32))))
+ (setf (aref new-fixups (length fixups)) offset)
+ (setf (code-header-ref code code-constants-offset)
+ new-fixups)))
+ (t
+ (unless (or (eq (get-type fixups) vm:unbound-marker-type)
+ (zerop fixups))
+ (format t "** Init. code FU = ~s~%" fixups))
+ (setf (code-header-ref code code-constants-offset)
+ (make-array 1 :element-type '(unsigned-byte 32)
+ :initial-element offset))))))))
+ (system:without-gcing
+ (let* ((sap (truly-the system-area-pointer
+ (kernel:code-instructions code)))
+ (obj-start-addr (logand (kernel:get-lisp-obj-address code)
+ #xfffffff8))
+ #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
+ (code-start-addr (sys:sap-int (kernel:code-instructions code)))
+ (ncode-words (kernel:code-header-ref code 1))
+ (code-end-addr (+ code-start-addr (* ncode-words 8))))
+ (unless (member kind '(:absolute :relative))
+ (error (intl:gettext "Unknown code-object-fixup kind ~s.") kind))
+ (ecase kind
+ (:absolute
+ ;; Word at sap + offset contains a value to be replaced by
+ ;; adding that value to fixup.
+ (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
+ ;; Record absolute fixups that point within the code object.
+ (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+ (add-fixup code offset)))
+ (:relative
+ ;; Fixup is the actual address wanted.
+ ;;
+ ;; Record relative fixups that point outside the code
+ ;; object.
+ (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+ (add-fixup code offset))
+ ;; Replace word with value to add to that loc to get there.
+ (let* ((loc-sap (+ (sap-int sap) offset))
+ (rel-val (- fixup loc-sap 4)))
+ (declare (type (unsigned-byte 32) loc-sap)
+ (type (signed-byte 32) rel-val))
+ (setf (signed-sap-ref-32 sap offset) rel-val))))))
+ nil))
+(export 'fixup-code-object)
+
+(defun sanctify-for-execution (component)
+ (declare (ignore component))
+ nil)
+(export 'sanctify-for-execution)
+
(in-package :cl-user)
(load "target:tools/comcom")
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9ef4457ae51636453556be537a986f03760ad41e...1459e4fdb40ba5bab7a3d739de5645d979a74745
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9ef4457ae51636453556be537a986f03760ad41e...1459e4fdb40ba5bab7a3d739de5645d979a74745
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20200405/42b1b78f/attachment-0001.htm>
More information about the cmucl-cvs
mailing list