; The M1 Virtual Machine Examples
; Copyright (C) 2004  J Strother Moore,
;               University of Texas at Austin

; This program is free software; you can redistribute it and/or 
; modify it under the terms of the GNU General Public License as
; published by the Free Software Foundation; either version 2 of
; the License, or (at your option) any later version.

; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.

; You should have received a copy of the GNU General Public
; License along with this program; if not, write to the Free 
; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
; USA.

; Written by: J Strother Moore
; email:      Moore@cs.utexas.edu
; Department of Computer Sciences
; University of Texas at Austin
; Austin, TX 78712-1188 U.S.A.

; Modified by: John Cowles
; email:       cowles@uwyo.edu
; Department of Computer Science
; University of Wyoming
; Laramie, WY 82071 U.S.A.
;==============================================================

(include-book "m1")

(in-package "M1")

;; Take a close look at the implementation of CALL and RET.

;; (defun reverse (lst)
;;   (if (consp lst)
;;       (append (reverse (cdr lst)) (list (car lst)))
;;       nil))

;; (defun bind-formals (rformals stack)
;;   (if (endp rformals)
;;       nil
;;       (cons (cons (car rformals) (top stack))
;; 	    (bind-formals (cdr rformals)
;; 			  (pop stack)))))

;; (defun popn (n stack)
;;   (if (zp n)
;;       stack
;;       (popn (- n 1) (pop stack))))

;; ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
;; ; Informal Spec: (CALL fname)
;; ; Let fdef be the definition of the fname in defs and let L be the
;; ; length of the formals of fdef. Bind the top L items of the 
;; ; operand stack to the formals, with the last formal bound to the
;; ; top of the stack, etc. Modify the current top frame by incrementing
;; ; the pc and poping the top L items off the operand stack.

;; ; Push the following frame on top of the modified current frame on
;; ; the call-stack:      pc: 0
;; ;                  locals: binding of formals created above
;; ;                   stack: empty stack
;; ;                 program: body of fdef   

;; (defun execute-CALL (inst s)
;;   (let* ((fn (arg1 inst))
;;          (def (binding fn (defs s)))
;;          (formals (car def))
;;          (body (cdr def))
;;          (s1 (modify s
;;                      :pc (+ 1 (pc s))
;;                      :stack (popn (len formals) (stack s)))))
;;     (modify s1
;;             :call-stack
;;             (push (make-frame 0
;;                               (reverse
;;                                (bind-formals (reverse formals)
;;                                              (stack s)))
;;                               nil
;;                               body)
;;                   (call-stack s1)))))

;; ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
;; ; Informal Spec: (RET)
;; ; Let val be the item on top of the operand stack of the top frame.
;; ; Pop the top frame off the call-stack and push val on top of the
;; ; operand stack of the newly exposed top frame.

