; Problem Set 4

; To do this problem set you should take your copy of m1-story.lisp and make a
; copy of everything from the top through the defun of compile.  Save that
; fragment of m1-story.lisp as problem-set-4-answers.lisp.  Then edit it to
; answer these two questions.  By the way, it is very common in software
; development that you are asked to take an existing system and modify it!


; Problem 4-1: Extend M1 so that it supports the IFNE instruction.  The
; semantics of (IFNE x) is that it adds x to the pc if the top of the stack is
; not equal to 0; otherwise control passes to the next instruction.  In any case,
; the topmost item on the stack is removed.

; Problem 4-2: Change the M1 compiler to support two new features:
; a new test, namely the equality of two integer-valued expressions,
; and an IF statement.  In particular the two syntactic changes
; are

; <test>         := ( <expr> > <expr>) | (<expr> = <expr>)

; <stmt>         := ( <var> = <expr> ) |
;                   ( while <test> <stmt*>) |
;                   ( if <test> ( <stmt*> )
;                               ( <stmt*> ) ) |
;                   ( return <expr> )

; where:

;  the semantics of the new <test>, ( <expr> = <expr> ), is that it is true if
;  the two <expr>s evaluate to the same integer and false otherwise.  You may
;  assume that all <expr>s evaluate to integers; and

;  the semantics of ( if <test> ( <stmt*> ) ( <stmt*> ) ) is that if <test>
;  evaluates to true the first sequence of statements is evaluated, otherwise
;  the second is evaluated.

; I strongly advise you to test your compiler, but that is not necessary for
; full credit.

; Obscure Hint: ACL2 will probably have trouble admitting your modified version
; of collect-vars-in-stmt*, collect-vars-in-stmt, stmt*! and stmt!.  That is
; because it doesn't know this simple fact:

; (defthm hack-lemma
;  (implies (car stmt)
;           (consp stmt)))

; I advise you to insert this lemma in your script just before the
; mutual-recursion event defining collect-vars-in-stmt*.

; Answers:

; In these answers I've stripped out unnecessary comments and just have the
; events that define M1 and the modified compiler.  The only comments below
; describe modifications to the corresponding fragment of m1-story.lisp.

(include-book "problem-set-1-answers")

(begin-book t :ttags :all)


(in-package "M1")

(defun next-inst (s)
  (nth (pc s) (program s)))

(defun execute-ICONST (inst s)
  (make-state (+ 1 (pc s))
              (locals s)
              (push (arg1 inst) (stack s))
              (program s)))

(defun execute-ILOAD (inst s)
  (make-state (+ 1 (pc s))
              (locals s)
              (push (nth (arg1 inst)
                         (locals s))
                    (stack s))
              (program s)))

