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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (hide annotations)
Fri Oct 24 02:56:59 2003 UTC (10 years, 5 months ago) by toy
Branch: MAIN
CVS Tags: snapshot-2004-05, mod-arith-base, amd64-merge-start, snapshot-2003-11, release-19a-base, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, snapshot-2004-04
Branch point for: mod-arith-branch, release-19a-branch
Changes since 1.72: +13 -1 lines
Add support for catching heap overflows, similar to the control stack
overflow checking.  Enable with :heap-overflow-check.  We reserve some
number of pages on the heap.  When the heap reaches the reserved
pages, an overflow warning is signalled.  The reserved pages are set
0.  This allows some additional allocation to happen during debugging,
if necessary.  If another overflow happens, we throw to top-level.

Sparc only right now.

	* lisp/sparc-assem.S (_do_dynamic_space_overflow_error): New
	function to handle a heap overflow error.
	(_do_dynamic_space_overflow_warning): New function to handle heap
	overflow warning.

	* lisp/sparc-arch.c (sigill_handler): Handle the two new traps
	caused by heap overflows.

	* lisp/interrupt.c (interrupt_handle_space_overflow): New function
	to handle interrupt caused by heap space overflows.

	* lisp/gencgc.c (handle_heap_overflow): New function to handle
	heap overflows.
	(gc_alloc_new_region): Use handle_heap_overflow.
	(gc_alloc_large): Use handle_heap_overflow

	* compiler/sparc/parms.lisp (static-symbols): Add new static
	symbols for heap overflow checking:
	dynamic-space-overflow-error-hit and
	dynamic-space-overflow-warning-hit.

	* compiler/generic/new-genesis.lisp (finish-symbols): Initialize
	the new dynamic-space-overflow-error-hit and
	dynamic-space-overflow-warning-hit static symbols.

	* code/lispinit.lisp (:heap-overflow-check): Add
	heap-overflow-check to *runtime-features*, if necessary.
	("reserved_heap_pages"): Access to alien variable for heap
	overflow.
	(*reserved-heap-pages*): Default number of heap pages to reserve
	for heap overflow.
	(%top-level): Set reserved-heap-pages to the default.

	* code/interr.lisp (dynamic-space-overflow-warning-hit): Add
	function to handle heap overflow warnings.
	(dynamic-space-overflow-error-hit): Add function to handle heap
	overflow error.

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

  ViewVC Help
Powered by ViewVC 1.1.5