/[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.2.1 - (hide annotations)
Wed Jul 2 01:22:07 2008 UTC (5 years, 9 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
Changes since 1.78.4.2: +5 -3 lines
More external format support from Paul Foley.

To get external format support I think you need to add :extfmts to
*features*.  But you can't bootstrap with that feature yet.

Initial support for pathname translations to so that namestrings can
be converted to an appropriate format before being given to the OS.

Many, many new external formats added.

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

  ViewVC Help
Powered by ViewVC 1.1.5