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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5