Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/t3_1/risc_src.lha/risc_sources/sys/sparckernel.t

Text File | 1990-04-12 | 11.8 KB | 339 lines

(herald sparckernel (env tsys))

;;; Copyright (c) 1985 Yale University
;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer
;;; Science Department.  Permission to copy this software, to redistribute it,
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions and understandings.
;;; 1. Any copy made of this software must include this copyright notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;;    to the T Project at Yale any improvements or extensions that they make,
;;;    so that these may be included in future releases; and (b) to inform
;;;    the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;;    shall duly acknowledge such use, in accordance with the usual standards
;;;    of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;;    this software will be error-free, and Yale is under no obligation to
;;;    provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;;    there shall be no use of the name of the Yale University nor of any
;;;    adaptation thereof in any advertising, promotional, or sales literature
;;;    without prior written consent from Yale in each case.
;;;

;;; The procedure big_bang MUST come first in this file.
;;; BIG_BANG is called to instantiate the root process of an external
;;; T image. It is called by a foreign stub program with arguments
;;; as follows:
;;;
;;;  (BIG_BANG memory mem-size argc argv bsd4.2?).
;;;
;;; The argument vector is saved as a T vector in *BOOT-ARGS*.  The
;;; Xenoids are created for STDIN and STDOUT and placed in the 2nd
;;; and 3rd argument registers.  The global-constant register (NIL)
;;; and the task register are initialized, and the root process
;;; block is created and initialized.  The stack is initialized.
;;; The heap-pointer and heap-limit of the root process are
;;; initialized.  Finally the address of the T procedure BOOT is
;;; placed in them P (procedure) register, and we jump through the
;;; root process block to ICALL.  Boot is called as follows:
;;;
;;;     (BOOT root-task boot-args),

;;; Unresolved issues:
;;; - Is the arg vector the right size and is the descriptor correct?
;;; - What should the initial stack size be and how can you tell?
;;; - The stack and areas should have guards - later I  guess
;;; - how to boot other systems
;;; - stdio shit?
;;; - PID as Fixnum?
;;; - *the-slink*
;;; - test stack-overflow in icall?
;;; - heap overflow code
;;; - exception code
;;; - interrupt code


;;;  When we enter Big_bang the stack looks as follows:
;;;
;;;              |      debug?   |
;;;              |_______________|
;;;              |      argv     |    Command line argv
;;;              |_______________|
;;;              |      argc     |    Command line argc
;;;              |_______________|
;;;              |  heap-size    |
;;;              |_______________|
;;;              |     heap2     |
;;;              |_______________|
;;;              |     heap1     |
;;;              |_______________|
;;;       SP =>  |     dummy     |
;;;              |_______________|
;;;              |    header     |  <= *boot-args*
;;;              |_______________|

(define (big_bang)
  (lap (*boot* *the-slink* risc-big-bang)
                    ;big_bang is in SP
                    ;interrupt handler in link
    ;; set up global-constants
;    (save ($ (- (* 4 (+ 16 6 1 8 1)))) ssp ssp)
 ; min size + boot args + 2  dummy + double word alignment
    (move SP P)                ;big_bang
    (load l (d@r P (static *the-slink*)) nil-reg)
    (load l (d@r nil-reg 2) nil-reg)
    (sub ($ 3) nil-reg sp)        ;grows down to data bottom 512K
    (sll ($ 2) link-reg)
    (store l link-reg (d@nil slink/interrupt-handler))    ; interrupt_xenoid
    (move ($ header/true) t-reg)
    (move zero crit-reg)
    (sub ($ (* 8 4)) sp)
    (store l ass-reg (d@r sp (+ 8 0)))        ;heap1  a8 = %o0
    (store l extra-args (d@r sp (+ 8 4)))        ;heap2
    (store l extra (d@r sp (+ 8 8)))        ;heap-size
    (store l parassign-extra (d@r sp (+ 8 12)))        ;argc
    (store l vector (d@r sp (+ 8 16)))        ;argc
    (store l scratch (d@r sp (+ 8 20)))        ;argc
    (add ($ 8) sp A1)  ; save argument pointer
    (movec (fx+ (fixnum-ashl 6 8) header/general-vector) extra)
    (store l extra (d@r sp 0))
    (add ($ 2) sp a2)
    (store l A2 (d@nil slink/boot-args))    ; we have 6 boot-args

    (load l (d@r P (static risc-big-bang)) P)
    (load l (d@r p 2) p)
    (load l (d@r P -2) extra)
    (add ($ 2) extra)
    (jalr extra)
    (add ($ 8) link-reg)
    ;; initialize area, area-frontier, and area-limit
    (load l  (d@r A1 0) scratch)                       ; move addr heap
    (store l scratch (d@nil slink/area-begin))
    (store l scratch (d@nil slink/area-frontier))
    (load l (d@r A1 8) vector)
    (add vector scratch)
    (store l scratch (d@nil slink/area-limit))

    ;; Set up the procedure register P and call boot,
    ;; never to return. (note: args 2 was setup above)
    (move nil-reg A3)
    (load l (d@r a1 20) extra)
    (j= extra zero %debug)
    (move t-reg A3)
%debug
    (store l zero (d@nil slink/saved-ssp))
    (load l (d@r P (static *boot*)) P)
    (load l (d@r p 2) p)
    (load l (d@r P -2) extra)
    (add ($ 2) extra)
    (jr extra)
    (move  ($ 4) NARGS)))


