/[cmucl]/src/code/x86-vm.lisp
ViewVC logotype

Diff of /src/code/x86-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by dtc, Wed Dec 17 22:46:29 1997 UTC revision 1.12 by dtc, Fri Jan 16 07:22:13 1998 UTC
# Line 125  Line 125 
125    
126    
127    
128  ;;; FIXUP-CODE-OBJECT -- Interface  ;;; Fixup-Code-Object -- Interface
129    ;;;
130  ;;; This gets called by LOAD to resolve newly positioned objects  ;;; This gets called by LOAD to resolve newly positioned objects
131  ;;; with things (like code instructions) that have to refer to them.  ;;; with things (like code instructions) that have to refer to them.
132    ;;;
133  ;;; Add a fixup offset to the vector of fixup offsets for the given  ;;; Add a fixup offset to the vector of fixup offsets for the given
134  ;;; code object.  ;;; code object.
135  ;;;  ;;;
136  ;;; Counter to measure the storage overhead.  ;;; Counter to measure the storage overhead.
137  (defvar *num-fixups* 0)  (defvar *num-fixups* 0)
138  ;;;  ;;;
 (defun 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) x86: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)))))))  
   
   
139  (defun fixup-code-object (code offset fixup kind)  (defun fixup-code-object (code offset fixup kind)
140    (declare (type index offset))    (declare (type index offset))
141    (system:without-gcing    (flet ((add-fixup (code offset)
142     (let* ((sap (truly-the system-area-pointer (c::code-instructions code)))             ;; Although this could check for and ignore fixups for code
143            (obj-start-addr (logand (kernel::get-lisp-obj-address code)             ;; objects in the read-only and static spaces, this should
144                                    #xfffffff8))             ;; only be the case when *enable-dynamic-space-code* is
145            #+nil (const-start-addr (+ obj-start-addr (* 5 4)))             ;; True.
146            (code-start-addr (c::sap-int (kernel::code-instructions code)))             (when lisp::*enable-dynamic-space-code*
147            (ncode-words (kernel::code-header-ref code 1))               (incf *num-fixups*)
148            (code-end-addr (+ code-start-addr (* ncode-words 4))))               (let ((fixups (code-header-ref code code-constants-offset)))
149       (unless (member kind '(:absolute :relative))                 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
150         (error "Unknown code-object-fixup kind ~s." kind))                        (let ((new-fixups
151       (ecase kind                               (adjust-array fixups (1+ (length fixups))
152         (:absolute                                             :element-type '(unsigned-byte 32))))
153          ;; word at sap + offset contains a value to be replaced by                          (setf (aref new-fixups (length fixups)) offset)
154          ;; adding that value to fixup.                          (setf (code-header-ref code code-constants-offset)
155          (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))                                new-fixups)))
156          ;; Record absolute fixups that point within the code object.                       (t
157          (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)                        (unless (or (eq (get-type fixups) vm:unbound-marker-type)
158            (add-fixup code offset)))                                    (zerop fixups))
159         (:relative                          (format t "** Init. code FU = ~s~%" fixups))
160          ;; Fixup is the actual address wanted.                        (setf (code-header-ref code code-constants-offset)
161          ;;                              (make-array 1 :element-type '(unsigned-byte 32)
162          ;; Record relative fixups that point outside the code object.                                          :initial-element offset))))))))
163          (when (or (< fixup obj-start-addr) (> fixup code-end-addr))      (system:without-gcing
164            (add-fixup code offset))       (let* ((sap (truly-the system-area-pointer
165          ;; Replace word with value to add to that loc to get there.                              (kernel:code-instructions code)))
166          (let* ((loc-sap (+ (sap-int sap) offset))              (obj-start-addr (logand (kernel:get-lisp-obj-address code)
167                 (rel-val (- fixup loc-sap 4)))                                      #xfffffff8))
168            (declare (type (unsigned-byte 32) loc-sap)              #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
169                     (type (signed-byte 32) rel-val))              (code-start-addr (sys:sap-int (kernel:code-instructions code)))
170            (setf (signed-sap-ref-32 sap offset) rel-val))))))              (ncode-words (kernel:code-header-ref code 1))
171    nil)              (code-end-addr (+ code-start-addr (* ncode-words 4))))
172           (unless (member kind '(:absolute :relative))
173             (error "Unknown code-object-fixup kind ~s." kind))
174           (ecase kind
175             (:absolute
176              ;; Word at sap + offset contains a value to be replaced by
177              ;; adding that value to fixup.
178              (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
179              ;; Record absolute fixups that point within the code object.
180              (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
181                (add-fixup code offset)))
182             (:relative
183              ;; Fixup is the actual address wanted.
184              ;;
185              ;; Record relative fixups that point outside the code
186              ;; object.
187              (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
188                (add-fixup code offset))
189              ;; Replace word with value to add to that loc to get there.
190              (let* ((loc-sap (+ (sap-int sap) offset))
191                     (rel-val (- fixup loc-sap 4)))
192                (declare (type (unsigned-byte 32) loc-sap)
193                         (type (signed-byte 32) rel-val))
194                (setf (signed-sap-ref-32 sap offset) rel-val))))))
195        nil))
196    
197    ;;; Do-Load-Time-Code-Fixups
198    ;;;
199    ;;; Add a code fixup to a code object generated by new-genesis. The
200    ;;; fixup has already been applied, it's just a matter of placing the
201    ;;; fixup in the code's fixup vector if necessary.
202    ;;;
203    #+gencgc
204    (defun do-load-time-code-fixup (code offset fixup kind)
205      (flet ((add-load-time-code-fixup (code offset)
206               (let ((fixups (code-header-ref code vm:code-constants-offset)))
207                 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
208                        (let ((new-fixups
209                               (adjust-array fixups (1+ (length fixups))
210                                             :element-type '(unsigned-byte 32))))
211                          (setf (aref new-fixups (length fixups)) offset)
212                          (setf (code-header-ref code vm:code-constants-offset)
213                                new-fixups)))
214                       (t
215                        (unless (or (eq (get-type fixups) vm:unbound-marker-type)
216                                    (zerop fixups))
217                          (%primitive print "** Init. code FU"))
218                        (setf (code-header-ref code vm:code-constants-offset)
219                              (make-array 1 :element-type '(unsigned-byte 32)
220                                          :initial-element offset)))))))
221        (let* ((sap (truly-the system-area-pointer
222                               (kernel:code-instructions code)))
223               (obj-start-addr
224                (logand (kernel:get-lisp-obj-address code) #xfffffff8))
225               (code-start-addr (sys:sap-int (kernel:code-instructions code)))
226               (ncode-words (kernel:code-header-ref code 1))
227             (code-end-addr (+ code-start-addr (* ncode-words 4))))
228          (ecase kind
229            (:absolute
230             ;; Record absolute fixups that point within the
231             ;; code object.
232             (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
233               (add-load-time-code-fixup code offset)))
234            (:relative
235             ;; Record relative fixups that point outside the
236             ;; code object.
237             (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
238               (add-load-time-code-fixup code offset)))))))
239    
240    
241  ;;;; Internal-error-arguments.  ;;;; Internal-error-arguments.
# Line 419  Line 463 
463  (defvar *fp-constant-1d0* 1d0)  (defvar *fp-constant-1d0* 1d0)
464    
465  ;;; Enable/Disable scavenging of the read-only space.  ;;; Enable/Disable scavenging of the read-only space.
466  (defvar *scavenge-read-only-space*)  (defvar *scavenge-read-only-space* nil)
467    
468  ;;; The current alien stack pointer; saved/restored for non-local  ;;; The current alien stack pointer; saved/restored for non-local
469  ;;; exits.  ;;; exits.
# Line 432  Line 476 
476    "Atomically compare object's slot value to test-value and if EQ store    "Atomically compare object's slot value to test-value and if EQ store
477     new-value in the slot. The original value of the slot is returned."     new-value in the slot. The original value of the slot is returned."
478    (kernel::%instance-set-conditional object slot test-value new-value))    (kernel::%instance-set-conditional object slot test-value new-value))
479    
480    ;;; Support for the MT19937 random number generator. The update
481    ;;; function is implemented as an assembly routine. This definition is
482    ;;; transformed to a call to this routine allowing its use in byte
483    ;;; compiled code.
484    ;;;
485    (defun random-mt19937 (state)
486      (declare (type (simple-array (unsigned-byte 32) (627)) state))
487      (random-mt19937 state))

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

  ViewVC Help
Powered by ViewVC 1.1.5