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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.68 - (hide annotations)
Sun Mar 23 21:23:42 2003 UTC (11 years, 1 month ago) by gerd
Branch: MAIN
CVS Tags: remove_negative_zero_not_zero
Changes since 1.67: +16 -2 lines
	Optional control stack checking.  This is controlled by the
	feature :stack-checking because it's not implemented for other
	systems/architectures yet.  It is currently known to work on
	FreeBSD 4.8-RC/x86 and Debian 2.2.20/x86.

	* bootfiles/18e/boot3.lisp: New boot file, well, only a
	description of the boot procedure since no boot file is needed.

	* lisp/x86-validate.h (SIGNAL_STACK_START, SIGNAL_STACK_SIZE)
	[__FreeBSD__, __linux__]: New defines.
	(CONTROL_STACK_SIZE) {__FreeBSD__, __linux__]:
	Adjust for signal stack.

	* lisp/validate.c (validate) [RED_ZONE_HIT]: Call
	os_guard_control_stack.  Some cleanup.

	* lisp/os.h (BOTH_ZONES, YELLOW_ZONE, RED_ZONE): New enums.
	Add function prototypes.

	* lisp/interrupt.c (interrupt_install_low_level_handler)
	[RED_ZONE_HIT]: Deliver protection violations on a dedicated
	signal stack.

	* lisp/os-common.c (os_stack_grows_down_1, os_stack_grows_down):
	New functions.
	(guard_zones, control_stack_zone, os_guard_control_stack)
	(os_control_stack_overflow) [RED_ZONE_HIT]: New functions.
	(os_control_stack_overflow) [!RED_ZONE_HIT]: Dummy function.

	* lisp/Linux-os.c (sigsegv_handler) [RED_ZONE_HIT]: Handle control
	stack overflows.

	* lisp/FreeBSD-os.c: General cleansing.
	(sigbus_handler) [RED_ZONE_HIT]: Handle control stack overflows.

	* lisp/FreeBSD-os.h (PROTECTION_VIOLATION_SIGNAL): New define.

	* lisp/Linux-os.h (PROTECTION_VIOLATION_SIGNAL): New define.

	* compiler/x86/system.lisp (lisp::%scrub-control-stack): Change
	defknown from sys:scrub-control-stack.
	(%scrub-control-stack): Rename VOP.

	* code/lispinit.lisp (os-guard-control-stack) [#+stack-checking]:
	Define alien os_guard_control_stack.
	(%scrub-control-stack) [#+x86]: New function.
	(scrub-control-stack) [#+x86]: Call %scrub-control-stack,
	call os-guard-control-stack if #+stack-checking.

	* code/interr.lisp (yellow-zone-hit,
	red-zone-hit) [#+stack-checking]: New functions.

	* code/error.lisp (stack-overflow) [#+stack-checking]: New
	condition.

	* compiler/generic/new-genesis.lisp (finish-symbols)
	[#+stack-checking]: Add symbols for control stack checking.

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

  ViewVC Help
Powered by ViewVC 1.1.5