;; (defun execute-RET (inst s)
;;   (declare (ignore inst))
;;   (let ((val (top (stack s)))
;;         (s1 (modify s
;;                     :call-stack (pop (call-stack s)))))
;;     (modify s1
;;             :stack (push val (stack s1)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Eg 1. Computing sq(x) = x^2.

(defconst *sq-state*
  (modify nil
          :pc 0
          :locals nil
          :stack nil
          :program '((load x)
                     (call sq)
                     (halt))
          :defs '((sq (n)
		      (load n)
		      (dup)
		      (mul)
		      (ret)))))

(run (modify *sq-state*
	     :locals (bind 'x 5 (locals *sq-state*)))
     5)

;; (((3                              ;; pc          Top frame   call-stack
;;    ((N . 5))                      ;; locals
;;    (25)                           ;; stack
;;    ((LOAD N) (DUP) (MUL) (RET)))  ;; program   
;;   (2                              ;; pc          A frame
;;    ((X . 5))                      ;; locals
;;      NIL                          ;; stack
;;      ((LOAD X) (CALL SQ) (HALT))));; program
;;  ((SQ (N) (LOAD N) (DUP) (MUL) (RET))))                      defs

(run (modify *sq-state*
	     :locals (bind 'x 5 (locals *sq-state*)))
     6)

;; (((2                            ;; pc        top frame   call-stack
;;    ((X . 5))                    ;; locals
;;    (25)                         ;; stack 
;;    ((LOAD X) (CALL SQ) (HALT))));; prgram
;;  ((SQ (N) (LOAD N) (DUP) (MUL) (RET))))                  defs
;; --------------------------------------------------------------

; Eg 2. Computing max(y x).

(defconst *max-state*
  (modify nil
          :pc 0
          :locals nil
          :stack nil
          :program '((load y)      ;; actual args. are put on stack
		     (load x)      ;; from left to right. In this
                     (call max)    ;; case, we compute max(y x).
                     (halt))
          :defs '((max (x y)
		       (load x)
		       (load y)
		       (sub)
		       (ifle 3)
		       (load x)
		       (ret)
		       (load y)
		       (ret)))))

(run (modify *max-state*
	     :locals (bind 'y 10 
			   (bind 'x 15 
				 (locals *max-state*))))
     8)

;; Note the values of x and y in the two frames:

;; (((7                   ;; pc        top frame    call-stack
;;    ((X . 10) (Y . 15)) ;; locals
;;    (15)                ;; stack
;;    ((LOAD X)           ;; program
;;     (LOAD Y)
;;     (SUB)
;;     (IFLE 3)
;;     (LOAD X)
;;     (RET)
;;     (LOAD Y)
;;     (RET)))
;;   (3                   ;; pc       a frame
;;    ((X . 15) (Y . 10)) ;; locals
;;    NIL                 ;; stack
;;    ((LOAD Y)           ;; program 
;;     (LOAD X) 
;;     (CALL MAX) 
;;     (HALT))))
;;  ((MAX (X Y)                                     defs
;;        (LOAD X)
;;        (LOAD Y)
;;        (SUB)
;;        (IFLE 3)
;;        (LOAD X)
;;        (RET)
;;        (LOAD Y)
;;        (RET))))

(run (modify *max-state*
	     :locals (bind 'y 10 
			   (bind 'x 15 
				 (locals *max-state*))))
     9)

(((3                   ;; pc        top frame    call-stack
   ((X . 15) (Y . 10)) ;; locals
   (15)                ;; stack
   ((LOAD Y)           ;; program
    (LOAD X) 
    (CALL MAX) 
    (HALT))))
 ((MAX (X Y)                                     defs
       (LOAD X)
       (LOAD Y)
       (SUB)
       (IFLE 3)
       (LOAD X)
       (RET)
       (LOAD Y)
       (RET))))
;; --------------------------------------------------------------

; Eg 3. Computing recursive factorial.

(defconst *fact-state*
  (modify nil
          :pc 0
          :locals nil
          :stack nil
          :program '((load x)
                     (call fact)
                     (halt))
          :defs '((fact (n)
                        (load n)
                        (ifgt 3)
                        (push 1)
                        (ret)
                        (load n)
                        (load n)
                        (push 1)
                        (sub)
                        (call fact)
                        (mul)
                        (ret)))))

(defun fact-clock (n)
  (if (zp n)
      4
      (+ 7 (fact-clock (- n 1)) 2)))

