#|$ACL2s-Preamble$;

(include-book "m5")
(begin-book t :ttags :all)

;$ACL2s-Preamble$|#


(in-package "M5")

; The goal of this book is the function diff, which takes two M5
; states, the first one being named var, and creates an ACL2 term in
; var that evaluates to the second M5 state.  The two states are
; supposed to be closely related, e.g., both have the same class
; table.

; Suppose (diff var s1 s2) evaluates to an expression, expr.  Then if
; var is bound to s1, expr evaluates to s2.

; For example, if *rfact-state* is a state poised to evaluate rfact
; (factorial) on 5, then

; (diff '*rfact-state*
;       *rfact-state*
;       (run (repeat 0 51) *rfact-state*))

; is

; (MODIFY 0 *RFACT-STATE*
;         :PC 2
;         :STK '(120)
;         :NEXT-INSTR '(HALT))

; In general, the result is of the form

;     (let ((tmp1 (modify <th1> s      <all changes to th1>))
;           (tmp2 (modify <th2> tmp1   <all changes to th2>))
;           ...
;           (tmpk (modify <thk> tmpk-1 <all changes to thk>)))
;       (modify nil tmpk
;               :hp (.... (hp s))))

; So much for preliminaries...

; WARNING: We assume that the first state, s1, is a well formed
; M5 state and that the second state is produced from it by a
; RUN!  In addition, since this utility basically inverts the
; MODIFY macro -- and then some -- we assume everything about
; MODIFY.  We use EVERYTHING we know about the shape of M5
; states, how keytuples are represented and accessed, and how
; MODIFY works, and how RUN works.  For example, :ids in the tt
; are numbered consecutively starting at 0 and hp addresses are
; consecutive REFs!  I suspect RUN would work just as well if
; :ids were symbols or listed in a different order, but RUN does
; it this way and we know it!  Also, we know the ct of s1 is that
; of s2, since RUN doesn't do dynamic class loading.  We know the
; hp of s2 is an extension of s1, since RUN doesn't garbage
; collect.

; For reference:
; (defkeytuple state (tt hp ct))
; (defkeytuple thread (id cs stat ref))
; (defkeytuple frame (pc locs stk mloc))
; (defkeytuple class (name supers fields methods))
; (defkeytuple method (name formals sync code xtbl))

; Our diff utility is only guaranteed to work on well-formed M5 states.

(defun same-refs (tt1 tt2)

; Tt1 and tt2 are tts and tt2 is at least as long as tt1.
; We check that the ref of each thread in tt1 is the
; same as the thread-ref of the corresponding thread in tt2.
; refs should never change!

  (cond ((endp tt1) t)
        ((equal (ref (car tt1))
                (ref (car tt2)))
         (same-refs (cdr tt1) (cdr tt2)))
        (t nil)))

(defun next-inst1 (pc mloc ct)
  (nth pc
       (code
        (get-method mloc
                    ct))))

(defun kwote (x)
  (if (or (acl2-numberp x)
          (equal x t)
          (equal x nil)
          (stringp x)
          (characterp x)
          (keywordp x))
      x
    (list 'quote x)))

(defun make-frame-modification (frame1 frame2 ct)
  (append
   (if (equal (pc frame1) (pc frame2))
       nil
     (list :pc (pc frame2)))
   (append
    (if (equal (locs frame1) (locs frame2))
        nil
      (list :locs (kwote (locs frame2))))
    (append
     (if (equal (stk frame1) (stk frame2))
         nil
       (list :stk (kwote (stk frame2))))
     (append
      (list :next-inst
            (kwote (next-inst1 (pc frame2)
                               (mloc frame2)
                               ct)))
      (if (equal (mloc frame1) (mloc frame2))
          nil
        (list :mloc (kwote (mloc frame2)))))))))

; ``Rcs'' stands for ``reversed call stk''.  See the example below.

(defun len-common-part (rcs1 rcs2)
  (cond ((endp rcs1) 0)
        ((endp rcs2) 0)
        ((equal (car rcs1) (car rcs2))
         (+ 1 (len-common-part (cdr rcs1) (cdr rcs2))))
        (t 0)))

(defun firstn (n lst)
  (if (zp n)
      nil
    (cons (car lst)
          (firstn (- n 1) (cdr lst)))))

; So
; cs1 = (e d c b a)
; cs2 = (w x y z c b a)

; Then len-common-part (on the rev of the csi) is 3 and so k is (-
; (len cs1) 3) = 2.  We we have to make frame descriptors for (firstn
; (- (len cs2) 3) cs2).

(defun make-cs-modification (new-frames var ct)
  (cond ((endp new-frames) var)
        (t (list 'push
                 (list 'make 'frame
                       :pc (pc (car new-frames))
                       :locs (kwote (locs (car new-frames)))
                       :stk (kwote (stk (car new-frames)))
                       :next-inst
                       (kwote (next-inst1 (pc (car new-frames))
                                          (mloc
                                           (car new-frames))
                                          ct))
                       :mloc
                       (kwote (mloc (car new-frames))))
                 (make-cs-modification (cdr new-frames)
                                               var
                                               ct
                                               )))))
(defun cs-diffs (var cs1 cs2 ct)
  (cond
   ((equal cs1 cs2) nil)
   ((and (consp cs1)
         (consp cs2)
         (equal (cdr cs1) (cdr cs2)))
    (make-frame-modification (car cs1) (car cs2) ct))
   (t (let* ((n (len-common-part (rev cs1) (rev cs2)))
             (k (- (len cs1) n)))
        (list :cs
              (make-cs-modification
               (firstn (- (len cs2) n) cs2)
               (if (zp n)

; If n is 0, then k is (len cs1), so (popn k cs1) is nil.

                   nil
                 (if (zp k)
                     var
                   (if (equal k 1)
                       (list 'pop var)
                     (list 'popn k var))))
               ct))))))

(defun stat-diffs (stat1 stat2)
  (cond ((equal stat1 stat2) nil)
        (t (list :stat (kwote stat2)))))

(defun ref-diffs (ref1 ref2)
  (cond ((equal ref1 ref2) nil)
        (t (list :ref (kwote ref2)))))

(defun state-var (i)

; For natural i, we generate the symbol M5::TMPi.

  (intern-in-package-of-symbol (coerce
                                (append '(#\T #\M #\P)
                                        (explode-atom i 10))
                                'string)
                               'm5::run))

(defun tt-diffs (var i tt1 tt2 ct)
  
; Var is the state variable that contains the thread table tt1 and
; i is the number of the first thread in tt2.

; Example:  Suppose
; var: TMP7
; i:   45
; tt1: ((cst0 stat0 ref0) (cst1 stat1 ref1))
; tt2: ((xx0 stat0 ref0) (cst1 stat1 ref1) (xx2 yy2 zz2))

; Then we return
; ((45 :cs (push ... (call-stk 45 TMP7)))
;  (47 :cs ... :thread-stat ...))

; Except! Instead of calling call-stk we use the modify abbreviation
; -cs-.  The call-stk expression could be generated by (list
; 'call-stk i var).  But because we don't generate that expression,
; var is an irrelevant formal.  Thus, we declare it ignored
; and pass nil instead of var into our recursive calls.

; If the css are appropriately related we might just return an
; item like (0 :pc ... :stk ...).

  (declare (ignore var)
           (xargs :measure (acl2-count tt2)))
  (cond ((endp tt2) nil)
        ((equal (car tt1) (car tt2))
         (tt-diffs nil ; var
                             (+ 1 i) (cdr tt1) (cdr tt2) ct))
        (t (cons
            (cons i  
                  (append
                   (cs-diffs

; Note:  If tt2 is non-nil but tt1 is nil, then we're dealing with
; a thread that doesn't exist in tt1.  So instead of writing
; -cs- we call it like it is: nil.

                    (if (null tt1) nil '-cs-)
                    (cs (car tt1))
                    (cs (car tt2))
                    ct)
                   (append
                    (stat-diffs (stat (car tt1))
                                (stat (car tt2)))
                    (ref-diffs (ref (car tt1))
                               (ref (car tt2))))))
            (tt-diffs (state-var i) (+ i 1) (cdr tt1) (cdr tt2)
                                ct)))))

(defun ok-hp-keys (i hp)
  (declare (xargs :measure (acl2-count hp)))
  (cond ((endp hp) (equal hp nil))
        ((and (consp (car hp))
              (equal (car (car hp)) (list 'REF i)))
         (ok-hp-keys (+ 1 i) (cdr hp)))
        (t nil)))

(defun hp-diffs (hp1 hp2)

; Example:  Suppose 
; hp1: '(((REF 0)  o0)((REF 1)  o1)((REF 2)  o2))
; hp2: '(((REF 0)  o0)((REF 1)  x1)((REF 2)  o2)((REF 3)  x3))

; Then we return ; '(((REF 1)  x1) ((REF 3)  x3))

; We know that hp2 is at least as long as hp1 and that both have
; ok keys counting sequentially up from 0.

  (declare (xargs :measure (acl2-count hp2)))
  (cond ((endp hp2) nil)
        ((equal (car hp1) (car hp2))
         (hp-diffs (cdr hp1) (cdr hp2)))
        (t (cons (car hp2)
                 (hp-diffs (cdr hp1) (cdr hp2))))))

; This is the function we'll use to put the changed values back into
; the hp.

(defun bind* (alist1 alist2)
  (if (endp alist1)
      alist2
    (bind* (cdr alist1)
           (bind (car (car alist1))
                 (cadr (car alist1))
                 alist2))))

(defun make-bind* (lst var)
  (cond ((null var) (kwote lst))
        ((endp lst) var)
        (t (list 'bind*
                 (kwote lst)
                 var))))
                 
;     (let ((temp1 (modify <th1> s     <all changes to th1>))
;           (temp2 (modify <th2> temp1 <all changes to th2>))
;           ...
;           (tempk (modify <thk> tempk-1 <all changes to thk>)))
;       (modify nil tempk
;               :hp (.... (hp s))))

(defun make-successive-modifies (var tt-diffs)
  (cond ((endp tt-diffs) nil)
        (t (cons (list (state-var (car (car tt-diffs)))
                       (list* 'modify
                              (car (car tt-diffs))
                              var
                              (cdr (car tt-diffs))))
                 (make-successive-modifies
                  (state-var (car (car tt-diffs)))
                  (cdr tt-diffs))))))

; So when this finishes I might have

; ((s1 (modify 1 s ...))
;  (s2 (modify 2 s1 ...))
;  (s3 (modify 3 s2 ...)))

(defun diff (var s1 s2)

; Var is a term and s1 and s2 are well-formed M5 states and s2 was
; produced by running s1.  Suppose var evaluates to s1.  We compute a
; MODIFY of var that evaluates to s2.

; Some of the checks below are unnecessary, given our assumptions.
; But I make them to increase the safety of this function.  I ought
; to make others.

  (cond
   ((and (true-listp s1)
         (equal (len s1) 4)
         (equal (car s1) 'state)
         (true-listp s2)
         (equal (len s2) 4)
         (equal (car s2) 'state)
         (<= (len (tt s1)) (len (tt s2)))
         (same-refs (tt s1)
                                  (tt s2))
         (ok-hp-keys 0 (hp s1))
         (ok-hp-keys 0 (hp s2))
         (<= (len (hp s1)) (len (hp s2)))
         (equal (ct s1)
                (ct s2)))
    (let* ((tt-diffs (tt-diffs var
                                         0
                                         (tt s1)
                                         (tt s2)
                                         (ct s2)))
           (bindings (make-successive-modifies var tt-diffs))
           (hp-diffs (hp-diffs (hp s1) (hp s2)))
           (hp-var (cond ((subsetp (strip-cars (hp s1))
                                     (strip-cars hp-diffs))
                            nil)
                           (t '-hp-))))
      (cond
       ((null hp-diffs)
        (cond ((endp bindings)
               var)
              ((endp (cdr bindings))
               (car (cdr (car bindings))))
              (t (list 'let*
                       (firstn (- (len bindings) 1) bindings)
                       (car (cdr (car (last bindings))))))))
       ((endp bindings)
        (list 'modify nil var
                      :hp
                      (make-bind* hp-diffs hp-var)))
       ((endp (cdr bindings))
        (append (car (cdr (car bindings)))
                (list :hp
                      (make-bind* hp-diffs hp-var))))
       (t (list 'let*
                bindings
                (list 'modify nil (car (car (last bindings)))
                      :hp
                      (make-bind* hp-diffs hp-var)))))))
   (t :unrelated)))