/[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.21 by moore, Tue Aug 27 22:18:25 2002 UTC revision 1.22 by rtoy, Wed Jul 7 15:03:11 2004 UTC
# Line 103  Line 103 
103          (sc-sp      unsigned-int)          (sc-sp      unsigned-int)
104          (sc-ss      unsigned-int)))          (sc-ss      unsigned-int)))
105    
106  ;;; OpenBSD/NetBSD also have sigcontext structs that look more like Linux.  ;;; OpenBSD also have sigcontext structs that look more like Linux.
107  #+openbsd  #+openbsd
108  (def-alien-type sigcontext  (def-alien-type sigcontext
109      (struct nil      (struct nil
# Line 129  Line 129 
129          (sc-err     unsigned-int)          (sc-err     unsigned-int)
130          ))          ))
131    
132  #+netbsd  ;; NetBSD
133    
134    #+netbsd1.6
135  (def-alien-type sigcontext  (def-alien-type sigcontext
136      (struct nil      (struct nil
137          (sc-gs      unsigned-int)          (sc-gs      unsigned-int)
# Line 157  Line 159 
159          (sc-mask    (array unsigned-int 4))          (sc-mask    (array unsigned-int 4))
160          ))          ))
161    
162    #+netbsd
163    (def-alien-type sigaltstack
164      (struct nil
165          (ss-sp    unsigned-int)
166          (ss-size  unsigned-int)
167          (ss-flags unsigned-int)))
168    
169    #+netbsd
170    (def-alien-type mcontext
171      (struct nil
172          (mc-gs    unsigned-long)
173          (mc-fs    unsigned-long)
174          (mc-es    unsigned-long)
175          (mc-ds    unsigned-long)
176          (mc-edi   unsigned-long)
177          (mc-esi   unsigned-long)
178          (mc-ebp   unsigned-long)
179          (mc-esp   unsigned-long)
180          (mc-ebx   unsigned-long)
181          (mc-edx   unsigned-long)
182          (mc-ecx   unsigned-long)
183          (mc-eax   unsigned-long)
184          (mc-trapno        unsigned-long)
185          (mc-err   unsigned-long)
186          (mc-eip   unsigned-long)
187          (mc-cs    unsigned-long)
188          (mc-efl   unsigned-long)
189          (mc-uesp  unsigned-long)
190          (mc-ss    unsigned-long)))
191    
192    #+netbsd
193    (def-alien-type ucontext
194      (struct nil
195              (uc-flags     unsigned-long)
196              (uc-link      unsigned-long)
197              (uc-sigmask   (array unsigned-long 4))
198              (uc-stack     sigaltstack)
199              (uc-mcontext  mcontext)))
200    
201    
202  ;; For Linux...  ;; For Linux...
203  #+linux  #+linux
204  (def-alien-type sigcontext  (def-alien-type sigcontext
# Line 328  Line 370 
370  ;;; Given the sigcontext, extract the internal error arguments from the  ;;; Given the sigcontext, extract the internal error arguments from the
371  ;;; instruction stream.  ;;; instruction stream.
372  ;;;  ;;;
373    #-netbsd
374  (defun internal-error-arguments (scp)  (defun internal-error-arguments (scp)
375    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
376    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* sigcontext) scp))
# Line 351  Line 394 
394                (sc-offsets (c::read-var-integer vector index)))                (sc-offsets (c::read-var-integer vector index)))
395              (values error-number (sc-offsets))))))))              (values error-number (sc-offsets))))))))
396    
397    #+netbsd
398    (defun internal-error-arguments (ucp)
399      (declare (type (alien (* ucontext)) ucp))
400      (%primitive print "internal-error-arguments")
401      (with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
402        (let ((pc (int-sap (slot mcp 'mc-eip))))
403          (declare (type system-area-pointer pc))
404          ;; using INT3 the pc is .. INT3 <here> code length bytes...
405          (let* ((length (sap-ref-8 pc 1))
406                 (vector (make-array length :element-type '(unsigned-byte 8))))
407            (declare (type (unsigned-byte 8) length)
408                     (type (simple-array (unsigned-byte 8) (*)) vector))
409            (copy-from-system-area pc (* vm:byte-bits 2)
410                                   vector (* vm:word-bits
411                                             vm:vector-data-offset)
412                                   (* length vm:byte-bits))
413            (let* ((index 0)
414                   (error-number (c::read-var-integer vector index)))
415              (collect ((sc-offsets))
416                (loop
417                  (when (>= index length)
418                    (return))
419                  (sc-offsets (c::read-var-integer vector index)))
420                (values error-number (sc-offsets))))))))
421    
422  ;;;; Sigcontext access functions.  ;;;; Sigcontext access functions.
423    
424  ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.  ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
425  ;;;  ;;;
426    #-netbsd
427  (defun sigcontext-program-counter (scp)  (defun sigcontext-program-counter (scp)
428    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
429    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* sigcontext) scp))
430      (int-sap (slot scp 'sc-pc))))      (int-sap (slot scp 'sc-pc))))
431    
432    #+netbsd
433    (defun sigcontext-program-counter (ucp)
434      (declare (type (alien (* ucontext)) ucp))
435      (with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
436        (int-sap (slot mcp 'sc-eip))))
437    
438  ;;; SIGCONTEXT-REGISTER -- Interface.  ;;; SIGCONTEXT-REGISTER -- Interface.
439  ;;;  ;;;
440  ;;; An escape register saves the value of a register for a frame that someone  ;;; An escape register saves the value of a register for a frame that someone
441  ;;; interrupts.  ;;; interrupts.
442  ;;;  ;;;
443    
444    #-netbsd
445  (defun sigcontext-register (scp index)  (defun sigcontext-register (scp index)
446    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
447    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* sigcontext) scp))
# Line 380  Line 455 
455        (#.esi-offset (slot scp 'sc-esi))        (#.esi-offset (slot scp 'sc-esi))
456        (#.edi-offset (slot scp 'sc-edi)))))        (#.edi-offset (slot scp 'sc-edi)))))
457    
458    #-netbsd
459  (defun %set-sigcontext-register (scp index new)  (defun %set-sigcontext-register (scp index new)
460    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))
461    (with-alien ((scp (* sigcontext) scp))    (with-alien ((scp (* sigcontext) scp))
# Line 395  Line 470 
470        (#.edi-offset (setf (slot scp 'sc-edi) new))))        (#.edi-offset (setf (slot scp 'sc-edi) new))))
471    new)    new)
472    
473    #+netbsd
474    (defun sigcontext-register (ucp index)
475      (declare (type (alien (* ucontext)) ucp))
476      (with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
477        (case index                         ; ugly -- I know.
478          (#.eax-offset (slot mcp 'mc-eax))
479          (#.ecx-offset (slot mcp 'mc-ecx))
480          (#.edx-offset (slot mcp 'mc-edx))
481          (#.ebx-offset (slot mcp 'mc-ebx))
482          (#.esp-offset (slot mcp 'mc-esp))
483          (#.ebp-offset (slot mcp 'mc-ebp))
484          (#.esi-offset (slot mcp 'mc-esi))
485          (#.edi-offset (slot mcp 'mc-edi)))))
486    
487    #+netbsd
488    (defun %set-sigcontext-register (ucp index new)
489      (declare (type (alien (* ucontext)) ucp))
490      (with-alien ((mcp (* mcontext) (slot ucp 'uc-mcontext)))
491        (case index
492          (#.eax-offset (setf (slot mcp 'mc-eax) new))
493          (#.ecx-offset (setf (slot mcp 'mc-ecx) new))
494          (#.edx-offset (setf (slot mcp 'mc-edx) new))
495          (#.ebx-offset (setf (slot mcp 'mc-ebx) new))
496          (#.esp-offset (setf (slot mcp 'mc-esp) new))
497          (#.ebp-offset (setf (slot mcp 'mc-ebp) new))
498          (#.esi-offset (setf (slot mcp 'mc-esi) new))
499          (#.edi-offset (setf (slot mcp 'mc-edi) new))))
500      new)
501    
502  (defsetf sigcontext-register %set-sigcontext-register)  (defsetf sigcontext-register %set-sigcontext-register)
503    
504    
# Line 446  Line 550 
550  ;;; same format as returned by FLOATING-POINT-MODES.  ;;; same format as returned by FLOATING-POINT-MODES.
551  ;;;  ;;;
552    
553  #+BSD  #+(or freebsd openbsd)
554  (defun sigcontext-floating-point-modes (scp)  (defun sigcontext-floating-point-modes (scp)
555    (declare (type (alien (* sigcontext)) scp)    (declare (type (alien (* sigcontext)) scp)
556             (ignore scp))             (ignore scp))
557    ;; This is broken until some future release of FreeBSD/OpenBSD!!!    ;; This is broken until some future release of FreeBSD/OpenBSD!!!
558    (floating-point-modes))    (floating-point-modes))
559    
560    #+netbsd
561    (defun sigcontext-floating-point-modes (ucp)
562      (declare (type (alien (* ucontext)) ucp)
563               (ignore ucp))
564      (floating-point-modes))
565    
566  #+linux  #+linux
567  (defun sigcontext-floating-point-modes (scp)  (defun sigcontext-floating-point-modes (scp)
568    (declare (type (alien (* sigcontext)) scp))    (declare (type (alien (* sigcontext)) scp))

Legend:
Removed from v.1.21  
changed lines
  Added in v.1.22

  ViewVC Help
Powered by ViewVC 1.1.5