/[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.2 by pw, Sun Apr 13 21:07:29 1997 UTC revision 1.2.2.1 by pw, Tue Jun 23 11:22:39 1998 UTC
# Line 6  Line 6 
6  ;;; If you want to use this code or any part of CMU Common Lisp, please contact  ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;;  ;;;
9  ;(ext:file-comment  (ext:file-comment
10  ;  "$Header$")    "$Header$")
11  ;;;  ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; This file contains the X86 specific runtime stuff.  ;;; This file contains the X86 specific runtime stuff.
15  ;;;  ;;;
16    
17  (in-package :vm)  (in-package "X86")
18  (use-package "SYSTEM")  (use-package "SYSTEM")
19  (use-package "ALIEN")  (use-package "ALIEN")
20  (use-package "C-CALL")  (use-package "C-CALL")
21  (use-package "UNIX")  (use-package "UNIX")
22  (use-package :kernel)  (use-package "KERNEL")
23    
24  (export '(fixup-code-object internal-error-arguments  (export '(fixup-code-object internal-error-arguments
25            sigcontext-program-counter sigcontext-register            sigcontext-program-counter sigcontext-register
26            sigcontext-float-register sigcontext-floating-point-modes            sigcontext-float-register sigcontext-floating-point-modes
27            extern-alien-name sanctify-for-execution            extern-alien-name sanctify-for-execution))
           alternate-get-global-address))  
28    
29    
30  ;;;; The sigcontext structure.  ;;;; The sigcontext structure.
# Line 126  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
134    ;;; code object.
135    ;;;
136    ;;; Counter to measure the storage overhead.
137    (defvar *num-fixups* 0)
138    ;;;
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       (unless (member kind '(:absolute :relative))             ;; objects in the read-only and static spaces, this should
144         (error "Unknown code-object-fixup kind ~s." kind))             ;; only be the case when *enable-dynamic-space-code* is
145       (ecase kind             ;; True.
146         (:absolute             (when lisp::*enable-dynamic-space-code*
147          ;; word at sap + offset contains a value to be replaced by               (incf *num-fixups*)
148          ;; adding that value to fixup.               (let ((fixups (code-header-ref code code-constants-offset)))
149          (setf (sap-ref-32 sap offset)                 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
150                (+ fixup (sap-ref-32 sap offset))))                        (let ((new-fixups
151         (:relative                               (adjust-array fixups (1+ (length fixups))
152          ;; fixup is actual address wanted. replace word with value                                             :element-type '(unsigned-byte 32))))
153          ;; to add to that loc to get there.                          (setf (aref new-fixups (length fixups)) offset)
154          ;; (format t "x86-fixup ~a ~x ~x ~a~&" code offset fixup kind)                          (setf (code-header-ref code code-constants-offset)
155          (let* ((loc-sap (+ (sap-int sap) offset))                                new-fixups)))
156                 (rel-val (- fixup loc-sap 4)))                       (t
157            (declare (type (unsigned-byte 32) loc-sap)                        (unless (or (eq (get-type fixups) vm:unbound-marker-type)
158                     (type (signed-byte 32) rel-val))                                    (zerop fixups))
159            ;;(format t "sap ~x ~x ~x~&" (sap-int sap) loc-sap rel-val)                          (format t "** Init. code FU = ~s~%" fixups))
160            (setf (sap-ref-32 sap offset)  rel-val)) ))))                        (setf (code-header-ref code code-constants-offset)
161    nil)                              (make-array 1 :element-type '(unsigned-byte 32)
162                                            :initial-element offset))))))))
163        (system:without-gcing
164         (let* ((sap (truly-the system-area-pointer
165                                (kernel:code-instructions code)))
166                (obj-start-addr (logand (kernel:get-lisp-obj-address code)
167                                        #xfffffff8))
168                #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
169                (code-start-addr (sys:sap-int (kernel:code-instructions code)))
170                (ncode-words (kernel:code-header-ref code 1))
171                (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 211  Line 293 
293        (#.edx-offset (slot scp 'sc-edx))        (#.edx-offset (slot scp 'sc-edx))
294        (#.ebx-offset (slot scp 'sc-ebx))        (#.ebx-offset (slot scp 'sc-ebx))
295        (#.esp-offset (slot scp 'sc-sp))        (#.esp-offset (slot scp 'sc-sp))
296  #-linux      (#.ebp-offset (slot scp 'sc-fp))        (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
 #+linux      (#.ebp-offset (slot scp 'ebp))  
297        (#.esi-offset (slot scp 'sc-esi))        (#.esi-offset (slot scp 'sc-esi))
298        (#.edi-offset (slot scp 'sc-edi)))))        (#.edi-offset (slot scp 'sc-edi)))))
299    
# Line 226  Line 307 
307        (#.edx-offset (setf (slot scp 'sc-edx) new))        (#.edx-offset (setf (slot scp 'sc-edx) new))
308        (#.ebx-offset (setf (slot scp 'sc-ebx) new))        (#.ebx-offset (setf (slot scp 'sc-ebx) new))
309        (#.esp-offset (setf (slot scp 'sc-sp)  new))        (#.esp-offset (setf (slot scp 'sc-sp)  new))
310  #-linux      (#.ebp-offset (setf (slot scp 'sc-fp)  new))        (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp)  new))
 #+linux      (#.ebp-offset (setf (slot scp 'ebp)  new))  
311        (#.esi-offset (setf (slot scp 'sc-esi) new))        (#.esi-offset (setf (slot scp 'sc-esi) new))
312        (#.edi-offset (setf (slot scp 'sc-edi) new))))        (#.edi-offset (setf (slot scp 'sc-edi) new))))
313    new)    new)
# Line 239  Line 319 
319  ;;;  ;;;
320  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.  ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
321  ;;; Format is the type of float to return.  ;;; Format is the type of float to return.
322  ;;; XXX  ;;;
 #-linux  
 (defun sigcontext-float-register (scp index format)  
   (declare (type (alien (* sigcontext)) scp))  
   (with-alien ((scp (* sigcontext) scp))  
     ;; fp regs not in sigcontext -- need new vop or c support  
     (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs))))  
       (declare (ignore sap))  
       index  
       (ecase format  
         (single-float 0s0  
          #+nil (system:sap-ref-single sap (* index vm:word-bytes)))  
         (double-float 0d0  
          #+nil(system:sap-ref-double sap (* index vm:word-bytes)))))))  
   
323  #+linux  #+linux
324  (defun sigcontext-float-register (scp index format)  (defun sigcontext-float-register (scp index format)
325    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
326    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* sigcontext) scp))
     ;; fp regs in sigcontext !!!  
327      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
328                                              'fpreg)                                             'fpreg)
329                                       index))))                                       index))))
330        (ecase format        (coerce (sys:sap-ref-long reg-sap 0) format))))
331          (single-float  
332            (system:sap-ref-single reg-sap 0))  ;;; Not supported on FreeBSD because the floating point state is not
333          (double-float  ;;; saved.
334            (system:sap-ref-double reg-sap 0))))))  #+FreeBSD
335    (defun sigcontext-float-register (scp index format)
336      (declare (ignore scp index))
337      (coerce 0l0 format))
338    
 ;;;  
 #-linux  
 (defun %set-sigcontext-float-register (scp index format new-value)  
   (declare (type (alien (* sigcontext)) scp))  
   scp index format new-value  
   #+nil  
   (with-alien ((scp (* sigcontext) scp))  
     (let ((sap (alien-sap (slot scp 'fpregs))))  
       (ecase format  
         (single-float  
          (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))  
         (double-float  
          (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))  
339  #+linux  #+linux
340  (defun %set-sigcontext-float-register (scp index format new-value)  (defun %set-sigcontext-float-register (scp index format new-value)
341    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
# Line 288  Line 343 
343      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)      (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
344                                              'fpreg)                                              'fpreg)
345                                       index))))                                       index))))
346        (ecase format        (declare (ignorable reg-sap))
347          (single-float        #+not-yet
348           (setf (system:sap-ref-single reg-sap 0) new-value))        (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
349          (double-float        (coerce new-value format))))
          (setf (system:sap-ref-double reg-sap 0)new-value))))))  
