/[cmucl]/src/code/lispinit.lisp
ViewVC logotype

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.77 - (hide annotations)
Thu Oct 4 19:58:19 2007 UTC (6 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-11
Changes since 1.76: +3 -2 lines
The floating point precision was always getting reset to :53-bit, even
if the user set a different value.  Fix this so the correct precision
is restored.

compiler/x86/parms.lisp:
o Add new static-symbol *FPU-PRECISION* to hold the precision bits
  that are given in (setf floating-point-modes).

compiler/x86/float.lisp:
o Whenever (setf floating-point-modes) is called, save the precision
  bits to *FPU-PRECISION* so that get restored correctly in
  DEALLOC-NUMBER-STACK-SPACE.

compiler/x86/c-call.lisp:
o Update DEALLOC-NUMBER-STACK-SPACE VOP so that when float-accuracy
  policy says so, we restore the precision from *fpu-precision*,
  instead of always making it :53-bit.

code/lispinit.lisp:
o Initialize the default precision to :53-bit on startup.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.20 ;;; 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     ;;;
7     (ext:file-comment
8 rtoy 1.77 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.77 2007/10/04 19:58:19 rtoy Exp $")
9 ram 1.20 ;;;
10 ram 1.1 ;;; **********************************************************************
11 wlott 1.10 ;;;
12 wlott 1.14 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
13     ;;; that we don't have any better place for.
14     ;;;
15 ram 1.1 ;;; Written by Skef Wholey and Rob MacLachlan.
16     ;;;
17 wlott 1.36 (in-package :lisp)
18 ram 1.1
19     (export '(most-positive-fixnum most-negative-fixnum sleep
20 wlott 1.33 ++ +++ ** *** // ///))
21 ram 1.1
22 toy 1.72 (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
23     "Holds a list of symbols that describe features provided by the
24     implementation.")
25    
26    
27 wlott 1.36 (in-package :system)
28 toy 1.72 (export '(compiler-version scrub-control-stack *runtime-features*))
29    
30     (defvar *runtime-features* nil
31     "Features affecting the runtime")
32 ram 1.1
33 wlott 1.36 (in-package :extensions)
34 wlott 1.33 (export '(quit *prompt*))
35 ram 1.1
36 wlott 1.36 (in-package :lisp)
37 toy 1.72
38     #+stack-checking
39     (sys:register-lisp-runtime-feature :stack-checking)
40 ram 1.1
41 toy 1.73 #+heap-overflow-check
42     (sys:register-lisp-runtime-feature :heap-overflow-check)
43    
44 rtoy 1.76 #+double-double
45     (sys:register-lisp-feature :double-double)
46    
47 ram 1.1 ;;; Make the error system enable interrupts.
48    
49 wlott 1.10 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
50 ram 1.1 "The fixnum closest in value to positive infinity.")
51    
52 wlott 1.10 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
53 ram 1.1 "The fixnum closest in value to negative infinity.")
54    
55    
56     ;;; Random information:
57    
58 wlott 1.10 (defvar *lisp-implementation-version* "4.0(?)")
59 ram 1.1
60    
61 ram 1.5 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
62 wlott 1.35 (declaim
63     #-gengc
64     (special *gc-inhibit* *already-maybe-gcing*
65     *need-to-collect-garbage* *gc-verbose*
66     *before-gc-hooks* *after-gc-hooks*
67 dtc 1.52 #+x86 *pseudo-atomic-atomic*
68     #+x86 *pseudo-atomic-interrupted*
69 wlott 1.35 unix::*interrupts-enabled*
70     unix::*interrupt-pending*
71     *type-system-initialized*)
72     #+gengc
73     (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
74     *type-system-initialized*))
75 ram 1.1
76    
77 wlott 1.10 ;;;; Random magic specials.
78 ram 1.1
79    
80 wlott 1.10 ;;; These are filled in by Genesis.
81 ram 1.1
82 wlott 1.35 #-gengc
83     (progn
84    
85 wlott 1.10 (defvar *current-catch-block*)
86 dtc 1.50 (defvar *current-unwind-protect-block*)
87 wlott 1.10 (defvar *free-interrupt-context-index*)
88 ram 1.1
89 wlott 1.35 ); #-gengc progn
90 ram 1.1
91 wlott 1.10
92 ram 1.39 ;;;; Random stuff that needs to be in the cold load which would otherwise be
93     ;;;; byte-compiled.
94     ;;;;
95     (defvar hi::*in-the-editor* nil)
96    
97     ;;;; Called by defmacro expanders...
98    
99     ;;; VERIFY-KEYWORDS -- internal
100     ;;;
101     ;;; Determine if key-list is a valid list of keyword/value pairs. Do not
102     ;;; signal the error directly, 'cause we don't know how it should be signaled.
103     ;;;
104 pw 1.63
105 ram 1.39 (defun verify-keywords (key-list valid-keys allow-other-keys)
106     (do ((already-processed nil)
107     (unknown-keyword nil)
108     (remaining key-list (cddr remaining)))
109     ((null remaining)
110     (if (and unknown-keyword
111     (not allow-other-keys)
112     (not (lookup-keyword :allow-other-keys key-list)))
113     (values :unknown-keyword (list unknown-keyword valid-keys))
114     (values nil nil)))
115     (cond ((not (and (consp remaining) (listp (cdr remaining))))
116     (return (values :dotted-list key-list)))
117     ((null (cdr remaining))
118     (return (values :odd-length key-list)))
119 pw 1.63 #+nil ;; Not ANSI compliant to disallow duplicate keywords.
120 ram 1.39 ((member (car remaining) already-processed)
121     (return (values :duplicate (car remaining))))
122     ((or (eq (car remaining) :allow-other-keys)
123     (member (car remaining) valid-keys))
124     (push (car remaining) already-processed))
125     (t
126     (setf unknown-keyword (car remaining))))))
127    
128     (defun lookup-keyword (keyword key-list)
129     (do ((remaining key-list (cddr remaining)))
130     ((endp remaining))
131     (when (eq keyword (car remaining))
132     (return (cadr remaining)))))
133     ;;;
134     (defun keyword-supplied-p (keyword key-list)
135     (do ((remaining key-list (cddr remaining)))
136     ((endp remaining))
137     (when (eq keyword (car remaining))
138     (return t))))
139    
140 ram 1.40 (in-package "CONDITIONS")
141 ram 1.39
142     (defvar *break-on-signals* nil
143     "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
144     enter the debugger prior to signalling that condition.")
145    
146     (defun signal (datum &rest arguments)
147     "Invokes the signal facility on a condition formed from datum and arguments.
148     If the condition is not handled, nil is returned. If
149     (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
150     any signalling is done."
151     (let ((condition (coerce-to-condition datum arguments
152     'simple-condition 'signal))
153     (*handler-clusters* *handler-clusters*))
154 ram 1.45 (let ((obos *break-on-signals*)
155     (*break-on-signals* nil))
156     (when (typep condition obos)
157 ram 1.39 (break "~A~%Break entered because of *break-on-signals* (now NIL.)"
158     condition)))
159     (loop
160     (unless *handler-clusters* (return))
161     (let ((cluster (pop *handler-clusters*)))
162     (dolist (handler cluster)
163     (when (typep condition (car handler))
164     (funcall (cdr handler) condition)))))
165     nil))
166    
167     ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
168     ;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
169     ;;; argument that's directly usable by all the other routines.
170     ;;;
171     (defun coerce-to-condition (datum arguments default-type function-name)
172     (cond ((typep datum 'condition)
173     (if arguments
174     (cerror "Ignore the additional arguments."
175     'simple-type-error
176     :datum arguments
177     :expected-type 'null
178     :format-control "You may not supply additional arguments ~
179     when giving ~S to ~S."
180     :format-arguments (list datum function-name)))
181     datum)
182     ((symbolp datum) ;Roughly, (subtypep datum 'condition).
183     (apply #'make-condition datum arguments))
184     ((or (stringp datum) (functionp datum))
185     (make-condition default-type
186     :format-control datum
187     :format-arguments arguments))
188     (t
189     (error 'simple-type-error
190     :datum datum
191     :expected-type '(or symbol string)
192     :format-control "Bad argument to ~S: ~S"
193     :format-arguments (list function-name datum)))))
194    
195     (defun error (datum &rest arguments)
196     "Invokes the signal facility on a condition formed from datum and arguments.
197     If the condition is not handled, the debugger is invoked."
198     (kernel:infinite-error-protect
199     (let ((condition (coerce-to-condition datum arguments
200     'simple-error 'error))
201     (debug:*stack-top-hint* debug:*stack-top-hint*))
202 ram 1.43 (unless (and (condition-function-name condition) debug:*stack-top-hint*)
203 ram 1.39 (multiple-value-bind
204     (name frame)
205     (kernel:find-caller-name)
206 ram 1.43 (unless (condition-function-name condition)
207     (setf (condition-function-name condition) name))
208 ram 1.39 (unless debug:*stack-top-hint*
209     (setf debug:*stack-top-hint* frame))))
210     (let ((debug:*stack-top-hint* nil))
211     (signal condition))
212     (invoke-debugger condition))))
213    
214     ;;; CERROR must take care to not use arguments when datum is already a
215     ;;; condition object.
216     ;;;
217     (defun cerror (continue-string datum &rest arguments)
218     (kernel:infinite-error-protect
219     (with-simple-restart
220     (continue "~A" (apply #'format nil continue-string arguments))
221     (let ((condition (if (typep datum 'condition)
222     datum
223     (coerce-to-condition datum arguments
224     'simple-error 'error)))
225     (debug:*stack-top-hint* debug:*stack-top-hint*))
226 ram 1.43 (unless (and (condition-function-name condition)
227     debug:*stack-top-hint*)
228 ram 1.39 (multiple-value-bind
229     (name frame)
230     (kernel:find-caller-name)
231 ram 1.43 (unless (condition-function-name condition)
232     (setf (condition-function-name condition) name))
233 ram 1.39 (unless debug:*stack-top-hint*
234     (setf debug:*stack-top-hint* frame))))
235     (with-condition-restarts condition (list (find-restart 'continue))
236     (let ((debug:*stack-top-hint* nil))
237     (signal condition))
238     (invoke-debugger condition)))))
239     nil)
240    
241     (defun break (&optional (datum "Break") &rest arguments)
242     "Prints a message and invokes the debugger without allowing any possibility
243     of condition handling occurring."
244     (kernel:infinite-error-protect
245     (with-simple-restart (continue "Return from BREAK.")
246     (let ((debug:*stack-top-hint*
247     (or debug:*stack-top-hint*
248     (nth-value 1 (kernel:find-caller-name)))))
249     (invoke-debugger
250     (coerce-to-condition datum arguments 'simple-condition 'break)))))
251     nil)
252    
253     (defun warn (datum &rest arguments)
254     "Warns about a situation by signalling a condition formed by datum and
255     arguments. While the condition is being signaled, a muffle-warning restart
256     exists that causes WARN to immediately return nil."
257     (kernel:infinite-error-protect
258     (let ((condition (coerce-to-condition datum arguments
259     'simple-warning 'warn)))
260     (check-type condition warning "a warning condition")
261     (restart-case (signal condition)
262     (muffle-warning ()
263     :report "Skip warning."
264     (return-from warn nil)))
265     (format *error-output* "~&~@<Warning: ~3i~:_~A~:>~%" condition)))
266     nil)
267 pmai 1.67
268     ;;; Utility functions
269    
270     (defun simple-program-error (datum &rest arguments)
271     "Invokes the signal facility on a condition formed from datum and arguments.
272     If the condition is not handled, the debugger is invoked. This function
273     is just like error, except that the condition type defaults to the type
274     simple-program-error, instead of program-error."
275     (kernel:infinite-error-protect
276     (let ((condition (coerce-to-condition datum arguments
277     'simple-program-error
278     'simple-program-error))
279     (debug:*stack-top-hint* debug:*stack-top-hint*))
280     (unless (and (condition-function-name condition) debug:*stack-top-hint*)
281     (multiple-value-bind
282     (name frame)
283     (kernel:find-caller-name)
284     (unless (condition-function-name condition)
285     (setf (condition-function-name condition) name))
286     (unless debug:*stack-top-hint*
287     (setf debug:*stack-top-hint* frame))))
288     (let ((debug:*stack-top-hint* nil))
289     (signal condition))
290     (invoke-debugger condition))))
291 ram 1.39
292     (in-package "LISP")
293    
294    
295 ram 1.1 ;;; %Initial-Function is called when a cold system starts up. First we zoom
296     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
297     ;;; at "load time." Then we initialize the various subsystems and call the
298     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
299     ;;; someone (most likely the Quit function) throws to the tag
300     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
301     ;;; in Unwind-Protects will get executed.
302    
303 pw 1.62 (declaim (special *lisp-initialization-functions*
304     *load-time-values*))
305 ram 1.1
306     (eval-when (compile)
307     (defmacro print-and-call (name)
308     `(progn
309 wlott 1.10 (%primitive print ,(symbol-name name))
310 ram 1.1 (,name))))
311 ram 1.49 #+nil
312     (defun hexstr(thing)
313     (let ((addr (kernel:get-lisp-obj-address thing))
314     (str (make-string 10)))
315     (setf (char str 0) #\0
316     (char str 1) #\x)
317     (dotimes (i 8)
318     (let* ((nib (ldb (byte 4 0) addr))
319     (chr (char "0123456789abcdef" nib)))
320     (declare (type (unsigned-byte 4) nib)
321     (base-char chr))
322     (setf (char str (- 9 i)) chr
323     addr (ash addr -4))))
324     str))
325 ram 1.1
326     (defun %initial-function ()
327     "Gives the world a shove and hopes it spins."
328 wlott 1.36 (%primitive print "In initial-function, and running.")
329 wlott 1.35 #-gengc (setf *already-maybe-gcing* t)
330     #-gengc (setf *gc-inhibit* t)
331     #-gengc (setf *need-to-collect-garbage* nil)
332     (setf *gc-verbose* #-gengc t #+gengc nil)
333 wlott 1.12 (setf *before-gc-hooks* nil)
334     (setf *after-gc-hooks* nil)
335 wlott 1.35 #-gengc (setf unix::*interrupts-enabled* t)
336     #-gengc (setf unix::*interrupt-pending* nil)
337 ram 1.34 (setf *type-system-initialized* nil)
338 ram 1.41 (setf *break-on-signals* nil)
339 wlott 1.44 #+gengc (setf conditions::*handler-clusters* nil)
340 ram 1.1
341     ;; Many top-level forms call INFO, (SETF INFO).
342     (print-and-call c::globaldb-init)
343    
344 wlott 1.32 ;; Set up the fdefn database.
345     (print-and-call fdefn-init)
346    
347     ;; Some of the random top-level forms call Make-Array, which calls Subtypep
348 ram 1.34 (print-and-call typedef-init)
349     (print-and-call class-init)
350 wlott 1.10 (print-and-call type-init)
351 ram 1.1
352 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
353     (%primitive print "Calling top-level forms.")
354 ram 1.49 (dolist (fun funs) #+nil (%primitive print (hexstr fun))
355 wlott 1.26 (typecase fun
356     (function
357     (funcall fun))
358     (cons
359     (case (car fun)
360     (:load-time-value
361     (setf (svref *load-time-values* (third fun))
362     (funcall (second fun))))
363     (:load-time-value-fixup
364 wlott 1.36 #-gengc
365 cwang 1.74 (setf (#+amd64 sap-ref-64
366     #-amd64 sap-ref-32 (second fun) 0)
367 wlott 1.26 (get-lisp-obj-address
368 wlott 1.36 (svref *load-time-values* (third fun))))
369     #+gengc
370     (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
371 cwang 1.74 #+(and (or x86 amd64) gencgc)
372 dtc 1.55 (:load-time-code-fixup
373     (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
374     (fifth fun)))
375 wlott 1.26 (t
376     (%primitive print
377     "Bogus fixup in *lisp-initialization-functions*")
378     (%halt))))
379     (t
380     (%primitive print
381     "Bogus function in *lisp-initialization-functions*")
382     (%halt)))))
383 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
384 wlott 1.26 (makunbound '*load-time-values*)
385 ram 1.1
386 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
387     ;; deftypes are.
388 ram 1.34 (setf *type-system-initialized* t)
389 wlott 1.10
390 ram 1.1 (print-and-call os-init)
391     (print-and-call filesys-init)
392    
393     (print-and-call reader-init)
394 ram 1.38 ;; Note: sharpm and backq not yet loaded, so this is not the final RT.
395 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
396 ram 1.1
397     (print-and-call stream-init)
398 wlott 1.10 (print-and-call loader-init)
399 ram 1.1 (print-and-call package-init)
400 wlott 1.16 (print-and-call kernel::signal-init)
401 pw 1.56 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
402 ram 1.49
403 rtoy 1.77 (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero)
404     #+x86 :precision-control #+x86 :53-bit)
405 wlott 1.29 ;; This is necessary because some of the initial top level forms might
406 cwang 1.74 ;; have changed the compilation policy in strange ways.
407 wlott 1.29 (print-and-call c::proclaim-init)
408 ram 1.34
409     (print-and-call kernel::class-finalize)
410 ram 1.1
411 wlott 1.10 (%primitive print "Done initializing.")
412    
413 wlott 1.35 #-gengc (setf *already-maybe-gcing* nil)
414     #+gengc (setf *gc-verbose* t)
415 ram 1.1 (terpri)
416     (princ "CMU Common Lisp kernel core image ")
417     (princ (lisp-implementation-version))
418     (princ ".")
419     (terpri)
420     (princ "[You are in the LISP package.]")
421     (terpri)
422 ram 1.48 (let ((wot
423     (catch '%end-of-the-world
424     (loop
425     (%top-level)
426     (write-line "You're certainly a clever child.")))))
427     (unix:unix-exit wot)))
428 wlott 1.36
429     #+gengc
430 wlott 1.42 (defun do-load-time-value-fixup (object offset index)
431 wlott 1.36 (declare (type index offset))
432     (macrolet ((lose (msg)
433     `(progn
434     (%primitive print ,msg)
435     (%halt))))
436 wlott 1.42 (let ((value (svref *load-time-values* index)))
437     (typecase object
438     (list
439     (case offset
440     (0 (setf (car object) value))
441     (1 (setf (cdr object) value))
442     (t (lose "Bogus offset in cons cell."))))
443     (instance
444     (setf (%instance-ref object (- offset vm:instance-slots-offset))
445     value))
446     (code-component
447     (setf (code-header-ref object offset) value))
448     (simple-vector
449     (setf (svref object (- offset vm:vector-data-offset)) value))
450     (t
451     (lose "Unknown kind of object for load-time-value fixup."))))))
452 ram 1.1
453    
454     ;;;; Initialization functions:
455    
456 ram 1.49 ;;; Print seems to not like x86 NPX denormal floats like
457     ;;; least-negative-single-float, so the :underflow exceptions
458     ;;; is disabled by default. Joe User can explicitly enable them
459     ;;; if desired.
460    
461 ram 1.1 (defun reinit ()
462     (without-interrupts
463 wlott 1.33 (without-gcing
464     (os-init)
465     (stream-reinit)
466     (kernel::signal-init)
467     (gc-init)
468 pw 1.56 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
469 wlott 1.33 (set-floating-point-modes :traps
470 toy 1.71 '(:overflow :invalid :divide-by-zero))
471 dtc 1.58 ;; Clear pseudo atomic in case this core wasn't compiled with support.
472 cwang 1.75 #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
473 ram 1.1
474    
475     ;;;; Miscellaneous external functions:
476    
477 pw 1.64 (defvar *cleanup-functions* nil
478     "Functions to be invoked during cleanup at Lisp exit.")
479    
480 ram 1.1 ;;; Quit gets us out, one way or another.
481    
482     (defun quit (&optional recklessly-p)
483     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
484     non-Nil."
485     (if recklessly-p
486 wlott 1.28 (unix:unix-exit 0)
487 pw 1.64 (progn
488     (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
489     (throw '%end-of-the-world 0))))
490 ram 1.1
491    
492 dtc 1.54 #-mp ; Multi-processing version defined in multi-proc.lisp.
493 ram 1.1 (defun sleep (n)
494     "This function causes execution to be suspended for N seconds. N may
495     be any non-negative, non-complex number."
496 wlott 1.13 (when (or (not (realp n))
497     (minusp n))
498 toy 1.66 (error 'simple-type-error
499     :format-control
500     "Invalid argument to SLEEP: ~S.~%~
501 wlott 1.13 Must be a non-negative, non-complex number."
502 toy 1.66 :format-arguments (list n)
503     :datum n
504     :expected-type '(real 0)))
505 wlott 1.13 (multiple-value-bind (sec usec)
506 pw 1.57 (if (integerp n)
507     (values n 0)
508 pw 1.64 (multiple-value-bind (sec frac) (truncate n)
509     (values sec (truncate frac 1e-6))))
510 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
511 ram 1.1 nil)
512    
513 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
514    
515 gerd 1.68 #+stack-checking
516     (alien:def-alien-routine "os_guard_control_stack" c-call:void
517     (zone c-call:int)
518     (guardp c-call:int))
519    
520 wlott 1.25
521 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
522 wlott 1.25
523 dtc 1.58 ;;; Scrub-control-stack.
524     ;;;
525 cwang 1.74 #-(or x86 amd64)
526 toy 1.69 (defun %scrub-control-stack ()
527 wlott 1.25 "Zero the unused portion of the control stack so that old objects are not
528     kept alive because of uninitialized stack variables."
529     (declare (optimize (speed 3) (safety 0))
530     (values (unsigned-byte 20)))
531     (labels
532     ((scrub (ptr offset count)
533     (declare (type system-area-pointer ptr)
534     (type (unsigned-byte 16) offset)
535     (type (unsigned-byte 20) count)
536     (values (unsigned-byte 20)))
537 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
538     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
539 wlott 1.25 (t
540     (setf (sap-ref-32 ptr offset) 0)
541 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
542 wlott 1.25 (look (ptr offset count)
543     (declare (type system-area-pointer ptr)
544     (type (unsigned-byte 16) offset)
545     (type (unsigned-byte 20) count)
546     (values (unsigned-byte 20)))
547 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
548 wlott 1.25 count)
549     ((zerop (sap-ref-32 ptr offset))
550 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
551 wlott 1.25 (t
552 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
553 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
554 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
555 wlott 1.25 (declare (type (unsigned-byte 32) csp))
556     (scrub (int-sap (- csp initial-offset))
557 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
558 wlott 1.25 0))))
559 dtc 1.59
560     ;;; Scrub-control-stack.
561     ;;;
562 cwang 1.74 ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
563 dtc 1.59 ;;; demand stacks the stack must be decreased as it is scrubbed.
564     ;;;
565 ram 1.49 (defun scrub-control-stack ()
566     "Zero the unused portion of the control stack so that old objects are not
567     kept alive because of uninitialized stack variables."
568 gerd 1.68 ;;
569     ;; The guard zone of the control stack is used by Lisp sometimes,
570     ;; so I think it should be zero'd out, too.
571     #+stack-checking (os-guard-control-stack 0 0)
572     (%scrub-control-stack)
573     #+stack-checking (os-guard-control-stack 0 1))
574    
575 cwang 1.74 #+(or x86 amd64)
576 gerd 1.68 (defun %scrub-control-stack ()
577     (%scrub-control-stack))
578 wlott 1.25
579    
580 ram 1.1 ;;;; TOP-LEVEL loop.
581    
582     (defvar / nil
583     "Holds a list of all the values returned by the most recent top-level EVAL.")
584     (defvar // nil "Gets the previous value of / when a new value is computed.")
585     (defvar /// nil "Gets the previous value of // when a new value is computed.")
586     (defvar * nil "Holds the value of the most recent top-level EVAL.")
587     (defvar ** nil "Gets the previous value of * when a new value is computed.")
588     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
589     (defvar + nil "Holds the value of the most recent top-level READ.")
590     (defvar ++ nil "Gets the previous value of + when a new value is read.")
591     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
592     (defvar - nil "Holds the form curently being evaluated.")
593 ram 1.3 (defvar *prompt* "* "
594     "The top-level prompt string. This also may be a function of no arguments
595     that returns a simple-string.")
596 ram 1.1 (defvar *in-top-level-catcher* nil
597     "True if we are within the Top-Level-Catcher. This is used by interrupt
598     handlers to see whether it is o.k. to throw.")
599    
600 ram 1.3 (defun interactive-eval (form)
601     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
602     +, ///, //, /, and -."
603 toy 1.70 (when (and (fboundp 'commandp) (funcall 'commandp form))
604     (return-from interactive-eval (funcall 'invoke-command-interactive form)))
605 ram 1.21 (setf - form)
606 toy 1.70 (let ((results (multiple-value-list (eval form))))
607 dtc 1.60 (finish-standard-output-streams)
608 ram 1.3 (setf /// //
609     // /
610     / results
611     *** **
612     ** *
613     * (car results)))
614 ram 1.21 (setf +++ ++
615     ++ +
616     + -)
617 ram 1.3 (unless (boundp '*)
618     ;; The bogon returned an unbound marker.
619     (setf * nil)
620     (cerror "Go on with * set to NIL."
621     "EVAL returned an unbound marker."))
622     (values-list /))
623 ram 1.21
624 ram 1.3
625     (defconstant eofs-before-quit 10)
626    
627 toy 1.73 (defparameter *reserved-heap-pages* 256
628     "How many pages to reserve from the total heap space so we can handle
629     heap overflow.")
630    
631     #+heap-overflow-check
632     (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
633    
634 ram 1.1 (defun %top-level ()
635     "Top-level READ-EVAL-PRINT loop. Do not call this."
636 ram 1.3 (let ((* nil) (** nil) (*** nil)
637 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
638 ram 1.3 (/// nil) (// nil) (/ nil)
639     (magic-eof-cookie (cons :eof nil))
640     (number-of-eofs 0))
641 ram 1.1 (loop
642 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
643     (catch 'top-level-catcher
644 wlott 1.28 (unix:unix-sigsetmask 0)
645 wlott 1.25 (let ((*in-top-level-catcher* t))
646     (loop
647     (scrub-control-stack)
648     (fresh-line)
649 toy 1.73 ;; Reset reserved pages in the heap
650     #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
651 wlott 1.25 (princ (if (functionp *prompt*)
652     (funcall *prompt*)
653     *prompt*))
654     (force-output)
655     (let ((form (read *standard-input* nil magic-eof-cookie)))
656     (cond ((not (eq form magic-eof-cookie))
657     (let ((results
658     (multiple-value-list (interactive-eval form))))
659     (dolist (result results)
660     (fresh-line)
661     (prin1 result)))
662     (setf number-of-eofs 0))
663     ((eql (incf number-of-eofs) 1)
664 phg 1.47 (if *batch-mode*
665 ram 1.48 (quit)
666 phg 1.47 (let ((stream (make-synonym-stream '*terminal-io*)))
667     (setf *standard-input* stream)
668     (setf *standard-output* stream)
669     (format t "~&Received EOF on *standard-input*, ~
670     switching to *terminal-io*.~%"))))
671 wlott 1.25 ((> number-of-eofs eofs-before-quit)
672     (format t "~&Received more than ~D EOFs; Aborting.~%"
673     eofs-before-quit)
674     (quit))
675     (t
676     (format t "~&Received EOF.~%")))))))))))
677 ram 1.1
678 ram 1.3
679 ram 1.1 ;;; %Halt -- Interface
680     ;;;
681     ;;; A convenient way to get into the assembly level debugger.
682     ;;;
683     (defun %halt ()
684     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5