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/9ef4457ae51636453556be5...