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

Diff of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.67 by pmai, Fri Aug 23 17:08:52 2002 UTC revision 1.67.4.1 by gerd, Sun Mar 9 13:03:48 2003 UTC
# Line 42  Line 42 
42    
43    
44  ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...  ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
45  (declaim  (declaim (special *gc-inhibit* *already-maybe-gcing*
46    #-gengc                    *need-to-collect-garbage* *gc-verbose*
47    (special *gc-inhibit* *already-maybe-gcing*                    *before-gc-hooks* *after-gc-hooks*
48             *need-to-collect-garbage* *gc-verbose*                    #+x86 *pseudo-atomic-atomic*
49             *before-gc-hooks* *after-gc-hooks*                    #+x86 *pseudo-atomic-interrupted*
50             #+x86 *pseudo-atomic-atomic*                    unix::*interrupts-enabled*
51             #+x86 *pseudo-atomic-interrupted*                    unix::*interrupt-pending*
52             unix::*interrupts-enabled*                    *type-system-initialized*))
            unix::*interrupt-pending*  
            *type-system-initialized*)  
   #+gengc  
   (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*  
            *type-system-initialized*))  
53    
54    
55  ;;;; Random magic specials.  ;;;; Random magic specials.
# Line 62  Line 57 
57    
58  ;;; These are filled in by Genesis.  ;;; These are filled in by Genesis.
59    
 #-gengc  
 (progn  
   
60  (defvar *current-catch-block*)  (defvar *current-catch-block*)
61  (defvar *current-unwind-protect-block*)  (defvar *current-unwind-protect-block*)
62  (defvar *free-interrupt-context-index*)  (defvar *free-interrupt-context-index*)
63    
 ); #-gengc progn  
   
