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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.76 - (hide annotations)
Fri Jun 30 18:41:22 2006 UTC (7 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2007-09, snapshot-2007-08, snapshot-2007-05, snapshot-2006-11, snapshot-2006-10, snapshot-2006-12, snapshot-2007-01, snapshot-2007-02, release-19d, snapshot-2007-03, snapshot-2007-04, snapshot-2007-07, snapshot-2007-06, release-19d-base, release-19d-pre2, release-19d-pre1, snapshot-2007-10, snapshot-2006-07, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19d-branch
Changes since 1.75: +4 -1 lines
This large checkin merges the double-double float support to HEAD.
The merge is from the tag "double-double-irrat-end".  The
double-double branch is now obsolete.

The code should build without double-double support (tested on sparc)
as well as build with double-double support (tested also on sparc).
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.76 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.76 2006/06/30 18:41:22 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 toy 1.71 (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
404 wlott 1.29 ;; This is necessary because some of the initial top level forms might
405 cwang 1.74 ;; have changed the compilation policy in strange ways.
406 wlott 1.29 (print-and-call c::proclaim-init)
407 ram 1.34
408     (print-and-call kernel::class-finalize)
409 ram 1.1
410 wlott 1.10 (%primitive print "Done initializing.")
411    
412 wlott 1.35 #-gengc (setf *already-maybe-gcing* nil)
413     #+gengc (setf *gc-verbose* t)
414 ram 1.1 (terpri)
415     (princ "CMU Common Lisp kernel core image ")
416     (princ (lisp-implementation-version))
417     (princ ".")
418     (terpri)
419     (princ "[You are in the LISP package.]")
420     (terpri)
421 ram 1.48 (let ((wot
422     (catch '%end-of-the-world
423     (loop
424     (%top-level)
425     (write-line "You're certainly a clever child.")))))
426     (unix:unix-exit wot)))
427 wlott 1.36
428     #+gengc
429 wlott 1.42 (defun do-load-time-value-fixup (object offset index)
430 wlott 1.36 (declare (type index offset))
431     (macrolet ((lose (msg)
432     `(progn
433     (%primitive print ,msg)
434     (%halt))))
435 wlott 1.42 (let ((value (svref *load-time-values* index)))
436     (typecase object
437     (list
438     (case offset
439     (0 (setf (car object) value))
440     (1 (setf (cdr object) value))
441     (t (lose "Bogus offset in cons cell."))))
442     (instance
443     (setf (%instance-ref object (- offset vm:instance-slots-offset))
444     value))
445     (code-component
446     (setf (code-header-ref object offset) value))
447     (simple-vector
448     (setf (svref object (- offset vm:vector-data-offset)) value))
449     (t
450     (lose "Unknown kind of object for load-time-value fixup."))))))
451 ram 1.1
452    
453     ;;;; Initialization functions:
454    
455 ram 1.49 ;;; Print seems to not like x86 NPX denormal floats like
456     ;;; least-negative-single-float, so the :underflow exceptions
457     ;;; is disabled by default. Joe User can explicitly enable them
458     ;;; if desired.
459    
460 ram 1.1 (defun reinit ()
461     (without-interrupts
462 wlott 1.33 (without-gcing
463     (os-init)
464     (stream-reinit)
465     (kernel::signal-init)
466     (gc-init)
467 pw 1.56 (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
468 wlott 1.33 (set-floating-point-modes :traps
469 toy 1.71 '(:overflow :invalid :divide-by-zero))
470 dtc 1.58 ;; Clear pseudo atomic in case this core wasn't compiled with support.
471 cwang 1.75 #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
472 ram 1.1
473    
474     ;;;; Miscellaneous external functions:
475    
476 pw 1.64 (defvar *cleanup-functions* nil
477     "Functions to be invoked during cleanup at Lisp exit.")
478    
479 ram 1.1 ;;; Quit gets us out, one way or another.
480    
481     (defun quit (&optional recklessly-p)
482     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
483     non-Nil."
484     (if recklessly-p
485 wlott 1.28 (unix:unix-exit 0)
486 pw 1.64 (progn
487     (mapc (lambda (fn) (ignore-errors (funcall fn))) *cleanup-functions*)
488     (throw '%end-of-the-world 0))))
489 ram 1.1
490    
491 dtc 1.54 #-mp ; Multi-processing version defined in multi-proc.lisp.
492 ram 1.1 (defun sleep (n)
493     "This function causes execution to be suspended for N seconds. N may
494     be any non-negative, non-complex number."
495 wlott 1.13 (when (or (not (realp n))
496     (minusp n))
497 toy 1.66 (error 'simple-type-error
498     :format-control
499     "Invalid argument to SLEEP: ~S.~%~
500 wlott 1.13 Must be a non-negative, non-complex number."
501 toy 1.66 :format-arguments (list n)
502     :datum n
503     :expected-type '(real 0)))
504 wlott 1.13 (multiple-value-bind (sec usec)
505 pw 1.57 (if (integerp n)
506     (values n 0)
507 pw 1.64 (multiple-value-bind (sec frac) (truncate n)
508     (values sec (truncate frac 1e-6))))
509 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
510 ram 1.1 nil)
511    
512 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
513    
514 gerd 1.68 #+stack-checking
515     (alien:def-alien-routine "os_guard_control_stack" c-call:void
516     (zone c-call:int)
517     (guardp c-call:int))
518    
519 wlott 1.25
520 wlott 1.30 (defconstant bytes-per-scrub-unit 2048)
521 wlott 1.25
522 dtc 1.58 ;;; Scrub-control-stack.
523     ;;;
524 cwang 1.74 #-(or x86 amd64)
525 toy 1.69 (defun %scrub-control-stack ()
526 wlott 1.25 "Zero the unused portion of the control stack so that old objects are not
527     kept alive because of uninitialized stack variables."
528     (declare (optimize (speed 3) (safety 0))
529     (values (unsigned-byte 20)))
530     (labels
531     ((scrub (ptr offset count)
532     (declare (type system-area-pointer ptr)
533     (type (unsigned-byte 16) offset)
534     (type (unsigned-byte 20) count)
535     (values (unsigned-byte 20)))
536 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
537     (look (sap+ ptr bytes-per-scrub-unit) 0 count))
538 wlott 1.25 (t
539     (setf (sap-ref-32 ptr offset) 0)
540 wlott 1.30 (scrub ptr (+ offset vm:word-bytes) count))))
541 wlott 1.25 (look (ptr offset count)
542     (declare (type system-area-pointer ptr)
543     (type (unsigned-byte 16) offset)
544     (type (unsigned-byte 20) count)
545     (values (unsigned-byte 20)))
546 wlott 1.30 (cond ((= offset bytes-per-scrub-unit)
547 wlott 1.25 count)
548     ((zerop (sap-ref-32 ptr offset))
549 wlott 1.30 (look ptr (+ offset vm:word-bytes) count))
550 wlott 1.25 (t
551 wlott 1.30 (scrub ptr offset (+ count vm:word-bytes))))))
552 wlott 1.25 (let* ((csp (sap-int (c::control-stack-pointer-sap)))
553 wlott 1.30 (initial-offset (logand csp (1- bytes-per-scrub-unit))))
554 wlott 1.25 (declare (type (unsigned-byte 32) csp))
555     (scrub (int-sap (- csp initial-offset))
556 wlott 1.30 (* (floor initial-offset vm:word-bytes) vm:word-bytes)
557 wlott 1.25 0))))
558 dtc 1.59
559     ;;; Scrub-control-stack.
560     ;;;
561 cwang 1.74 ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
562 dtc 1.59 ;;; demand stacks the stack must be decreased as it is scrubbed.
563     ;;;
564 ram 1.49 (defun scrub-control-stack ()
565     "Zero the unused portion of the control stack so that old objects are not
566     kept alive because of uninitialized stack variables."
567 gerd 1.68 ;;
568     ;; The guard zone of the control stack is used by Lisp sometimes,
569     ;; so I think it should be zero'd out, too.
570     #+stack-checking (os-guard-control-stack 0 0)
571     (%scrub-control-stack)
572     #+stack-checking (os-guard-control-stack 0 1))
573    
574 cwang 1.74 #+(or x86 amd64)
575 gerd 1.68 (defun %scrub-control-stack ()
576     (%scrub-control-stack))
577 wlott 1.25
578    
579 ram 1.1 ;;;; TOP-LEVEL loop.
580    
581     (defvar / nil
582     "Holds a list of all the values returned by the most recent top-level EVAL.")
583     (defvar // nil "Gets the previous value of / when a new value is computed.")
584     (defvar /// nil "Gets the previous value of // when a new value is computed.")
585     (defvar * nil "Holds the value of the most recent top-level EVAL.")
586     (defvar ** nil "Gets the previous value of * when a new value is computed.")
587     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
588     (defvar + nil "Holds the value of the most recent top-level READ.")
589     (defvar ++ nil "Gets the previous value of + when a new value is read.")
590     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
591     (defvar - nil "Holds the form curently being evaluated.")
592 ram 1.3 (defvar *prompt* "* "
593     "The top-level prompt string. This also may be a function of no arguments
594     that returns a simple-string.")
595 ram 1.1 (defvar *in-top-level-catcher* nil
596     "True if we are within the Top-Level-Catcher. This is used by interrupt
597     handlers to see whether it is o.k. to throw.")
598    
599 ram 1.3 (defun interactive-eval (form)
600     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
601     +, ///, //, /, and -."
602 toy 1.70 (when (and (fboundp 'commandp) (funcall 'commandp form))
603     (return-from interactive-eval (funcall 'invoke-command-interactive form)))
604 ram 1.21 (setf - form)
605 toy 1.70 (let ((results (multiple-value-list (eval form))))
606 dtc 1.60 (finish-standard-output-streams)
607 ram 1.3 (setf /// //
608     // /
609     / results
610     *** **
611     ** *
612     * (car results)))
613 ram 1.21 (setf +++ ++
614     ++ +
615     + -)
616 ram 1.3 (unless (boundp '*)
617     ;; The bogon returned an unbound marker.
618     (setf * nil)
619     (cerror "Go on with * set to NIL."
620     "EVAL returned an unbound marker."))
621     (values-list /))
622 ram 1.21
623 ram 1.3
624     (defconstant eofs-before-quit 10)
625    
626 toy 1.73 (defparameter *reserved-heap-pages* 256
627     "How many pages to reserve from the total heap space so we can handle
628     heap overflow.")
629    
630     #+heap-overflow-check
631     (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
632    
633 ram 1.1 (defun %top-level ()
634     "Top-level READ-EVAL-PRINT loop. Do not call this."
635 ram 1.3 (let ((* nil) (** nil) (*** nil)
636 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
637 ram 1.3 (/// nil) (// nil) (/ nil)
638     (magic-eof-cookie (cons :eof nil))
639     (number-of-eofs 0))
640 ram 1.1 (loop
641 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
642     (catch 'top-level-catcher
643 wlott 1.28 (unix:unix-sigsetmask 0)
644 wlott 1.25 (let ((*in-top-level-catcher* t))
645     (loop
646     (scrub-control-stack)
647     (fresh-line)
648 toy 1.73 ;; Reset reserved pages in the heap
649     #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
650 wlott 1.25 (princ (if (functionp *prompt*)
651     (funcall *prompt*)
652     *prompt*))
653     (force-output)
654     (let ((form (read *standard-input* nil magic-eof-cookie)))
655     (cond ((not (eq form magic-eof-cookie))
656     (let ((results
657     (multiple-value-list (interactive-eval form))))
658     (dolist (result results)
659     (fresh-line)
660     (prin1 result)))
661     (setf number-of-eofs 0))
662     ((eql (incf number-of-eofs) 1)
663 phg 1.47 (if *batch-mode*
664 ram 1.48 (quit)
665 phg 1.47 (let ((stream (make-synonym-stream '*terminal-io*)))
666     (setf *standard-input* stream)
667     (setf *standard-output* stream)
668     (format t "~&Received EOF on *standard-input*, ~
669     switching to *terminal-io*.~%"))))
670 wlott 1.25 ((> number-of-eofs eofs-before-quit)
671     (format t "~&Received more than ~D EOFs; Aborting.~%"
672     eofs-before-quit)
673     (quit))
674     (t
675     (format t "~&Received EOF.~%")))))))))))
676 ram 1.1
677 ram 1.3
678 ram 1.1 ;;; %Halt -- Interface
679     ;;;
680     ;;; A convenient way to get into the assembly level debugger.
681     ;;;
682     (defun %halt ()
683     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5