(defun execute-IADD (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (+ (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-ISTORE (inst s)
  (make-state (+ 1 (pc s))
              (update-nth (arg1 inst) (top (stack s)) (locals s))
              (pop (stack s))
              (program s)))

(defun execute-ISUB (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (- (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-IMUL (inst s)
  (declare (ignore inst))
  (make-state (+ 1 (pc s))
              (locals s)
              (push (* (top (pop (stack s)))
                       (top (stack s)))
                    (pop (pop (stack s))))
              (program s)))

(defun execute-GOTO (inst s)
  (make-state (+ (arg1 inst) (pc s))
              (locals s)
              (stack s)
              (program s)))

(defun execute-IFLE (inst s)
  (make-state (if (<= (top (stack s)) 0)
                  (+ (arg1 inst) (pc s))
                (+ 1 (pc s)))
              (locals s)
              (pop (stack s))
              (program s)))

; Here is the new IFNE semantics:

(defun execute-IFNE (inst s)
  (make-state (if (equal (top (stack s)) 0)
                  (+ 1 (pc s))
                  (+ (arg1 inst) (pc s)))
              (locals s)
              (pop (stack s))
              (program s)))

; We have to include it in do-inst:

(defun do-inst (inst s)
  (if (equal (op-code inst) 'ICONST)
      (execute-ICONST  inst s)
    (if (equal (op-code inst) 'ILOAD)
        (execute-ILOAD  inst s)
      (if (equal (op-code inst) 'ISTORE)
          (execute-ISTORE  inst s)
        (if (equal (op-code inst) 'IADD)
            (execute-IADD   inst s)
          (if (equal (op-code inst) 'ISUB)
              (execute-ISUB   inst s)
            (if (equal (op-code inst) 'IMUL)
                (execute-IMUL   inst s)
              (if (equal (op-code inst) 'GOTO)
                  (execute-GOTO   inst s)
                (if (equal (op-code inst) 'IFLE)
                    (execute-IFLE   inst s)
                  (if (equal (op-code inst) 'IFNE)
                      (execute-IFNE   inst s)
                    s))))))))))

(defun step (s)
     (do-inst (next-inst s) s))

(defun run (sched s)
     (if (endp sched)
         s
       (run (cdr sched) (step s))))

; This concludes my solution to Problem 4-1.

; I will just delete the extraneous example of *ifact-program* and its testing.

; ===========================================================================

(defun collect-at-end (list e)
  (if (member e list)
      list
    (app list (cons e nil))))

(defthm nth-nil
  (equal (nth n nil) nil))

(defthm acl2-count-nth
  (implies (consp list)
           (< (acl2-count (nth n list))
              (acl2-count list)))
  :rule-classes :linear)

(defun collect-vars-in-expr (vars expr)
  (if (atom expr)
      (if (symbolp expr)
          (collect-at-end vars expr)
        vars)
    (collect-vars-in-expr
     (collect-vars-in-expr vars
                           (nth 0 expr))
     (nth 2 expr))))

; I have to add this silly lemma to establish termination of the next two
; function defuns.  The reason is that termination depends on the fact that
; (nth n stmt) is smaller than stmt if statement is known to be a consp.  But
; the defuns below do not test that stmt is a consp!  They test whether (nth 0
; stmt) is IF or WHILE or whatever.  So this lemma connects the dots: if you
; know (car stmt) is non-NIL then you know stmt is a consp [duh!].

(defthm hack-lemma
  (implies (car stmt)
           (consp stmt)))

(mutual-recursion

(defun collect-vars-in-stmt* (vars stmt-list)
  (if (endp stmt-list)
      vars
    (collect-vars-in-stmt*
     (collect-vars-in-stmt vars (car stmt-list))
     (cdr stmt-list))))

(defun collect-vars-in-stmt (vars stmt)
  (if (equal (nth 1 stmt) '=)
      (collect-vars-in-expr
       (collect-at-end vars (nth 0 stmt))
       (nth 2 stmt))
    (if (equal (nth 0 stmt) 'WHILE)
        (collect-vars-in-stmt*
         (collect-vars-in-expr vars (nth 1 stmt))
         (cdr (cdr stmt)))

; This is the obvious way to collect vars in an IF expression.

      (if (equal (nth 0 stmt) 'IF)
          (collect-vars-in-stmt*
           (collect-vars-in-stmt*
            (collect-vars-in-expr vars (nth 1 stmt))
            (nth 2 stmt))
           (nth 3 stmt))
        (if (equal (nth 0 stmt) 'RETURN)
            (collect-vars-in-expr vars (nth 1 stmt))
          vars)))))
)

(defun OP! (op)
  (if (equal op '+)
      '((IADD))
    (if (equal op '-)
        '((ISUB))
      (if (equal op '*)
          '((IMUL))
        '((ILLEGAL))))))

(defun ILOAD! (vars var)
  (cons (cons 'ILOAD (cons (index var vars) nil))
        nil))

(defun ICONST! (n)
  (cons (cons 'ICONST (cons n nil))
        nil))

(defun expr! (vars expr)
  (if (atom expr)
      (if (symbolp expr)
          (ILOAD! vars expr)
        (ICONST! expr))
    (app (expr! vars (nth 0 expr))
         (app (expr! vars (nth 2 expr))
              (OP! (nth 1 expr))))))

(defun IFLE! (offset)
  (cons (cons 'IFLE (cons offset nil))
        nil))

; The new code generator for IFNE instructions.

(defun IFNE! (offset)
  (cons (cons 'IFNE (cons offset nil))
        nil))

(defun GOTO! (offset)
  (cons (cons 'GOTO (cons offset nil))
        nil))

; I'll add a flag to while! so that it knows whether it is compiling
; a (while (x > y) ...) or a (while (x = y) ...).

(defun while! (ifle-flg test-code body-code)
  (app test-code
       (app (if ifle-flg
                (IFLE! (+ 2 (len body-code)))
              (IFNE! (+ 2 (len body-code))))
            (app body-code
                 (GOTO! (- (+ (len test-code)
                              1
                              (len body-code))))))))

; Here is the code generator for if statements:

(defun if! (ifle-flg test-code true-code false-code)
  (app test-code
       (app (if ifle-flg
                (IFLE! (+ 2 (len true-code)))
              (IFNE! (+ 2 (len true-code))))
            (app true-code
                 (app (GOTO! (+ 1 (len false-code)))
                      false-code)))))

; Here is the new function for compiling a test:

(defun test! (vars test)

; Test has to be of the form (x > y) or (x = y), where x and y are expressions.
; if the operator is > we don't change the generated code.

  (if (equal (nth 1 test) '>)
      (if (equal (nth 2 test) 0)
          (expr! vars (nth 0 test))
        (app (expr! vars (nth 0 test))
             (app (expr! vars (nth 2 test))
                  '((ISUB)))))

; If the operator is =, we put their difference on the stack.

    (if (equal (nth 1 test) '=)
        (app (expr! vars (nth 0 test))
             (app (expr! vars (nth 2 test))
                  '((ISUB))))
      '((ILLEGAL)))))

(defun ISTORE! (vars var)
  (cons (cons 'ISTORE (cons (index var vars) nil))
        nil))

(mutual-recursion

 (defun stmt*! (vars stmt-list)
   (if (endp stmt-list)
       nil
     (app (stmt! vars (car stmt-list))
          (stmt*! vars (cdr stmt-list)))))

 (defun stmt! (vars stmt)
   (if (equal (nth 1 stmt) '=)
       (app (expr! vars (nth 2 stmt))
            (ISTORE! vars (nth 0 stmt)))
     (if (equal (nth 0 stmt) 'WHILE)
         (while!

; Here is the new flag for while! that tells it whether to lay down an IFLE
; or an IFNE:

          (if (equal (nth 1 (nth 1 stmt)) '>)
              t
            nil)
          (test! vars (nth 1 stmt))
          (stmt*! vars (cdr (cdr stmt))))

; Here is the handling of the new IF statement.

       (if (equal (nth 0 stmt) 'IF)
           (if! (if (equal (nth 1 (nth 1 stmt)) '>)
                    t
                  nil)
                (test! vars (nth 1 stmt))
                (stmt*! vars (nth 2 stmt))
                (stmt*! vars (nth 3 stmt)))
         (if (equal (nth 0 stmt) 'RETURN)
             (app (expr! vars (nth 1 stmt))
                  '((HALT)))
           '((ILLEGAL)))))))
 )

(defun compile (formals stmt-list)
  (stmt*! (collect-vars-in-stmt* formals stmt-list)
          stmt-list))

; Here is a test program.  It is a version of the program we wrote in
; class that determines whether a natural number i is even or odd by
; returning a 1 or 0 on top of the stack.

(defconst *even-program*
  (compile '(i)
           '((while (i > 1) (i = (i - 2)))
             (if (i = 0)
                 ( (return 1) )
                 ( (return 0) )))))

; The only way I can write this schedule function is to
; look at the compiled code generated for the *even-program*.

(defun even-sched (i)
  (if (zp i)
      (repeat 0 10)
    (if (equal i 1)
        (repeat 0 10)
      (app (repeat 0 9)
           (even-sched (- i 2))))))

(defun test-even (i)
  (top 
    (stack 
     (run (even-sched i)
          (make-state 0
                      (list i)
                      nil
                      *even-program*)))))

(defthm even-examples
  (and (equal (test-even 4) 1)
       (equal (test-even 5) 0)
       (equal (test-even 17) 0)
       (equal (test-even 246) 1))
  :rule-classes nil)