(* This is the beaver compiled code processor. *)

(setq statistics-wanted t)
(globalvars statistics-wanted)
(globalvars nlisp-stats-window)

(defun 1.9-lisp (stream) 
   (do (ersetq (1.9-lisp-kernel stream))))

(* ## variables: statistics. 
   ** variables: important machine registers that carry
                 state across instruction boundaries. 
   Other local variables are intra-instruction temps
   or constants. *) 
   
(defun 1.9-lisp-kernel (stream)
  (prog (**env **pc **frame **next **cont 
         ##first-opcode ##last-opcode ##freq-table 
         ##time-table ##opname-alist ##nexecuted 
         ##start-time ##start-tick ##end-tick ##old-opcode
         ##nconses ##nmsec ##before-compile-time
         ##after-compile-time ##tick ##ngc ##gc-time
         ##pagefaults
         scratchpad halter opcode
         inst instargs nargs embedded objectified
         temp culprit skeleton spread nexpected arg-ptr
         arg1 arg2 arg3 message var exp 
         primitive-name result next-contour contour proc
         variables binding arg-offset arg-number
         env-wrapper cont-wrapper scratchpad-wrapper
         frame-wrapper var-index) 

     (if statistics-wanted then
         (setq ##first-opcode *return-opcode*)
         (setq ##last-opcode *halt-opcode*)
         (setq ##freq-table 
           (array (add1 (idifference ##last-opcode ##first-opcode)) 
              NIL 0 ##first-opcode))
         (setq ##time-table  
           (array (add1 (idifference ##last-opcode ##first-opcode)) 
              NIL 0 ##first-opcode))
         (setq ##ngc 0)
         (setq ##gc-time 0)
         (setq ##opname-alist 
            (list (list *return-opcode* 'ret)
              (list *const-opcode* 'const)
              (list *var-opcode* 'var)
              (list *pcheck-opcode* 'pcheck)
              (list *call-opcode* 'call)
              (list *start-opcode* 'start)
              (list *tstart-opcode* 'tstart)
              (list *ostart-opcode* 'ostart)
              (list *tostart-opcode* 'tostart)
              (list *lambda-opcode* 'lambda)
              (list *if-opcode* 'if)
              (list *primitive-opcode* 'primitive)
              (list *gset-opcode* 'gset)
              (list *halt-opcode* 'halt))) )

     (* The scratchpad is a dummy frame to hold the 
        overall result. *) 

     (setq scratchpad (ncreate-frame 0 nil nil))
     (setq scratchpad-wrapper (wrap scratchpad))

     (setq env-wrapper (wrap nil))
     (setq frame-wrapper (wrap nil))
     (setq cont-wrapper (wrap nil))

     (setq halter (list (list *halt-opcode*)))

 (* READ-NORMALISE-PRINT loop. *)

   read-normalise-print
     (setq exp (prompt&read stream))

     (if statistics-wanted then
         (setq ##before-compile-time (clock)))

     (setq **pc (beaver exp global-env))

     (if statistics-wanted then
         (setq ##after-compile-time (clock)))

     (setq **env global-env)
     (setq **frame scratchpad)
     (setq **next words-per-ptr)
     (setq **cont 
        (ncreate-cont halter **env **frame **next nil))

     (if statistics-wanted then
         (setq ##nexecuted 0)
         (for i from ##first-opcode to ##last-opcode do
            (seta ##freq-table i 0)
            (seta ##time-table i 0))
         (conscount 0)
         (setq ##pagefaults (pagefaults))
         (setq opcode *halt-opcode*)
         (setq ##nmsec 0)
         (setq ##start-tick (clock)))  

     (go decode)



 (* INSTRUCTION DECODING. *)
     
   decode
     (if statistics-wanted then
         (setq ##end-tick (clock))
         (setq ##old-opcode opcode)
         (setq ##tick (idifference ##end-tick ##start-tick))
         (seta ##time-table ##old-opcode
            (iplus (elt ##time-table ##old-opcode) ##tick))
         (setq ##nmsec (iplus ##nmsec ##tick))
         (setq ##nexecuted (add1 ##nexecuted))
         (seta ##freq-table ##old-opcode 
             (add1 (elt ##freq-table ##old-opcode)))
         (setq ##start-tick (clock)) )

     (if (ilessp 
            (fetch (space-header wordsleft) of new-space) 
            100) then
         (replace (nlisp-object uglyaddr) 
            of env-wrapper with **env)
         (replace (nlisp-object uglyaddr) 
            of frame-wrapper with **frame)
         (replace (nlisp-object uglyaddr) 
            of scratchpad-wrapper with scratchpad)
         (replace (nlisp-object uglyaddr) 
            of cont-wrapper with **cont)
         (gsgc)
         (setq **env 
            (fetch (nlisp-object uglyaddr) of env-wrapper))
         (setq **frame 
            (fetch (nlisp-object uglyaddr) of frame-wrapper))
         (setq scratchpad 
            (fetch (nlisp-object uglyaddr) of scratchpad-wrapper))
         (setq **cont 
            (fetch (nlisp-object uglyaddr) of cont-wrapper))
         (if statistics-wanted then
             (setq ##end-tick (clock))
             (setq ##ngc (add1 ##ngc))
             (setq ##gc-time 
                (iplus ##gc-time 
                   (idifference ##end-tick ##start-tick)))  
             (setq ##start-tick (clock))) )
         
     
     (setq inst (car **pc))
     (setq **pc (cdr **pc))
     (setq opcode (car inst))
     (setq instargs (cdr inst))

     (select opcode
        (*return-opcode*     (go return))
        (*var-opcode*        (go var))
        (*const-opcode*      (go const))
        (*start-opcode*
            (setq nargs (car instargs))
            (setq embedded t)
            (setq objectified nil)
            (go start))
        (*tstart-opcode*
            (setq nargs (car instargs))
            (setq embedded nil)
            (setq objectified nil)
            (go start))
        (*ostart-opcode*
            (setq nargs 1)
            (setq embedded t)
            (setq objectified t)
            (go start))
        (*tostart-opcode*
            (setq nargs 1)
            (setq embedded nil)
            (setq objectified t)
            (go start))
        (*pcheck-opcode*    (go pcheck))
        (*call-opcode*      (go call))
        (*lambda-opcode*    (go lambda))
        (*if-opcode*        (go if))
        (*primitive-opcode* (go primitive))
        (*gset-opcode*      (go gset))
        (*halt-opcode*      (go halt))
        (shouldnt "bad 3-lisp opcode"))
     
   const
     (\putbaseptr **frame **next (car instargs))
     (setq **next (iplus **next words-per-ptr)) 
     (go decode)

   var 
     (setq var (car instargs))
     (setq contour **env)      
   search-next-contour
     (if (null contour) then
         (setq result (nlisp-global-binding var))
         (if (eq result 'not.found) then
             (go failure))
         (go success))
     (setq proc (fetch (stack-frame proc) of contour))
     (* proc is guaranteed to be unwrapped. *)
     (setq objectified (fetch (stack-frame objectified) of contour))
     (setq skeleton (fetch (stack-closure skeleton) of proc))
     (setq variables (variable-list skeleton))
     (setq var-index 0)
   next-variable
     (if (null variables) then
         (setq contour (fetch (stack-closure env) of proc)) 
         (go search-next-contour))
     (if (neq var (car variables)) then
         (setq var-index (add1 var-index))
         (setq variables (cdr variables))
         (go next-variable))
     (* Variable is bound in this contour. *)
     (if (not objectified) then
         (setq arg-offset 
            (iplus words-per-stack-frame 
                (itimes words-per-ptr var-index)))
         (setq result (\getbaseptr contour arg-offset))
      else
         (setq temp (fetch (stack-frame arg1) of contour))
         (for i from 1 to (sub1 var-index) do 
            (setq temp (rest temp)))
         (setq result (first temp)))
   success
     (\putbaseptr **frame **next result)
     (setq **next (iplus **next words-per-ptr))
     (go decode)
   failure
     (setq culprit var)
     (setq message "unbound variable")
     (go diagnose-error)



 (* xxSTART instruction(s).  *)

   start
     (* Begin by creating a continuation if necessary. *)
     (if embedded then
        (setq **cont
          (ncreate-cont nil **env **frame **next **cont)))
     (* Now allocate a new frame. *)
     (setq **frame (ncreate-frame nargs embedded objectified))
     (setq **next words-per-ptr)
     (go decode)



 (* PCHECK instruction.  *)

   pcheck
     (setq proc (fetch (stack-frame proc) of **frame))
     (* Unwrap it if necessary. *)
     (if (type? nlisp-object proc) then
         (setq proc (unwrap proc))
         (replace (stack-frame proc) of **frame with proc))
     (if (not (stack-closure? proc)) then
         (setq culprit proc)
         (setq message "not reducible")
         (go diagnose-error))
     (setq skeleton 
         (fetch (stack-closure skeleton) of proc))
     (if (reflective? skeleton) then
         (shouldnt "Surprised by a special closure."))
     (go decode)



 (* CALL instruction.  *)

   call
     (setq embedded (fetch (stack-frame embedded) of **frame))
     (setq nargs (fetch (stack-frame nargs) of **frame))
     (setq objectified (fetch (stack-frame objectified) of **frame))
     (setq proc (fetch (stack-frame proc) of **frame))
     (if (type? nlisp-object proc) then
         (setq proc (unwrap proc))
         (replace (stack-frame proc) of **frame with proc))
     (setq skeleton (fetch (stack-closure skeleton) of proc))
     (setq spread (spread? skeleton))
     (setq nexpected (nexpected skeleton))     
     (cond ((and spread (not objectified))
            (go check-arity))
           ((and spread objectified)
            (go spread-args))
           ((and (not spread) objectified)
            (replace (stack-frame objectified) of 
               **frame with nil)
            (go no-problems))
           ((and (not spread) (not objectified))
            (go collect-args)))

   check-arity
     (if (eq nargs nexpected) then
         (go no-problems)
      else
         (go mismatch))

   no-problems
     (setq **env **frame)
     (setq **frame scratchpad)
     (setq **next words-per-ptr)     
     (if embedded then
         (replace (stack-cont pc) of **cont with **pc))
     (setq **pc (start-address skeleton))
     (go decode)

   collect-args
     (setq result (rcons0))
     (for i from 1 to nargs do
        (setq **next (idifference **next words-per-ptr))
        (setq arg1 (\getbaseptr **frame **next))
        (\putbaseptr **frame **next nil)
        (if (stack-object? arg1) then
            (setq arg1 (wrap arg1)))
        (setq result (prep arg1 result)))
     (replace (stack-frame arg1) of **frame with result)
     (replace (stack-frame objectified) of **frame with t)
     (go no-problems)

   spread-args
     (setq arg1 (fetch (stack-frame arg1) of **frame))
     (if (rail? arg1) then
         (setq nargs (rlength arg1))
         (go check-arity)
      else
         (go mismatch))

   mismatch
     (setq culprit proc)
     (setq message "incorrect number of arguments")
     (go diagnose-error)



 (* RETURN instruction. *)

   return
     (setq temp 
         (\getbaseptr **frame 
             (idifference **next words-per-ptr)))
   restore-continuation
     (setq **env   (fetch (stack-cont env) of **cont))
     (setq **frame (fetch (stack-cont frame) of **cont))
     (setq **next  (fetch (stack-cont next) of **cont))
     (setq **pc    (fetch (stack-cont pc) of **cont))
     (setq **cont  (fetch (stack-cont cont) of **cont))
     (\putbaseptr **frame **next temp)
     (setq **next (iplus **next words-per-ptr))
     (go decode)



 (* LAMBDA instruction. *)

   lambda
     (setq temp (ncreate-closure (car instargs) **env))
     (\putbaseptr **frame **next temp)
     (setq **next (iplus **next words-per-ptr))
     (go decode)



 (* IF instruction. *)

   if
     (setq **next (idifference **next words-per-ptr))
     (setq temp (\getbaseptr **frame **next))
     (if (null temp) then
         (setq **pc (cadr instargs))
         (go decode))
     (if (eq temp t) then
         (setq **pc (car instargs))
         (go decode))
     (setq culprit temp)
     (setq message "IF expects a truth value")
     (go diagnose-error)



 (* PRIMITIVE instruction. *)

   primitive
       (* Note that this instruction must be the entire
          body of some closure. *)
       (setq primitive-name (car instargs))
       (setq nargs (fetch (stack-frame nargs) of **env))
       (setq objectified (fetch (stack-frame objectified) of **env))
       (if objectified then
           (go ugly-call-on-primitive))
       (setq arg1 nil)
       (setq arg2 nil)
       (setq arg3 nil)
       (if (eq nargs 1) then (go unpack-1))
       (if (eq nargs 2) then (go unpack-2))
       (if (eq nargs 0) then (go done-unpacking))
     unpack-3
       (setq arg3 (fetch (stack-frame arg3) of **env))
     unpack-2
       (setq arg2 (fetch (stack-frame arg2) of **env))
     unpack-1
       (setq arg1 (fetch (stack-frame arg1) of **env))
     done-unpacking
       (if (nlsetq
               (setq temp (apply* primitive-name arg1 arg2 arg3)) 
               t) then
           (go restore-continuation))
     error-in-primitive
       (setq culprit primitive-name)
       (setq message "error in a primitive")
       (go diagnose-error)

     ugly-call-on-primitive
       (setq arg1 (fetch (stack-frame arg1) of **env))
       (if (nlsetq
             (* We rely here on rails being suffixed lists. *)
             (setq temp (apply primitive-name arg1)) 
             t) then
           (go restore-continuation)
        else
           (go error-in-primitive))



 (* GSET instruction. *)
 
   gset
     (setq var (car instargs))
     (setq result 
         (\getbaseptr **frame 
             (idifference **next words-per-ptr)))
     (if (stack-closure? result) then
         (setq result (wrap result)))
     (put var 'nlisp result)
     (go decode)


 (* HALT instruction. *)

   halt
     (setq result 
         (\getbaseptr **frame 
             (idifference **next words-per-ptr)))
     (if (stack-closure? result) then
         (setq result (wrap result)))

     (if statistics-wanted then
         (setq ##pagefaults 
            (idifference (pagefaults) ##pagefaults))
         (setq ##nconses (conscount)) )

     (prompt&print result stream)
     (go display-statistics)



 (* Display execution statistics. *)

   display-statistics
     (if statistics-wanted then
         (if (or (not (boundp 'nlisp-stats-window))
                 (not (windowp nlisp-stats-window))) then
             (setq nlisp-stats-window
                (createw nil "n-lisp statistics")))
         (clearw nlisp-stats-window)
         (printout nlisp-stats-window .i5
            (idifference ##after-compile-time ##before-compile-time)
            " msec. compilation." t
            .i5  ##nmsec " msec. execution." t
            .i5  ##nexecuted " inst." t
            .i5  ##nconses " conses." t
            .i5  ##pagefaults " page faults." t t
            .i5  ##ngc " garbage collections so far." t
            .i5  ##gc-time " msec. gc." t t)
            
         (for i from ##first-opcode to ##last-opcode do
             (printout nlisp-stats-window 
                1       (cadr (assoc i ##opname-alist))  
                12 .i5  (elt ##freq-table i)   
                18 .i5  (elt ##time-table i) 
                25 .f5.3 (fquotient 
                           (elt ##time-table i) 
                           (elt ##freq-table i)) 
                t)) )
 
     (go read-normalise-print)



 (* Error handling. *)

   diagnose-error
     (if (stack-object? culprit) then
         (setq culprit nil))

     (if statistics-wanted then
         (setq ##pagefaults
            (idifference (pagefaults) ##pagefaults))
         (setq ##nconses (conscount)))

     (printout stream "*** " message "." t)
     (if (not (stack-object? culprit)) then
         (printout stream "Hint: " .ppv (export culprit) t))
     (printout stream t "Reset." t)
     (setq message nil)
     (setq culprit nil)
     (go display-statistics)
))


STOP