;;;; Low-level exception handling

;;; Interrupts can be deferred.
;;; the task/critical count byte has
;;; bit 7 -- interrupts deferred
;;; bit 0 -- quit pending

(define (interrupt_dispatcher)       ; signal=%o0,code=%o1,context=%o2
  (lap (signal-handler enable-signals gc-interrupt)
    (load l (d@r %o3 (static *the-slink*)) %o4) ;unit is in a11(i3)
    (load l (d@r %o4 2) %o4)
    (load l (d@r %o4 slink/doing-gc?) %o5)
    (jn= %o5 %o4 %doing-gc)    ; are we doing gc?
    (load l (d@r %o4 slink/saved-sp) %o5)
    (jn= %o5 zero %foreign)
    (load l (d@r %o2 24) sp)        ;sc_g1 = sp
    (jn= %o0 ($ 2) %fault)                   ; is this a ^c?
    (load l (d@r %o2 8) %o1)        ;fault ssp
    (load l (d@r %o1 (* 4 15)) %o2)    ;saved crit-reg (i7)
    (mask ($ 1) %o2 %o5)    ; is this the second one?
    (j= %o5 zero %set-interrupt-flag) ; if not, defer interrupt
    (mask ($ #xfe) %o2)        ;turn off bit 0
    (store l %o2 (d@r %o1 (* 4 15)))
    (j= %o2 zero %fault)        ; are interrupts deferred?
%set-interrupt-flag
    (or ($ 1) %o2)            ; set quit bit
    (store l %o2 (d@r %o1 (* 4 15)))
%ignore-interrupt
    (jmpl (d@r link-reg 8) zero)
    (noop)
%doing-gc
    (jmpl (d@r link-reg 8) zero)
    (noop)

;;; Interrupts should be disabled here.
%foreign
    (move %o5 sp)            ;saved sp
    (store l zero (d@r %o4 slink/saved-sp))
    (restore zero zero zero)        ;link reg at time of foreign
    (save a5 zero %o1)            ;call is in A5=%l5
    (jbr %shared-fault)
%fault
    (move crit-reg %o1)            ;crit-reg = %i7 = return address (link)
    (move zero %o5)
%shared-fault
    (sub ($ 12) sp)            ;retore if we throw out
    (store l %o1 (d@r sp 8))        ;describe top of stack, old link-reg
    (store l %o5 (d@r sp 4))        ;saved sp
    (store l link-reg (d@r sp 0))    ;save handler ra
    (save ($ -64) ssp ssp)
    (move %i4 nil-reg)            ;%o4->%i4 from save
    (move ($ header/true) t-reg)
    (load l  (d@r %i3 (static signal-handler)) p)
    (load l (d@r p 2) p)
    (move zero a1)            ;dummy ssp
    (sll ($ 2) %i0 a2)            ;signal number
    (move zero a3)
    (move zero a4)
    (move zero a5)
    (move zero a6)
    (move zero a7)
    (move zero a8)
    (move zero a9)
    (move zero a10)
    (move zero a11)
    (move zero an)
    (move zero an+1)
    (move zero extra-args)
    (move zero parassign-extra)
    (move zero ass-reg)
    (move zero crit-reg)
    (load l (d@r p -2) extra)
    (add ($ 2) extra)
    (move ($ 3) nargs)
    (jalr extra)
    (add ($ template-return-offset) link-reg)
    (template 2 -1 t)
    (load l (d@r sp 4) %o1)
    (store l %o1 (d@nil slink/saved-sp))
    (restore zero zero zero)
    (load l (d@r sp 0) link-reg)    ;restore handler ra
    (jmpl (d@r link-reg 8) zero)    ;return to fault
    (add ($ 12) sp)))


(define (reset-ssp ssp)
  (lap ()
    (move nil-reg t-reg)        ;t-reg is only global we can use
    (restore zero link-reg link-reg)    ;restore our save
    (restore zero link-reg link-reg)    ;restore fault handler's save
    (move t-reg nil-reg)        ;restore nil
    (move ($ header/true) t-reg)    ;restore t
    (move zero p)
    (move zero a1)
    (move zero a2)
    (move zero a3)
    (move zero a4)
    (move zero a5)
    (move zero a6)
    (move zero a7)
    (move zero a8)
    (move zero a9)
    (move zero a10)
    (move zero a11)
    (move zero an)
    (move zero an+1)
    (move zero extra)
    (move zero extra-args)
    (move zero parassign-extra)
    (move zero ass-reg)
    (move zero crit-reg)
    (jr link-reg)
    (move ($ -1) nargs)))

(define (flush-code-from-icache bytev)
  (lap ()
    (load l (d@r a1 -2) scratch)
    (sra ($ 8) scratch)            ;length in bytes
    (add a1 scratch)            ;past end
    (jbr flush-test)
flush-loop
    (iflush ($ 2) a1 zero)
    (add ($ 4) a1)
flush-test
    (j< a1 scratch flush-loop)
    (move zero a1)
    (jr link-reg)
    (move ($ -2) nargs)))


(define local-processor
  (lambda ()
    (object nil
      ((processor-type self)     'sparc)
      ((print-type-string self)  "Processor"))))

(define (local-machine)
  (object nil
      ((machine-type self)          'sparc)
      ((machine-suspend-file self) '(link sparcsuspend))
      ((object-file-type self)      'so)
      ((information-file-type self) 'si)
      ((noise-file-type self)       'sn)
      ((debug-file-type self)       'sd)
      ((print-type-string self)     "Machine")))

(define (nan? x)
  (or (fx= (isnan x) 1)
      (fx= (isinf x) 1)))

(define-foreign isnan ("isnan" (in rep/double)) rep/integer)
(define-foreign isinf ("isinf" (in rep/double)) rep/integer)

(define (st_mtime stat-block)
  (+ (ash (mref-16-u stat-block 32) 16)
     (mref-16-u stat-block 34)))

(define-integrable (st_size stat-block)
  (mref-integer stat-block 20))


(define-integrable (st_mode stat-block)
  (mref-16-u stat-block 8))

(define-constant %%apollo-d-ieee-size 53)
(define-constant %%apollo-d-ieee-excess 1023)

;;; <n,s> means bit field of length s beginning at bit n of the first
;;; WORD (not longword)
;;;                    sign      exponent   MSB       fraction
;;; IEEE flonum        <15,1>    <4,11>     hidden    <0,4>+next 3 words
;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words

(define (integer-decode-float x)     ; IEEE version
  (let ((a (mref-16-u x 0)))
    (return (if (fl<= 0.0 x) 1 -1)
            (+ (mref-16-u x 6)
               (%ash (+ (mref-16-u x 4)
                        (%ash (fx+ (mref-16-u x 2)
                                   (fixnum-ashl (fx+ (fixnum-bit-field a 0 4) 16)
                                                16))
                              16))
                     16))
            (fx- (fixnum-bit-field a 4 11) (fx+ 1024 51)))))

(define (integer-encode-float sign m e)
  (let ((float (make-flonum)))
    (receive (sign mantissa exponent)
             (normalize-float-parts sign
                                    m
                                    e
                                    %%apollo-d-ieee-size
                                    %%apollo-d-ieee-excess
                                    t)
      (set (mref-16-u float 0) (fx+ (fixnum-ashl sign 15)
                                    (fx+ (fixnum-ashl exponent 4)
                                         (bignum-bit-field mantissa 48 4))))
      (set (mref-16-u float 2) (bignum-bit-field mantissa 32 16))
      (set (mref-16-u float 4) (bignum-bit-field mantissa 16 16))
      (set (mref-16-u float 6) (bignum-bit-field mantissa 0  16))
      float)))