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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78.4.2 - (hide annotations)
Mon May 19 16:55:15 2008 UTC (5 years, 11 months ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-sync-2008-12, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-sync-label-2009-03-16, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-sync-2008-11, unicode-utf16-string-support
Branch point for: unicode-utf16-extfmt-branch
Changes since 1.78.4.1: +2 -2 lines
Remove debugging stuff.

code/c-call.lisp:
o Remove debugging print
o Don't need make-array-unsigned-byte-8.  It was never really needed.
o Update deport-gen not to use make-array-unsigned-byte-8.
o Remove %primitive prints.

code/filesys.lisp:
o Remove %primitive prints.

code/lispinit.lisp:
o Remove %primitive prints.

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

  ViewVC Help
Powered by ViewVC 1.1.5