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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Wed Nov 5 14:59:47 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.5: +3 -3 lines
Replace the allocation macros with a function, and pass the VOP
node-var as an optional argument so the allocation function can make
policy decisions (to inline with GENCGC).

Remove the make-complex-{single,double}-float functions, and just
define the VOPs as translations of the complex function.

Fix a few bugs in the complex-float move VOPs.
1 ram 1.1 ;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; 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.
8     ;;;
9     ;(ext:file-comment
10 dtc 1.6 ; "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.6 1997/11/05 14:59:47 dtc Exp $")
11 ram 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the X86 specific runtime stuff.
15     ;;;
16    
17 pw 1.2 (in-package :vm)
18 ram 1.1 (use-package "SYSTEM")
19     (use-package "ALIEN")
20     (use-package "C-CALL")
21     (use-package "UNIX")
22     (use-package :kernel)
23    
24     (export '(fixup-code-object internal-error-arguments
25     sigcontext-program-counter sigcontext-register
26     sigcontext-float-register sigcontext-floating-point-modes
27     extern-alien-name sanctify-for-execution
28     alternate-get-global-address))
29    
30    
31     ;;;; The sigcontext structure.
32     ;;;; Add machine specific features to *features*
33    
34     (pushnew :x86 *features*)
35    
36    
37    
38     #+linux
39     (def-alien-type nil
40     (struct fpreg
41     (significand (array unsigned-short 4))
42     (exponent unsigned-short)))
43     #+linux
44     (def-alien-type nil
45     (struct fpstate
46     (cw unsigned-long)
47     (sw unsigned-long)
48     (tag unsigned-long)
49     (ipoff unsigned-long)
50     (cssel unsigned-long)
51     (dataoff unsigned-long)
52     (datasel unsigned-long)
53     (fpreg (array (struct fpreg) 8))
54     (status unsigned-long)))
55    
56     ;;; for FreeBSD
57     #+freebsd
58     (def-alien-type sigcontext
59     (struct nil
60     (sc-onstack unsigned-int)
61     (sc-mask unsigned-int)
62     (sc-sp unsigned-int)
63     (sc-fp unsigned-int)
64     (sc-isp unsigned-int)
65     (sc-pc unsigned-int)
66     (sc-efl unsigned-int) ; sc_ps
67     (sc-es unsigned-int)
68     (sc-ds unsigned-int)
69     (sc-cs unsigned-int)
70     (sc-ss unsigned-int)
71     (sc-edi unsigned-int)
72     (sc-esi unsigned-int)
73     (sc-ebx unsigned-int)
74     (sc-edx unsigned-int)
75     (sc-ecx unsigned-int)
76     (sc-eax unsigned-int)))
77    
78     ;; For Linux...
79     #+linux
80     (def-alien-type sigcontext
81     (struct nil
82     (gs unsigned-short)
83     (__gsh unsigned-short)
84     (fs unsigned-short)
85     (__fsh unsigned-short)
86     (sc-es unsigned-short)
87     (__esh unsigned-short)
88     (sc-ds unsigned-short)
89     (__dsh unsigned-short)
90     (sc-edi unsigned-long)
91     (sc-esi unsigned-long)
92     (ebp unsigned-long)
93     (sc-sp unsigned-long)
94     (sc-ebx unsigned-long)
95     (sc-edx unsigned-long)
96     (sc-ecx unsigned-long)
97     (sc-eax unsigned-long)
98     (trapno unsigned-long)
99     (err unsigned-long)
100     (sc-pc unsigned-long)
101     (sc-cs unsigned-short)
102     (__csh unsigned-short)
103     (sc-efl unsigned-long)
104     (esp_at_signal unsigned-long)
105     (sc-ss unsigned-short)
106     (__ssh unsigned-short)
107     ; (fpstate unsigned-long) ;; fpstate struct pointer
108     (fpstate (* (struct fpstate)))
109     (sc-mask unsigned-long)
110     (cr2 unsigned-long)))
111    
112    
113    
114     ;;;; MACHINE-TYPE and MACHINE-VERSION
115    
116     #-cross-compiler
117     (defun machine-type ()
118     "Returns a string describing the type of the local machine."
119     "X86")
120    
121    
122     #-cross-compiler
123     (defun machine-version ()
124     "Returns a string describing the version of the local machine."
125     "X86")
126    
127    
128    
129     ;;; FIXUP-CODE-OBJECT -- Interface
130     ;;; This gets called by LOAD to resolve newly positioned objects
131     ;;; with things (like code instructions) that have to refer to them.
132    
133     (defun fixup-code-object (code offset fixup kind)
134     (declare (type index offset))
135     (system:without-gcing
136     (let ((sap (truly-the system-area-pointer (c::code-instructions code))))
137     (unless (member kind '(:absolute :relative))
138     (error "Unknown code-object-fixup kind ~s." kind))
139     (ecase kind
140     (:absolute
141     ;; word at sap + offset contains a value to be replaced by
142     ;; adding that value to fixup.
143     (setf (sap-ref-32 sap offset)
144     (+ fixup (sap-ref-32 sap offset))))
145     (:relative
146     ;; fixup is actual address wanted. replace word with value
147     ;; to add to that loc to get there.
148     ;; (format t "x86-fixup ~a ~x ~x ~a~&" code offset fixup kind)
149     (let* ((loc-sap (+ (sap-int sap) offset))
150     (rel-val (- fixup loc-sap 4)))
151     (declare (type (unsigned-byte 32) loc-sap)
152     (type (signed-byte 32) rel-val))
153     ;;(format t "sap ~x ~x ~x~&" (sap-int sap) loc-sap rel-val)
154     (setf (sap-ref-32 sap offset) rel-val)) ))))
155     nil)
156    
157    
158    
159     ;;;; Internal-error-arguments.
160    
161     ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
162     ;;;
163     ;;; Given the sigcontext, extract the internal error arguments from the
164     ;;; instruction stream.
165     ;;;
166     (defun internal-error-arguments (scp)
167     (declare (type (alien (* sigcontext)) scp))
168     (with-alien ((scp (* sigcontext) scp))
169     (let ((pc (int-sap (slot scp 'sc-pc))))
170     (declare (type system-area-pointer pc))
171     ;; using INT3 the pc is .. INT3 <here> code length bytes...
172     (let* ((length (sap-ref-8 pc 1))
173     (vector (make-array length :element-type '(unsigned-byte 8))))
174     (declare (type (unsigned-byte 8) length)
175     (type (simple-array (unsigned-byte 8) (*)) vector))
176     (copy-from-system-area pc (* vm:byte-bits 2)
177     vector (* vm:word-bits
178     vm:vector-data-offset)
179     (* length vm:byte-bits))
180     (let* ((index 0)
181     (error-number (c::read-var-integer vector index)))
182     (collect ((sc-offsets))
183     (loop
184     (when (>= index length)
185     (return))
186     (sc-offsets (c::read-var-integer vector index)))
187     (values error-number (sc-offsets))))))))
188    
189    
190     ;;;; Sigcontext access functions.
191    
192     ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
193     ;;;
194     (defun sigcontext-program-counter (scp)
195     (declare (type (alien (* sigcontext)) scp))
196     (with-alien ((scp (* sigcontext) scp))
197     (int-sap (slot scp 'sc-pc))))
198    
199     ;;; SIGCONTEXT-REGISTER -- Interface.
200     ;;;
201     ;;; An escape register saves the value of a register for a frame that someone
202     ;;; interrupts.
203     ;;;
204    
205     (defun sigcontext-register (scp index)
206     (declare (type (alien (* sigcontext)) scp))
207     (with-alien ((scp (* sigcontext) scp))
208     (case index ; ugly -- I know.
209     (#.eax-offset (slot scp 'sc-eax))
210     (#.ecx-offset (slot scp 'sc-ecx))
211     (#.edx-offset (slot scp 'sc-edx))
212     (#.ebx-offset (slot scp 'sc-ebx))
213     (#.esp-offset (slot scp 'sc-sp))
214     #-linux (#.ebp-offset (slot scp 'sc-fp))
215     #+linux (#.ebp-offset (slot scp 'ebp))
216     (#.esi-offset (slot scp 'sc-esi))
217     (#.edi-offset (slot scp 'sc-edi)))))
218    
219    
220     (defun %set-sigcontext-register (scp index new)
221     (declare (type (alien (* sigcontext)) scp))
222     (with-alien ((scp (* sigcontext) scp))
223     (case index
224     (#.eax-offset (setf (slot scp 'sc-eax) new))
225     (#.ecx-offset (setf (slot scp 'sc-ecx) new))
226     (#.edx-offset (setf (slot scp 'sc-edx) new))
227     (#.ebx-offset (setf (slot scp 'sc-ebx) new))
228     (#.esp-offset (setf (slot scp 'sc-sp) new))
229     #-linux (#.ebp-offset (setf (slot scp 'sc-fp) new))
230     #+linux (#.ebp-offset (setf (slot scp 'ebp) new))
231     (#.esi-offset (setf (slot scp 'sc-esi) new))
232     (#.edi-offset (setf (slot scp 'sc-edi) new))))
233     new)
234    
235     (defsetf sigcontext-register %set-sigcontext-register)
236    
237    
238     ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
239     ;;;
240     ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
241     ;;; Format is the type of float to return.
242     ;;; XXX
243     #-linux
244     (defun sigcontext-float-register (scp index format)
245     (declare (type (alien (* sigcontext)) scp))
246     (with-alien ((scp (* sigcontext) scp))
247     ;; fp regs not in sigcontext -- need new vop or c support
248     (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs))))
249     (declare (ignore sap))
250     index
251     (ecase format
252     (single-float 0s0
253     #+nil (system:sap-ref-single sap (* index vm:word-bytes)))
254     (double-float 0d0
255     #+nil(system:sap-ref-double sap (* index vm:word-bytes)))))))
256    
257     #+linux
258     (defun sigcontext-float-register (scp index format)
259     (declare (type (alien (* sigcontext)) scp))
260     (with-alien ((scp (* sigcontext) scp))
261     ;; fp regs in sigcontext !!!
262     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
263     'fpreg)
264     index))))
265     (ecase format
266     (single-float
267     (system:sap-ref-single reg-sap 0))
268     (double-float
269     (system:sap-ref-double reg-sap 0))))))
270    
271     ;;;
272     #-linux
273     (defun %set-sigcontext-float-register (scp index format new-value)
274     (declare (type (alien (* sigcontext)) scp))
275     scp index format new-value
276     #+nil
277     (with-alien ((scp (* sigcontext) scp))
278     (let ((sap (alien-sap (slot scp 'fpregs))))
279     (ecase format
280     (single-float
281     (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
282     (double-float
283     (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
284     #+linux
285     (defun %set-sigcontext-float-register (scp index format new-value)
286     (declare (type (alien (* sigcontext)) scp))
287     (with-alien ((scp (* sigcontext) scp))
288     (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
289     'fpreg)
290     index))))
291     (ecase format
292     (single-float
293     (setf (system:sap-ref-single reg-sap 0) new-value))
294     (double-float
295     (setf (system:sap-ref-double reg-sap 0)new-value))))))
296    
297     ;;;
298    
299     (defsetf sigcontext-float-register %set-sigcontext-float-register)
300    
301     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
302     ;;;
303     ;;; Given a sigcontext pointer, return the floating point modes word in the
304     ;;; same format as returned by FLOATING-POINT-MODES.
305     ;;;
306    
307     #+FreeBSD
308     (defun sigcontext-floating-point-modes (scp)
309     (declare (type (alien (* sigcontext)) scp)
310     (ignore scp))
311     ;; This is broken until some future release of FreeBSD!!!
312     (floating-point-modes))
313    
314     #+linux
315     (defun sigcontext-floating-point-modes (scp)
316     (declare (type (alien (* sigcontext)) scp))
317     (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
318     (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
319     ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
320     ;; NOT TESTED -- clear sticky bits to clear interrupt condition
321     (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
322     ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
323     ;; simulate floating-point-modes VOP
324     (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
325    
326    
327     ;;; EXTERN-ALIEN-NAME -- interface.
328     ;;;
329     ;;; The loader uses this to convert alien names to the form they occure in
330     ;;; the symbol table (for example, prepending an underscore).
331     ;;;
332     ;;; On the x86 under FreeBSD, we prepend an underscore. If this is not
333     ;;; done under Linux then this is the place to make the change.
334     ;;;
335     (defun extern-alien-name (name)
336     (declare (type simple-string name))
337     (lisp:concatenate 'string #+linux "" #-linux "_" name))
338    
339     ;;; This used to live in foreign.lisp but it gets loaded too late
340     ;;; to be useful. This gets used by the loader to map lisp foreign
341     ;;; symbol names to the OS's version of it. This was added for the
342     ;;; Linux port -- maybe it makes the above extern-alien-name
343     ;;; obsolete?
344     (defun system:alternate-get-global-address(symbol)
345     (declare (type simple-string symbol))
346     (let ((namex symbol)
347     (table lisp::*foreign-symbols*)) ; defined in load.lisp
348     (cond ((gethash namex table nil))
349     #+linux ((gethash (concatenate 'string "PVE_stub_" namex) table nil))
350     #+linux ((gethash (concatenate 'string "" namex) table nil)) ; Linux
351     #+freebsd ((gethash (concatenate 'string "_" namex) table nil)); FreeBSD
352     ((gethash (concatenate 'string "__" namex) table nil))
353     ((gethash (concatenate 'string "__libc_" namex) table nil))
354     (t (progn (format t "Error: can't be in alt-get-gl-addr ~a" namex)
355     ;; returning 0 is VERY dangerous!
356     0)))))
357    
358    
359    
360     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
361     ;;;
362     ;;; Do whatever is necessary to make the given code component executable.
363     ;;; On the sparc, we don't need to do anything, because the i and d caches
364     ;;; are unified.
365     ;;;
366     (defun sanctify-for-execution (component)
367     (declare (ignore component))
368     nil)
369    
370     ;;; FLOAT-WAIT
371     ;;;
372     ;;; This is used in error.lisp to insure floating-point exceptions
373     ;;; are properly trapped. The compiler translates this to a VOP.
374     ;;; Note: if you are compiling this from an old version you may need
375     ;;; to disable this until the float-wait VOP is entrenched.
376     (defun float-wait()
377     (float-wait))
378    
379     ;;; FLOAT CONSTANTS
380     ;;;
381     ;;; These are used by the FP move-from-{single|double} VOPs
382     ;;; rather than the i387 load constant instructions to avoid
383     ;;; consing in some cases.
384    
385     (defvar *fp-constant-0s0* 0s0)
386     (defvar *fp-constant-0d0* 0d0)
387     (defvar *fp-constant-1s0* 1s0)
388     (defvar *fp-constant-1d0* 1d0)
389 dtc 1.3
390     ;;; The current alien stack pointer; saved/restored for non-local
391     ;;; exits.
392     (defvar *alien-stack*)
393 dtc 1.4
394     ;;;
395     (defun kernel::%instance-set-conditional (object slot test-value new-value)
396     (declare (type instance object)
397     (type index slot))
398     "Atomically compare object's slot value to test-value and if EQ store
399     new-value in the slot. The original value of the slot is returned."
400     (kernel::%instance-set-conditional object slot test-value new-value))
401 dtc 1.5
402     #+complex-float
403     (progn
404     (defun make-complex-single-float (x y)
405     (declare (type single-float x y))
406 dtc 1.6 (truly-the (complex single-float) (complex x y)))
407 dtc 1.5
408     (defun make-complex-double-float (x y)
409     (declare (type double-float x y))
410 dtc 1.6 (truly-the (complex double-float) (complex x y)))
411 dtc 1.5
412     (defun complex-single-float-real (x)
413     (declare (type (complex single-float) x))
414     (the single-float (complex-single-float-real x)))
415    
416     (defun complex-double-float-real (x)
417     (declare (type (complex double-float) x))
418     (the double-float (complex-double-float-real x)))
419    
420     (defun complex-single-float-imag (x)
421     (declare (type (complex single-float) x))
422     (the single-float (complex-single-float-imag x)))
423    
424     (defun complex-double-float-imag (x)
425     (declare (type (complex double-float) x))
426     (the double-float (complex-double-float-imag x)))
427     ) ; complex-float

  ViewVC Help
Powered by ViewVC 1.1.5