/[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.49 by ram, Sat Jan 18 14:30:42 1997 UTC revision 1.49.2.4 by dtc, Thu Sep 14 14:35:13 2000 UTC
# Line 47  Line 47 
47    (special *gc-inhibit* *already-maybe-gcing*    (special *gc-inhibit* *already-maybe-gcing*
48             *need-to-collect-garbage* *gc-verbose*             *need-to-collect-garbage* *gc-verbose*
49             *before-gc-hooks* *after-gc-hooks*             *before-gc-hooks* *after-gc-hooks*
50               #+x86 *pseudo-atomic-atomic*
51               #+x86 *pseudo-atomic-interrupted*
52             unix::*interrupts-enabled*             unix::*interrupts-enabled*
53             unix::*interrupt-pending*             unix::*interrupt-pending*
54             *type-system-initialized*)             *type-system-initialized*)
# Line 64  Line 66 
66  (progn  (progn
67    
68  (defvar *current-catch-block*)  (defvar *current-catch-block*)
69  (defvar *current-unwind-block*)  (defvar *current-unwind-protect-block*)
70  (defvar *free-interrupt-context-index*)  (defvar *free-interrupt-context-index*)
71    
72  ); #-gengc progn  ); #-gengc progn
# Line 322  Line 324 
324                     (svref *load-time-values* (third fun))))                     (svref *load-time-values* (third fun))))
325              #+gengc              #+gengc
326              (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))              (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
327               #+(and x86 gencgc)
328               (:load-time-code-fixup
329                (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
330                                             (fifth fun)))
331             (t             (t
332              (%primitive print              (%primitive print
333                          "Bogus fixup in *lisp-initialization-functions*")                          "Bogus fixup in *lisp-initialization-functions*")
# Line 348  Line 354 
354    (print-and-call loader-init)    (print-and-call loader-init)
355    (print-and-call package-init)    (print-and-call package-init)
356    (print-and-call kernel::signal-init)    (print-and-call kernel::signal-init)
357    (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)    (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
358    
359    (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid    (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid
360                                                 :divide-by-zero))                                                 :divide-by-zero))
# Line 415  Line 421 
421      (stream-reinit)      (stream-reinit)
422      (kernel::signal-init)      (kernel::signal-init)
423      (gc-init)      (gc-init)
424      (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)      (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
425      (set-floating-point-modes :traps      (set-floating-point-modes :traps
426                                '(:overflow #-x86 :underflow :invalid                                '(:overflow #-x86 :underflow :invalid
427                                            :divide-by-zero)))))                                            :divide-by-zero))
428        ;; Clear pseudo atomic in case this core wasn't compiled with support.
429        #+x86 (setf lisp::*pseudo-atomic-atomic* 0))))
430    
431    
432  ;;;; Miscellaneous external functions:  ;;;; Miscellaneous external functions:
# Line 434  Line 441 
441        (throw '%end-of-the-world 0)))        (throw '%end-of-the-world 0)))
442    
443    
444    #-mp ; Multi-processing version defined in multi-proc.lisp.
445  (defun sleep (n)  (defun sleep (n)
446    "This function causes execution to be suspended for N seconds.  N may    "This function causes execution to be suspended for N seconds.  N may
447    be any non-negative, non-complex number."    be any non-negative, non-complex number."
# Line 443  Line 451 
451              Must be a non-negative, non-complex number."              Must be a non-negative, non-complex number."
452             n))             n))
453    (multiple-value-bind (sec usec)    (multiple-value-bind (sec usec)
454                         (if (integerp n)      (if (integerp n)
455                             (values n 0)          (values n 0)
456                             (values (truncate n)          (multiple-value-bind (sec frac)(truncate n)
457                                     (truncate (* n 1000000))))            (values sec(truncate frac 1e-6))))
458      (unix:unix-select 0 0 0 0 sec usec))      (unix:unix-select 0 0 0 0 sec usec))
459    nil)    nil)
   
460    
461  ;;;; SCRUB-CONTROL-STACK  ;;;; SCRUB-CONTROL-STACK
462    
463    
464  (defconstant bytes-per-scrub-unit 2048)  (defconstant bytes-per-scrub-unit 2048)
465    
466    ;;; Scrub-control-stack.
467    ;;;
468  #-x86  #-x86
469  (defun scrub-control-stack ()  (defun scrub-control-stack ()
470    "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
# Line 490  Line 499 
499        (scrub (int-sap (- csp initial-offset))        (scrub (int-sap (- csp initial-offset))
500               (* (floor initial-offset vm:word-bytes) vm:word-bytes)               (* (floor initial-offset vm:word-bytes) vm:word-bytes)
501               0))))               0))))
502    
503  #+x86 ;; Stack grows downwards  ;;; Scrub-control-stack.
504    ;;;
505    ;;; On the x86 port the stack grows downwards, and to support grow on
506    ;;; demand stacks the stack must be decreased as it is scrubbed.
507    ;;;
508    #+x86
509  (defun scrub-control-stack ()  (defun scrub-control-stack ()
510    "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
511     kept alive because of uninitialized stack variables."     kept alive because of uninitialized stack variables."
512    (declare (optimize (speed 3) (safety 0))    (scrub-control-stack))
            (values (unsigned-byte 20)))  
   (labels  
       ((scrub (ptr offset count)  
          (declare (type system-area-pointer ptr)  
                   (type (unsigned-byte 16) offset)  
                   (type (unsigned-byte 20) count)  
                   (values (unsigned-byte 20)))  
          (let ((loc (int-sap (- (sap-int ptr) (+ offset vm:word-bytes)))))  
            (cond ((= offset bytes-per-scrub-unit)  
                   (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))  
                         0 count))  
                  (t ;; need to fix bug in %set-stack-ref  
                   (setf (sap-ref-32 loc 0) 0)  
                   (scrub ptr (+ offset vm:word-bytes) count)))))  
        (look (ptr offset count)  
          (declare (type system-area-pointer ptr)  
                   (type (unsigned-byte 16) offset)  
                   (type (unsigned-byte 20) count)  
                   (values (unsigned-byte 20)))  
          (let ((loc (int-sap (- (sap-int ptr) offset))))  
            (cond ((= offset bytes-per-scrub-unit)  
                   count)  
                  ((zerop (stack-ref loc 0))  
                   (look ptr (+ offset vm:word-bytes) count))  
                  (t  
                   (scrub ptr offset (+ count vm:word-bytes)))))))  
     (let* ((csp (sap-int (c::control-stack-pointer-sap)))  
            (initial-offset (logand csp (1- bytes-per-scrub-unit))))  
       (declare (type (unsigned-byte 32) csp))  
       (scrub (int-sap (+ csp initial-offset))  
              (* (floor initial-offset vm:word-bytes) vm:word-bytes)  
              0))))  
   
   
513    
514    
515  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
# Line 557  Line 537 
537    +, ///, //, /, and -."    +, ///, //, /, and -."
538    (setf - form)    (setf - form)
539    (let ((results (multiple-value-list (eval form))))    (let ((results (multiple-value-list (eval form))))
540        (finish-standard-output-streams)
541      (setf /// //      (setf /// //
542            // /            // /
543            / results            / results

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.49.2.4

  ViewVC Help
Powered by ViewVC 1.1.5