64    
65  ;;;; Random stuff that needs to be in the cold load which would otherwise be  ;;;; Random stuff that needs to be in the cold load which would otherwise be
66  ;;;; byte-compiled.  ;;;; byte-compiled.
# Line 291  Line 281 
281      `(progn      `(progn
282         (%primitive print ,(symbol-name name))         (%primitive print ,(symbol-name name))
283         (,name))))         (,name))))
284    
285  #+nil  #+nil
286  (defun hexstr(thing)  (defun hexstr (thing)
287    (let ((addr (kernel:get-lisp-obj-address thing))    (let ((addr (kernel:get-lisp-obj-address thing))
288          (str (make-string 10)))          (str (make-string 10)))
289      (setf (char str 0) #\0      (setf (char str 0) #\0
# Line 309  Line 300 
300  (defun %initial-function ()  (defun %initial-function ()
301    "Gives the world a shove and hopes it spins."    "Gives the world a shove and hopes it spins."
302    (%primitive print "In initial-function, and running.")    (%primitive print "In initial-function, and running.")
303    #-gengc (setf *already-maybe-gcing* t)    (setf *already-maybe-gcing* t)
304    #-gengc (setf *gc-inhibit* t)    (setf *gc-inhibit* t)
305    #-gengc (setf *need-to-collect-garbage* nil)    (setf *need-to-collect-garbage* nil)
306    (setf *gc-verbose* #-gengc t #+gengc nil)    (setf *gc-verbose* t)
307    (setf *before-gc-hooks* nil)    (setf *before-gc-hooks* nil)
308    (setf *after-gc-hooks* nil)    (setf *after-gc-hooks* nil)
309    #-gengc (setf unix::*interrupts-enabled* t)    (setf unix::*interrupts-enabled* t)
310    #-gengc (setf unix::*interrupt-pending* nil)    (setf unix::*interrupt-pending* nil)
311    (setf *type-system-initialized* nil)    (setf *type-system-initialized* nil)
312    (setf *break-on-signals* nil)    (setf *break-on-signals* nil)
313    #+gengc (setf conditions::*handler-clusters* nil)    ;;
   
314    ;; Many top-level forms call INFO, (SETF INFO).    ;; Many top-level forms call INFO, (SETF INFO).
315    (print-and-call c::globaldb-init)    (print-and-call c::globaldb-init)
316      ;;
317    ;; Set up the fdefn database.    ;; Set up the fdefn database.
318    (print-and-call fdefn-init)    (print-and-call fdefn-init)
319      ;;
320    ;; Some of the random top-level forms call Make-Array, which calls Subtypep    ;; Some of the random top-level forms call Make-Array, which calls Subtypep
321    (print-and-call typedef-init)    (print-and-call typedef-init)
322    (print-and-call class-init)    (print-and-call class-init)
323    (print-and-call type-init)    (print-and-call type-init)
324    
325    (let ((funs (nreverse *lisp-initialization-functions*)))    (dolist (fun (nreverse *lisp-initialization-functions*))
326      (%primitive print "Calling top-level forms.")      (typecase fun
327      (dolist (fun funs) #+nil (%primitive print (hexstr fun))        (function (funcall fun))
328        (typecase fun  
329          (function        (cons
330           (funcall fun))         (case (car fun)
331          (cons           (:load-time-value
332           (case (car fun)            (setf (svref *load-time-values* (third fun))
333             (:load-time-value                  (funcall (second fun))))
334              (setf (svref *load-time-values* (third fun))  
335                    (funcall (second fun))))           (:load-time-value-fixup
336             (:load-time-value-fixup            (setf (sap-ref-32 (second fun) 0)
337              #-gengc                  (get-lisp-obj-address (svref *load-time-values* (third fun)))))
338              (setf (sap-ref-32 (second fun) 0)  
339                    (get-lisp-obj-address           #+(and x86 gencgc)
340                     (svref *load-time-values* (third fun))))           (:load-time-code-fixup
341              #+gengc            (vm::do-load-time-code-fixup
342              (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))                (second fun) (third fun) (fourth fun) (fifth fun)))
343             #+(and x86 gencgc)  
344             (:load-time-code-fixup           (:type-system-initialized
345              (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)            (setf *type-system-initialized* t))
346                                           (fifth fun)))  
347             (t           (:reader-init
348              (%primitive print            (print-and-call reader-init)
349                          "Bogus fixup in *lisp-initialization-functions*")            (setf *readtable* (copy-readtable std-lisp-readtable)))
350              (%halt))))  
351          (t           (:signal-init
352           (%primitive print            (print-and-call kernel::signal-init)
353                       "Bogus function in *lisp-initialization-functions*")            (setf (alien:extern-alien "internal_errors_enabled" boolean) t))
354           (%halt)))))  
355    (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.           (:set-floating-point-modes
356              (set-floating-point-modes
357               :traps '(:overflow #-x86 :underflow :invalid :divide-by-zero)))
358    
359             (:lisp-implementation-version
360              (setq *lisp-implementation-version* (cdr fun)))
361    
362             (:file
363              (%primitive print (cdr fun)))
364    
365             (:load
366              (load (cdr fun)))
367    
368             (:cold-core
369              (pushnew :cold-core *features*))
370    
371             (t
372              (let ((fun (car fun)))
373                (unless (and (symbolp fun) (fboundp fun))
374                  (%primitive print "Bogus init function.")
375                  (typecase fun
376                    (symbol (%primitive print (symbol-name fun)))
377                    (string (%primitive print fun)))
378                  (%halt))
379                (%primitive print (symbol-name fun))
380                (funcall fun)))))
381    
382          (t
383           (%primitive print "Bogus element in *LISP-INITIALIZATION-FUNCTIONS*")
384           (%halt))))
385    
386      (makunbound '*lisp-initialization-functions*)
387    (makunbound '*load-time-values*)    (makunbound '*load-time-values*)
388      (setf *already-maybe-gcing* nil)
389    
390    ;; Only do this after top level forms have run, 'cause thats where    (cond ((featurep :cold-core)
391    ;; deftypes are.           (setq *package* (find-package "USER"))
392    (setf *type-system-initialized* t)           (print-herald))
   
   (print-and-call os-init)  
   (print-and-call filesys-init)  
   
   (print-and-call reader-init)  
   ;; Note: sharpm and backq not yet loaded, so this is not the final RT.  
   (setf *readtable* (copy-readtable std-lisp-readtable))  
   
   (print-and-call stream-init)  
   (print-and-call loader-init)  
   (print-and-call package-init)  
   (print-and-call kernel::signal-init)  
   (setf (alien:extern-alien "internal_errors_enabled" boolean) t)  
   
   (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid  
                                                :divide-by-zero))  
   ;; This is necessary because some of the initial top level forms might  
   ;; have changed the compliation policy in strange ways.  
   (print-and-call c::proclaim-init)  
   
   (print-and-call kernel::class-finalize)  
   
   (%primitive print "Done initializing.")  
   
   #-gengc (setf *already-maybe-gcing* nil)  
   #+gengc (setf *gc-verbose* t)  
   (terpri)  
   (princ "CMU Common Lisp kernel core image ")  
   (princ (lisp-implementation-version))  
   (princ ".")  
   (terpri)  
   (princ "[You are in the LISP package.]")  
   (terpri)  
   (let ((wot  
          (catch '%end-of-the-world  
            (loop  
              (%top-level)  
              (write-line "You're certainly a clever child.")))))  
     (unix:unix-exit wot)))  
   
 #+gengc  
 (defun do-load-time-value-fixup (object offset index)  
   (declare (type index offset))  
   (macrolet ((lose (msg)  
                `(progn  
                   (%primitive print ,msg)  
                   (%halt))))  
     (let ((value (svref *load-time-values* index)))  
       (typecase object  
         (list  
          (case offset  
            (0 (setf (car object) value))  
            (1 (setf (cdr object) value))  
            (t (lose "Bogus offset in cons cell."))))  
         (instance  
          (setf (%instance-ref object (- offset vm:instance-slots-offset))  
                value))  
         (code-component  
          (setf (code-header-ref object offset) value))  
         (simple-vector  
          (setf (svref object (- offset vm:vector-data-offset)) value))  
393          (t          (t
394           (lose "Unknown kind of object for load-time-value fixup."))))))           (terpri)
395             (princ "CMUCL cold core ")
396             (princ (lisp-implementation-version))
397             (princ ".")
398             (terpri)
399             (princ "[You are in the LISP package.]")
400             (terpri)))
401    
402      (let ((wot (catch '%end-of-the-world
403                   (loop
404                      (%top-level)
405                      (write-line "You're certainly a clever child.")))))
406        (unix:unix-exit wot)))
407    
408    
409  ;;;; Initialization functions:  ;;;; Initialization functions:
# Line 495  Line 468 
468    
469  ;;;; SCRUB-CONTROL-STACK  ;;;; SCRUB-CONTROL-STACK
470    
471    #+control-stack-guard
472    (alien:def-alien-routine "os_guard_control_stack" c-call:void
473      (zone   c-call:int)
474      (guardp c-call:int))
475    
476  (defconstant bytes-per-scrub-unit 2048)  (defconstant bytes-per-scrub-unit 2048)
477    
# Line 544  Line 521 
521  (defun scrub-control-stack ()  (defun scrub-control-stack ()
522    "Zero the unused portion of the control stack so that old objects are not    "Zero the unused portion of the control stack so that old objects are not
523     kept alive because of uninitialized stack variables."     kept alive because of uninitialized stack variables."
524    (scrub-control-stack))    ;;
525      ;; The guard zone of the control stack is used by Lisp sometimes,
526      ;; so I think it should be zero'd out, too.
527      #+control-stack-guard
528      (os-guard-control-stack 0 0)
529      (%scrub-control-stack)
530      #+control-stack-guard
531      (os-guard-control-stack 0 1))
532    
533    #+x86
534    (defun %scrub-control-stack ()
535      (%scrub-control-stack))
536    
537    
538  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
539    
540  (defvar / nil  (defvar / nil
541    "Holds a list of all the values returned by the most recent top-level EVAL.")    "Holds a list of all the values returned by the most recent top-level EVAL.")
542  (defvar // nil "Gets the previous value of / when a new value is computed.")  (defvar // nil "Gets the previous value of / when a new value is computed.")
# Line 592  Line 580 
580              "EVAL returned an unbound marker."))              "EVAL returned an unbound marker."))
581    (values-list /))    (values-list /))
582    
   
583  (defconstant eofs-before-quit 10)  (defconstant eofs-before-quit 10)
584    
585  (defun %top-level ()  (defun %top-level ()
# Line 643  Line 630 
630  ;;;    A convenient way to get into the assembly level debugger.  ;;;    A convenient way to get into the assembly level debugger.
631  ;;;  ;;;
632  (defun %halt ()  (defun %halt ()
633      (%primitive print "%halt called")
634    (%primitive halt))    (%primitive halt))

Legend:
Removed from v.1.67  
changed lines
  Added in v.1.67.4.1

  ViewVC Help
Powered by ViewVC 1.1.5