(defun run-fact (n)
  (top (stack
        (run (modify *fact-state*
                     :locals
                     (bind 'x n (locals *fact-state*)))
             (+ 2 (fact-clock n))))))

(fact-clock 5) ;; returns 49

(run-fact 5) ;; returns 120

;(run-fact 100) ;; may cause runtime error:

;; Error: Invocation history stack overflow.
;; Fast links are on: do (si::use-fast-links nil) for debugging
;; Error signalled by COND.
;; Broken at COND.  Type :H for Help.

; Prevent error by compiling
:comp t

(run-fact 100) ;; returns value below:

;; 9332621544394415268169923885626670049071596826438162146859296389521759999
;; 3229915608941463976156518286253697920827223758251185210916864000000000000
;; 000000000000
;; - - - - - - - -
(run (modify *fact-state*
	     :locals 
	     (bind 'x 5 (locals *fact-state*)))
     (+ 2 (fact-clock 5)))

;; (((2             ;; pc         top frame    call-stack
;;    ((X . 5))     ;; locals
;;    (120)         ;; stack
;;    ((LOAD X)     ;; program
;;     (CALL FACT) 
;;     (HALT))))
;;  ((FACT (N)                                 defs
;;         (LOAD N)
;;         (IFGT 3)
;;         (PUSH 1)
;;         (RET)
;;         (LOAD N)
;;         (LOAD N)
;;         (PUSH 1)
;;         (SUB)
;;         (CALL FACT)
;;         (MUL)
;;         (RET))))
;; - - - - - - - -
;; Call-stack with many frames produced by this.

(run (modify *fact-state*
	     :locals 
	     (bind 'x 5 (locals *fact-state*)))
     (fact-clock 4))

;; Note the value of the local variable N in each frame.

;; (((3             ;; pc         top frame    call-stack
;;    ((N . 0))     ;; locals
;;    (1)           ;; stack
;;    ((LOAD N)     ;; program
;;     (IFGT 3)
;;     (PUSH 1)
;;     (RET)
;;     (LOAD N)
;;     (LOAD N)
;;     (PUSH 1)
;;     (SUB)
;;     (CALL FACT)
;;     (MUL)
;;     (RET)))
;;   (9 
;;    ((N . 1))
;;    (1)
;;    ((LOAD N)
;;     (IFGT 3)
;;     (PUSH 1)
;;     (RET)
;;     (LOAD N)
;;     (LOAD N)
;;     (PUSH 1)
;;     (SUB)
;;     (CALL FACT)
;;     (MUL)
;;     (RET)))
;;   (9
;;    ((N . 2))
;;    (2)
;;    ((LOAD N)
;;     (IFGT 3)
;;     (PUSH 1)
;;     (RET)
;;     (LOAD N)
;;     (LOAD N)
;;     (PUSH 1)
;;     (SUB)
;;     (CALL FACT)
;;     (MUL)
;;     (RET)))
;;   (9
;;    ((N . 3))
;;    (3)
;;    ((LOAD N)
;;     (IFGT 3)
;;     (PUSH 1)
;;     (RET)
;;     (LOAD N)
;;     (LOAD N)
;;     (PUSH 1)
;;     (SUB)
;;     (CALL FACT)
;;     (MUL)
;;     (RET)))
;;   (9
;;    ((N . 4))
;;    (4)
;;    ((LOAD N)
;;     (IFGT 3)
;;     (PUSH 1)
;;     (RET)
;;     (LOAD N)
;;     (LOAD N)
;;     (PUSH 1)
;;     (SUB)
;;     (CALL FACT)
;;     (MUL)
;;     (RET)))
;;   (9
;;    ((N . 5))
;;    (5)
;;    ((LOAD N)
;;     (IFGT 3)
;;     (PUSH 1)
;;     (RET)
;;     (LOAD N)
;;     (LOAD N)
;;     (PUSH 1)
;;     (SUB)
;;     (CALL FACT)
;;     (MUL)
;;     (RET)))
;;   (2
;;    ((X . 5))
;;    NIL
;;    ((LOAD X)
;;     (CALL FACT)
;;     (HALT))))
;;  ((FACT (N)                                 defs
;;         (LOAD N)
;;         (IFGT 3)
;;         (PUSH 1)
;;         (RET)
;;         (LOAD N)
;;         (LOAD N)
;;         (PUSH 1)
;;         (SUB)
;;         (CALL FACT)
;;         (MUL)
;;         (RET))))