350    
351  ;;;  ;;; Not supported on FreeBSD.
352    #+FreeBSD
353    (defun %set-sigcontext-float-register (scp index format new-value)
354      (declare (ignore scp index))
355      (coerce new-value format))
356    
357    ;;;
358  (defsetf sigcontext-float-register %set-sigcontext-float-register)  (defsetf sigcontext-float-register %set-sigcontext-float-register)
359    
360  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface  ;;; SIGCONTEXT-FLOATING-POINT-MODES  --  Interface
# Line 329  Line 388 
388  ;;; The loader uses this to convert alien names to the form they occure in  ;;; The loader uses this to convert alien names to the form they occure in
389  ;;; the symbol table (for example, prepending an underscore).  ;;; the symbol table (for example, prepending an underscore).
390  ;;;  ;;;
 ;;; On the x86 under FreeBSD, we prepend an underscore. If this is not  
 ;;; done under Linux then this is the place to make the change.  
 ;;;  
391  (defun extern-alien-name (name)  (defun extern-alien-name (name)
392    (declare (type simple-string name))    (declare (type simple-string name))
393    (lisp:concatenate 'string #+linux "" #-linux "_" name))    name)
   
 ;;; This used to live in foreign.lisp but it gets loaded too late  
 ;;; to be useful. This gets used by the loader to map lisp foreign  
 ;;; symbol names to the OS's version of it. This was added for the  
 ;;; Linux port -- maybe it makes the above extern-alien-name  
 ;;; obsolete?  
 (defun system:alternate-get-global-address(symbol)  
   (declare (type simple-string symbol))  
   (let ((namex symbol)  
         (table lisp::*foreign-symbols*)) ; defined in load.lisp  
     (cond ((gethash namex table nil))  
 #+linux   ((gethash (concatenate 'string "PVE_stub_" namex) table nil))  
 #+linux   ((gethash (concatenate 'string "" namex) table nil)) ; Linux  
 #+freebsd ((gethash (concatenate 'string "_" namex) table nil)); FreeBSD  
           ((gethash (concatenate 'string "__" namex) table nil))  
           ((gethash (concatenate 'string "__libc_" namex) table nil))  
           (t (progn (format t "Error: can't be in alt-get-gl-addr ~a" namex)  
         ;; returning 0 is VERY dangerous!  
                 0)))))  
394    
395    (defun lisp::foreign-symbol-address-aux (name)
396      (multiple-value-bind (value found)
397          (gethash name lisp::*foreign-symbols* 0)
398        (if found
399            value
400            (multiple-value-bind (value found)
401                (gethash
402                 (concatenate 'string #+linux "PVE_stub_" #+freebsd "_" name)
403                 lisp::*foreign-symbols* 0)
404              (if found
405                  value
406                  (let ((value (system:alternate-get-global-address name)))
407                    (when (zerop value)
408                      (error "Unknown foreign symbol: ~S" name))
409                    value))))))
410    
411    
412  ;;; SANCTIFY-FOR-EXECUTION -- Interface.  ;;; SANCTIFY-FOR-EXECUTION -- Interface.
413  ;;;  ;;;
414  ;;; Do whatever is necessary to make the given code component executable.  ;;; Do whatever is necessary to make the given code component
415  ;;; On the sparc, we don't need to do anything, because the i and d caches  ;;; executable - nothing on the x86.
 ;;; are unified.  
416  ;;;  ;;;
417  (defun sanctify-for-execution (component)  (defun sanctify-for-execution (component)
418    (declare (ignore component))    (declare (ignore component))
# Line 371  Line 422 
422  ;;;  ;;;
423  ;;; This is used in error.lisp to insure floating-point  exceptions  ;;; This is used in error.lisp to insure floating-point  exceptions
424  ;;; are properly trapped. The compiler translates this to a VOP.  ;;; are properly trapped. The compiler translates this to a VOP.
425  ;;; Note: if you are compiling this from an old version you may need  ;;;
 ;;; to disable this until the float-wait VOP is entrenched.  
426  (defun float-wait()  (defun float-wait()
427    (float-wait))    (float-wait))
428    
429  ;;; FLOAT CONSTANTS  ;;; FLOAT CONSTANTS
430  ;;;  ;;;
431  ;;; These are used by the FP move-from-{single|double} VOPs  ;;; These are used by the FP move-from-{single|double} VOPs rather
432  ;;; rather than the i387 load constant instructions to avoid  ;;; than the i387 load constant instructions to avoid consing in some
433  ;;; consing in some cases.  ;;; cases. Note these are initialise by genesis as they are needed
434    ;;; early.
435  (defvar *fp-constant-0s0* 0s0)  ;;;
436  (defvar *fp-constant-0d0* 0d0)  (defvar *fp-constant-0s0*)
437  (defvar *fp-constant-1s0* 1s0)  (defvar *fp-constant-1s0*)
438  (defvar *fp-constant-1d0* 1d0)  (defvar *fp-constant-0d0*)
439    (defvar *fp-constant-1d0*)
440    ;;; The long-float constants.
441    (defvar *fp-constant-0l0*)
442    (defvar *fp-constant-1l0*)
443    (defvar *fp-constant-pi*)
444    (defvar *fp-constant-l2t*)
445    (defvar *fp-constant-l2e*)
446    (defvar *fp-constant-lg2*)
447    (defvar *fp-constant-ln2*)
448    
449    ;;; Enable/Disable scavenging of the read-only space.
450    (defvar *scavenge-read-only-space* nil)
451    
452    ;;; The current alien stack pointer; saved/restored for non-local
453    ;;; exits.
454    (defvar *alien-stack*)
455    
456    ;;;
457    (defun kernel::%instance-set-conditional (object slot test-value new-value)
458      (declare (type instance object)
459               (type index slot))
460      "Atomically compare object's slot value to test-value and if EQ store
461       new-value in the slot. The original value of the slot is returned."
462      (kernel::%instance-set-conditional object slot test-value new-value))
463    
464    ;;; Support for the MT19937 random number generator. The update
465    ;;; function is implemented as an assembly routine. This definition is
466    ;;; transformed to a call to this routine allowing its use in byte
467    ;;; compiled code.
468    ;;;
469    (defun random-mt19937 (state)
470      (declare (type (simple-array (unsigned-byte 32) (627)) state))
471      (random-mt19937 state))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.2.2.1

  ViewVC Help
Powered by ViewVC 1.1.5