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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5