; I changed modify and semantics from earlier in the semester, making the -abbrevs- IGNORABLE. ;(include-book "keytuples") ;(certify-book "m5" 1) (in-package "M5") ; States ; To understand this, you should read the Discussion in keytuples.lisp. ; Here are the keytuples involved in the representation of states. I use short ; field names so we won't have to write so much in class. (defkeytuple state (:tt :hp :ct)) (defkeytuple thread (:id :cs :stat :ref)) (defkeytuple frame (:pc :locs :stk :mloc) :allow-but-ignore (:next-inst)) (defkeytuple class (:name :supers :fields :methods)) (defkeytuple method (:name :formals :sync :code :xtbl)) ; To build a state with :tt x, :hp y, and :ct z, you can use any of these ; constructs: ; (state x y z) -- positional ; (make state :hp y :tt x :ct z) -- by key, order unimportant ; To access the tt of a state s you may use either: ; (tt s) ; (get :tt s) ; These comments about states and their components generalize to all keytuples ; and their components. So to access the :methods slot of a class, c, you may ; use (class c) or (get :class c). To make a class you may use the positional ; notation (class nm sc fd mt) or the keyword notation (make class :name nm ...). ; If you have a list of keytuples of the same type, clst, e.g., a list of ; classes, you can find the first one with a given key value with find, as in ; (find :name "Math" clst). ; Here is the shape of a state and a brief explanation of how each component of ; each keytuple is used. #| (make STATE :TT (list ... ; thread table (list of threads) (make THREAD ; thread :ID id ; thread identifier (natp) :CS (list ... ; call stack (stack of frames) (make FRAME ; frame :PC pc ; program counter (natp) :LOCS locs ; local variable values :STK stk ; operand stack :MLOC mloc) ; method locator ...) :STAT stat ; status (ACTIVE or INACTIVE) :REF ref) ; ref to "Thread" Object in heap ...) :HP hp ; heap (binding environment mapping ; addresses to Objects) :CT (list ; class table (list of classes) ... (make CLASS ; class :NAME name ; name (string) :SUPERS supers ; proper superclasses (list of strs) :FIELDS fields ; fields (list of strings) :METHODS (list ; methods (list of method objects) ... (make METHOD ; method :NAME name ; name (string) :FORMALS formals ; formals (list of symbols) :SYNC sync ; synchronized flag (boolean) :CODE code ; code (list of instructions) :XTBL xtbl) ; exception table ...)) ...)) |# ; ----------------------------------------------------------------- ; Threads ; The :TT (``thread table'') component of a state is a list of thread ; keytuples. Every thread has a :CS (``call stack''), which is a stack (list) ; of frame keytuples. The topmost frame in a thread's call stack is called its ; ``top frame'' and is the frame of the most recently invoked method. The ; frame immediately below it invoked that one, etc. ; Questions: ; In the following you may assume that id is a thread identifier for some ; thread in the thread table of state s. Define cst and top-frame as ; described below: ; (cst id s) -- return the call stack of the indicated thread. ; (top-frame id s) -- return the top frame of the indicated thread. ; Answers: (defun cst (id s) (cs (find :id id (tt s)))) (defun top-frame (id s) (top (cst id s))) ; ----------------------------------------------------------------- ; Objects ; Every class keytuple in the class table contains the name of the class ; (:NAME), the list of the names of the proper super classes (:SUPERS), and the ; list of immediate field names (:FIELDS). All these names are strings. ; The super classes are listed in order, from most specific to least; thus, ; "Object" is always the last element of every :SUPERS except one. ; Question: ; Which class is the exception just mentioned? ; Answer: ; The class defining "Object". ; Java Objects are represented as doubly nested binding environments. At the ; top level, each successive class name in the superclass hierarchy is bound to ; a binding environment which specifies the values for the immediate fields of ; the corresponding class. For example, suppose class "Beta" extends "Alpha" ; which extends "Object". Suppose the fields of "Beta", "Alpha" and "Object" ; are, respectively, "b1", ..., "bb", "a1", ..., "aa", and "o1", ..., "oo". ; Then the representation of an instance of an Object of class "Beta" is: ; (("Beta" (("b1" vb1) ... ("bb" vbb))) ; immediate data for "Beta" ; ("Alpha" (("a1" va1) ... ("aa" vaa))) ; immediate data for "Alpha" ; ("Object" (("o1" vo1) ... ("oo" voo)))) ; immediate data for "Object" ; The vxx are the values of the corresponding fields. ; Questions: ; Define the following functions. In the following, you may assume that ; class-name is a class name in the class table ct and that field-name is the ; name of one of the immediate fields of class-name. In addition, obj is the ; representation of a Java object as above. ; (super-classes class-name ct) - return the super-class chain of class-name, ; starting with class-name and ending with "Object". ; (new-object class-name ct) - build an Object of class class-name. All fields ; should be (un-)initialized to 0. ; (instanceofp obj class-name) - return t or nil to indicate whether ; obj is an instance of class-name. ; (getf class-name field-name obj) - return the value of the immediate field ; field-name of class-name in obj. You may assume obj is an instance of ; class-name. ; (putf class-name field-name value obj) - "modify" obj so that the immediate ; field field-name of class-name in obj has value value. You may assume ; obj is an instance of class-name. Of course, you cannot actually modify ; obj. Technically, you should return a new object with the same ; superclass chain as obj in which all the fields are set as in obj except ; for the immediate field field-name of class-name, which should be set to ; value. ; (extendsp class-name1 class-name2 ct) - return t or nil to indicate whether ; class-name1 extends class-name2. Both may be assumed to be class names ; in ct. (defun super-classes (class-name ct) (cons class-name (supers (find :name class-name ct)))) (defun new-object-immediate (class-name ct) (list class-name (bind-all (fields (find :name class-name ct)) 0))) (defun new-object1 (class-names ct) (if (endp class-names) nil (cons (new-object-immediate (car class-names) ct) (new-object1 (cdr class-names) ct)))) (defun new-object (class-name ct) (new-object1 (super-classes class-name ct) ct)) (defun getf (class-name field-name obj) (binding field-name (binding class-name obj))) (defun putf (class-name field-name value obj) (bind class-name (bind field-name value (binding class-name obj)) obj)) (defun instanceofp (obj class-name) (boundp class-name obj)) (defun extendsp (class-name1 class-name2 ct) (member class-name2 (super-classes class-name1 ct))) ; ----------------------------------------------------------------- ; References and the Heap ; The heap is a binding environment that binds references to objects. A ; ``reference'' is a list of the form (REF i), where i is a natural number. ; Notice that this reliance on natural numbers induces the notion of one ; reference being the (unique) successor of another, e.g., (REF 1) is the ; successor of (REF 0). In a well-formed heap, the first binding is of (REF 0) ; and each successive binding is of the successive reference. ; Questions: ; Suppose hp is a well-formed heap and obj is an object. Define the following ; functions: ; (new-ref hp) - return the next available reference, i.e., the smallest ; reference not bound in hp. ; (deref ref hp) - return the object associated with ref in hp. ; (put-heap ref obj hp) - return a new heap, hp', that is like hp except that ; ref is bound in hp' to obj. Be sure hp' is well-formed. ; (class-name-of-ref ref hp) - return the most specific class name of which ; obj is an instance, where obj is the result of dereferencing ref in hp. ; Answers: (defun new-ref (hp) (list 'REF (len hp))) (defun deref (ref hp) (binding ref hp)) (defun class-name-of-ref (ref hp) (car (car (deref ref hp)))) ; Every object is an instance of the "Object" class. The "Object" class has ; two special fields, "mcount" and "monitor". Both fields always contain ; natural numbers. An object, obj, is ``locked'' if the immediate field "mcount" ; of "Object" in obj is non-zero. When an object is locked, its "monitor" ; field is set to the thread identifier of the thread that locked it (sometimes ; called the object's ``owner''). ; An object is ``lockable'' by a thread identifier id if either the object is not ; locked or owned by id. To ``lock'' a lockable object, the "mcount" field is ; incremented and the "monitor" field is set to the id of the thread. ; An object is ``unlockable'' by a thread identifier id if either the object is ; not locked or is owned by id. To ``unlock'' an unlockable object, the "mcount" ; field is decremented (if non-0) and the "monitor" field is set to the owner. ; Define the following functions. You may assume id is the identifier of a ; thread and ref is a reference to an object in the well-formed heap hp. ; (lockablep id ref hp) - return t or nil indicating whether the object ; indicated by ref may be locked by thread id. ; (lock id ref hp) - assuming the object indicated by ref is lockable by id, ; lock it. ; (unlockable id ref hp) - return t or nil indicating whether the object ; indicated by ref may be unlocked by thread it. ; (unlock id ref hp) - assume the object indicated by ref is unlockable by id, ; unlock it. ; Answers: (defun lockablep (id ref hp) (let ((obj (deref ref hp))) (or (zp (getf "Object" "mcount" obj)) (equal (getf "Object" "monitor" obj) id)))) (defun lock (id ref hp) (let* ((obj (deref ref hp)) (new-mcount (+ 1 (getf "Object" "mcount" obj))) (new-object (putf "Object" "monitor" id (putf "Object" "mcount" new-mcount obj)))) (bind ref new-object hp))) (defun unlockablep (id ref hp) (let ((obj (deref ref hp))) (or (zp (getf "Object" "mcount" obj)) (equal (getf "Object" "monitor" obj) id)))) (defun unlock (id ref hp) (let* ((obj (deref ref hp)) (old-mcount (getf "Object" "mcount" obj)) (new-mcount (if (zp old-mcount) 0 (- old-mcount 1))) (new-monitor (if (zp new-mcount) 0 id)) (new-object (putf "Object" "monitor" new-monitor (putf "Object" "mcount" new-mcount obj)))) (bind ref new-object hp))) ; ----------------------------------------------------------------- ; Method Locators and Method Resolution ; A ``method locator'' is of the form (class-name method-name i), where i is ; the natural number position of the method whose :NAME is method-name in the ; :methods of a class named class-name. A method locator thus identifies a ; particular method keytuple in a class. ``Method resolution'' is the process ; of mapping from a method name to a method locator (and is done with respect ; to a given class name). Resolution consists of scanning up the super-class ; chain of the given class name to find the first method with the given method ; name. [In Java, resolution is also sensitive to the signature of the ; method.] ; Questions: ; Assume that class-name is a class name in a well-formed class table ct. ; Define: ; (resolve-method-name method-name class-name ct) - resolve method-name with ; respect to the given class-name) and return the resulting method locator ; or nil if no such method exists. ; (get-method locator ct) - return the method keytuple indicated by the method ; locator locator in class table ct. Return nil if no such method exists. ; (synchronized-methodp locator ct) - return t if the :sync field of the indicated ; method is t; otherwise, nil. ; Answers: (defun method-index (method-name methods) (index (find :name method-name methods) methods)) (defun method-locator (method-name classes ct) (cond ((endp classes) nil) (t (let* ((class-name (car classes)) (class (find :name class-name ct)) (method (find :name method-name (methods class)))) (if method (list (car classes) method-name (method-index method-name (methods class))) (method-locator method-name (cdr classes) ct)))))) (defun resolve-method-name (method-name class-name ct) (method-locator method-name (super-classes class-name ct) ct)) (defun get-method (locator ct) (let ((class (nth 0 locator)) (i (nth 2 locator))) (nth i (methods (find :name class ct))))) (defun synchronized-methodp (locator ct) (sync (get-method locator ct))) ; Built In Classes ; Here are the ``base classes'' which we assume every class table will contain. (defconst *base-classes* (list (make class :name "Object" :supers nil :fields '("monitor" "mcount" "wait-set") :methods nil) (make class :name "Thread" :supers '("Object") :fields nil :methods (list (make method :name "run" :formals () :sync nil :code '((return)) :xtbl nil) ; The next two methods are recognized as native and their codes ; are irrelevant. (make method :name "start" :formals () :sync nil :code nil :xtbl nil) (make method :name "stop" :formals () :sync nil :code nil :xtbl nil))))) ; This function will be used to extend user-supplied classes to include ; the base classes. (defun make-ct (classes) (append *base-classes* classes)) ; Question: ; A method is ``native'' if it is the "start" method of class "Thread" or the ; "stop" method of class "Thread". [In Java, there are many other native ; methods; "stop" has been deprecated.] ; Define ; (native-methodp locator) - return t if locator is the method locator of a ; native method; otherwise, nil. ; Answer: (defun native-methodp (locator) (or (equal locator '("Thread" "start" 1)) (equal locator '("Thread" "stop" 2)))) ; ----------------------------------------------------------------- ; The MODIFY macro ; Our modify macro will allow us to use certain standard abbreviations for ; various components of the state. For example, -stk- will abbreviate the ; stack of the ``current'' thread. What does that really mean? Given a thread ; identifier, id, and a state, -stk- means the :STK component of the top-most ; frame of the call-stack of thread id in s. Formally, -stk- means (stk ; (top-frame id s)). ; Suppose id and s denote expressions that eval to a thread id and an ; M5 state. We construct an alist that specifies the meanings of all ; the supported abbreviations. (defun -standard-abbrevs- (id s) `((-thread- (find :id ,id (tt ,s))) (-pc- (pc (top-frame ,id ,s))) (-locs- (locs (top-frame ,id ,s))) (-stk- (stk (top-frame ,id ,s))) (-mloc- (mloc (top-frame ,id ,s))) (-cs- (cst ,id ,s)) (-hp- (hp ,s)) (-ct- (ct ,s)))) ; This function constructs a STATE expression given a bunch of ``optional'' ; arguments. Aside from id and s, each pair of arguments below is a flag and a ; value. The flag indicates whether the user supplied a value for this ; argument or not. If so, the value is the one supplied by the user; if not, ; the value is nil. ; We create a STATE that builds the new state by using the supplied components ; and filling in with the corresponding components of id and s. The STATE ; expression uses the variables, -pc-, -locs-, etc., freely, as though they ; were bound to the corresponding components of thread id in s. We will so ; bind them in the context in which we use this function. ; Note that in the absence of a supplied value, the pc of the new state will be ; one greater than the pc of s. The user may, of course, supply an explicit pc ; expression. To hold the pc constant while changing other components of the ; state, we supply :NO-CHANGE for the :PC. We could, of course, have supplied ; the expression '-pc-. (defun make-state-expr (id s pc-suppliedp pc locs-suppliedp locs stk-suppliedp stk mloc-suppliedp mloc cs-suppliedp cs stat-suppliedp stat ref-suppliedp ref hp-suppliedp hp ct-suppliedp ct) `(state ,(cond ((or cs-suppliedp pc-suppliedp locs-suppliedp stk-suppliedp mloc-suppliedp stat-suppliedp ref-suppliedp) `(replace :id ,id (thread ,id ,(cond (cs-suppliedp cs) ((or pc-suppliedp locs-suppliedp stk-suppliedp mloc-suppliedp) `(push (frame ,(if pc-suppliedp (if (equal pc :no-change) '-pc- pc) `(+ 1 -pc-)) ,(if locs-suppliedp locs '-locs-) ,(if stk-suppliedp stk '-stk-) ,(if mloc-suppliedp mloc '-mloc-)) (pop -cs-))) (t '-cs-)) ,(if stat-suppliedp stat '(stat -thread-)) ,(if ref-suppliedp ref '(ref -thread-))) (tt ,s))) (t `(tt ,s))) ,(if hp-suppliedp hp '-hp-) ,(if ct-suppliedp ct '-ct-))) ; Here is the modify macro. It takes the indicated optional keyword arguments. ; It returns an expression that binds the standard abbreviations, e.g., -pc-, ; to the appropriate values and then returns the make-state-expr constructed ; above. (defmacro modify (id s &key (pc 'nil pc-suppliedp) (locs 'nil locs-suppliedp) (stk 'nil stk-suppliedp) (mloc 'nil mloc-suppliedp) (cs 'nil cs-suppliedp) (stat 'nil stat-suppliedp) (ref 'nil ref-suppliedp) (hp 'nil hp-suppliedp) (ct 'nil ct-suppliedp) ; This is allowed-but-ignored by modify. next-inst) (declare (ignore next-inst)) (let ((bindings (-standard-abbrevs- id s))) `(let ,bindings (declare (ignorable ,@(strip-cars bindings))) ,(make-state-expr id s pc-suppliedp pc locs-suppliedp locs stk-suppliedp stk mloc-suppliedp mloc cs-suppliedp cs stat-suppliedp stat ref-suppliedp ref hp-suppliedp hp ct-suppliedp ct)))) ; ----------------------------------------------------------------- ; Defsem -- Defining Semantic Functions. ; This macro allows us to write ; (defsem (OPCODE a b c) ; body) ; to mean ; (define execute-opcode (inst id s) ; (let ((a (arg1 inst)) ; (b (arg2 inst)) ; (c (arg3 inst)) ; (-pc- (pc (top-frame id s))) ; ...) ; body)) (defmacro semantics (inst body) (cond ((and (true-listp inst) (symbol-listp inst) (<= 1 (len inst)) (<= (len inst) 4) (no-duplicatesp inst)) (let ((lst1 (bind-all (cdr inst) '((arg1 inst) (arg2 inst) (arg3 inst)))) (lst2 (-standard-abbrevs- 'id 's))) (cond ((and (endp lst1) (endp lst2)) body) (t `(let ,(append lst1 lst2) (declare (ignorable ,@(strip-cars (append lst1 lst2)))) ,body))))) (t (er hard 'semantics "The inst in SEMANTICS must be a non-empty ~ true-list of no more than four distinct symbols.")))) (defmacro defsem (pattern &rest args) (cond ((and (true-listp pattern) (symbol-listp pattern) (<= 1 (len pattern)) (<= (len pattern) 4) (no-duplicatesp pattern)) `(defun ,(concat-atoms (list 'execute- (car pattern))) (inst id s) ,@(if (equal (len pattern) 1) '((declare (ignore inst))) nil) ,@(take (- (len args) 1) args) (semantics ,pattern ,(car (last args))))) (t (er hard 'semantics "The pattern in defsem must be a non-empty ~ true-list of no more than four distinct symbols.")))) ; ----------------------------------------------------------------- ; Instruction Semantics: ; We must tell ACL2 that it is ok for a definition to ignore some of the ; variables bound in its definition. For example, in the semantics of CONST, ; below, the variable -stk- is bound and is used, but the variable -hp- and ; many others are bound but are ignored. (set-ignore-ok t) ; ----------------------------------------------------------------- (defsem (CONST c) (modify id s :stk (push c -stk-))) ; ----------------------------------------------------------------- (defsem (POP) (modify id s :stk (pop -stk-))) ; ----------------------------------------------------------------- (defsem (LOAD n) (modify id s :stk (push (nth n -locs-) -stk-))) ; ----------------------------------------------------------------- (defsem (STORE n) (modify id s :locs (put-nth n (top -stk-) -locs-) :stk (pop -stk-))) ; ----------------------------------------------------------------- (defsem (DUP) (modify id s :stk (push (top -stk-) -stk-))) ; ----------------------------------------------------------------- (defsem (ADD) (modify id s :stk (push (+ (top (pop -stk-)) (top -stk-)) (pop (pop -stk-))))) ; ----------------------------------------------------------------- (defsem (SUB) (modify id s :stk (push (- (top (pop -stk-)) (top -stk-)) (pop (pop -stk-))))) ; ----------------------------------------------------------------- (defsem (MUL) (modify id s :stk (push (* (top (pop -stk-)) (top -stk-)) (pop (pop -stk-))))) ; ----------------------------------------------------------------- (defsem (GOTO n) (modify id s :pc (+ n -pc-))) ; ----------------------------------------------------------------- (defsem (IFEQ n) (modify id s :pc (if (equal (top -stk-) 0) (+ n -pc-) (+ 1 -pc-)) :stk (pop -stk-))) ; ----------------------------------------------------------------- (defsem (IFNE n) (modify id s :pc (if (equal (top -stk-) 0) (+ 1 -pc-) (+ n -pc-)) :stk (pop -stk-))) ; ----------------------------------------------------------------- (defsem (IFGT n) (modify id s :pc (if (> (top -stk-) 0) (+ n -pc-) (+ 1 -pc-)) :stk (pop -stk-))) ; ----------------------------------------------------------------- (defsem (IFLT n) (modify id s :pc (if (< (top -stk-) 0) (+ n -pc-) (+ 1 -pc-)) :stk (pop -stk-))) ; ----------------------------------------------------------------- (defsem (NEW class) (let* ((obj (new-object class -ct-)) (ref (new-ref -hp-)) (s1 (modify id s :stk (push ref -stk-) :hp (bind ref obj -hp-)))) (cond ((extendsp class "Thread" -ct-) (let ((new-id (len (tt s1))) (run-locator (resolve-method-name "run" class -ct-))) (modify new-id s1 :cs (push (make frame :pc 0 :locs (list ref) :stk nil :mloc run-locator) nil) :stat 'inactive :ref ref))) (t s1)))) ; ----------------------------------------------------------------- (defsem (GETFIELD descr) (let* ((class (nth 0 descr)) (field (nth 1 descr)) (obj (deref (top -stk-) -hp-)) (val (getf class field obj))) (modify id s :stk (push val (pop -stk-))))) ; ----------------------------------------------------------------- (defsem (PUTFIELD descr) (let* ((class (nth 0 descr)) (field (nth 1 descr)) (value (top -stk-)) (obj (deref (top (pop -stk-)) -hp-)) (ref (top (pop -stk-)))) (modify id s :stk (pop (pop -stk-)) :hp (bind ref (putf class field value obj) -hp-)))) ; ----------------------------------------------------------------- (defsem (INSTANCEOF class) (modify id s :stk (push (if (instanceofp (deref (top -stk-) -hp-) class) 1 0) (pop -stk-)))) ; ----------------------------------------------------------------- (defsem (INVOKESTATIC descr) (let* ((class (nth 0 descr)) (method (nth 1 descr)) (n (nth 2 descr)) (actuals (rev (topn n -stk-))) (closest-mloc (resolve-method-name method class -ct-)) (s1 (modify id s :pc (+ 1 -pc-) :stk (popn n -stk-)))) (if (null closest-mloc) s (modify id s1 :cs (push (make frame :pc 0 :locs actuals :stk nil :mloc closest-mloc) -cs-))))) ; ----------------------------------------------------------------- (defsem (XRETURN) (cond ((endp (pop -cs-)) s) (t (let ((val (top -stk-)) (s1 (modify id s :cs (pop -cs-) :hp (if (synchronized-methodp -mloc- -ct-) (unlock id (nth 0 -locs-) -hp-) -hp-)))) (modify id s1 :pc :no-change :stk (push val -stk-)))))) ; ----------------------------------------------------------------- (defsem (RETURN) (cond ((endp (pop -cs-)) s) (t (modify id s :cs (pop -cs-) :hp (if (synchronized-methodp -mloc- -ct-) (unlock id (nth 0 -locs-) -hp-) -hp-))))) ; ----------------------------------------------------------------- (defsem (INVOKEVIRTUAL descr) (let* ((class (nth 0 descr)) (method (nth 1 descr)) (n (nth 2 descr)) (actuals (rev (topn (+ 1 n) -stk-))) (ref (top (popn n -stk-))) (obj-class-name (class-name-of-ref ref -hp-)) (closest-mloc (resolve-method-name method obj-class-name -ct-)) (s1 (modify id s :pc (+ 1 -pc-) :stk (popn (+ 1 n) -stk-))) (s2 (modify id s1 :cs (push (make frame :pc 0 :locs actuals :stk nil :mloc closest-mloc) -cs-)))) (cond ((null closest-mloc) s) ((native-methodp closest-mloc) (let ((other-id (id (find :ref ref (tt s))))) (cond ((equal method "start") (modify other-id s1 :pc :no-change :stat 'active)) ((equal method "stop") (modify other-id s1 :pc :no-change :stat 'inactive)) (t s)))) ((synchronized-methodp closest-mloc -ct-) (cond ((lockablep id ref -hp-) (modify id s2 :pc :no-change :hp (lock id ref -hp-))) (t s))) (t s2)))) ; ----------------------------------------------------------------- (defsem (INVOKESPECIAL descr) (let* ((class (nth 0 descr)) (method (nth 1 descr)) (n (nth 2 descr)) (actuals (rev (topn (+ 1 n) -stk-))) (ref (top (popn n -stk-))) (obj-class-name (class-name-of-ref ref -hp-)) (closest-mloc (resolve-method-name method class -ct-)) (s1 (modify id s :pc (+ 1 -pc-) :stk (popn (+ 1 n) -stk-))) (s2 (modify id s1 :cs (push (make frame :pc 0 :locs actuals :stk nil :mloc closest-mloc) -cs-)))) (cond ((null closest-mloc) s) ((native-methodp closest-mloc) (let ((other-id (id (find :ref ref (tt s))))) (cond ((equal method "start") (modify other-id s1 :pc :no-change :stat 'active)) ((equal method "stop") (modify other-id s1 :pc :no-change :stat 'inactive)) (t s)))) ((synchronized-methodp closest-mloc -ct-) (cond ((lockablep id ref -hp-) (modify id s2 :pc :no-change :hp (lock id ref -hp-))) (t s))) (t s2)))) ; ----------------------------------------------------------------- (defsem (MONITORENTER) (let* ((ref (top -stk-))) (cond ((lockablep id ref -hp-) (modify id s :stk (pop -stk-) :hp (lock id ref -hp-))) (t s)))) ; ---------------------------------------------------------------- (defsem (MONITOREXIT) (let* ((ref (top -stk-))) (cond ((unlockablep id ref -hp-) (modify id s :stk (pop -stk-) :hp (unlock id ref -hp-))) (t s)))) ; ----------------------------------------------------------------- (defun find-handler-in-xtbl (ref pc xtbl hp) (cond ((endp xtbl) nil) (t (let ((pc1 (nth 0 (car xtbl))) (pc2 (nth 1 (car xtbl))) (class (nth 3 (car xtbl)))) (cond ((and (<= pc1 pc) (<= pc pc2) (instanceofp (deref ref hp) class)) (car xtbl)) (t (find-handler-in-xtbl ref pc (cdr xtbl) hp))))))) ; We need the following lemma to pove that the next function terminates. (local (defthm cs-gets-shorter (implies (consp (pop cs)) (< (len (push frame (pop (pop cs)))) (len cs))) :hints (("Goal" :in-theory (enable pop push))))) (defun execute-THROW1 (ref id s) (declare (xargs :measure (len (cst id s)))) (semantics (THROW) (let ((handler (find-handler-in-xtbl ref -pc- (xtbl (get-method -mloc- -ct-)) -hp-))) (cond (handler (modify id s :pc (nth 2 handler) :stk (push ref nil))) ((endp (pop (cst id s))) nil) (t (let ((s1 (execute-RETURN '(RETURN) id s))) (execute-THROW1 ref id (modify id s1 :pc (- -pc- 1) :stk (push ref -stk-))))))))) (defsem (THROW) (or (execute-THROW1 (top -stk-) id s) s)) ; ----------------------------------------------------------------- ; Step and Run ; Questions: ; In the following, you may assume id is the thread identifier of a thread in ; state s. You may assume that sched (``schedule'') is a list of thread ; identifiers. ; Define ; (do-inst inst id s) - If the op-code of inst is one of those defined above, ; assume inst is a well-formed instruction of that kind. Return the result ; of executing instruction inst in thread id of s. ; (next-inst id s) - The :PC of the top frame of thread id is an index into the ; :CODE of the method indicated by the method locator, :MLOC, of the top ; frame. The instruction at that index is the next instruction to be ; executed by thread id. Return that instruction. ; (step id s) - If the :STAT (``status'') of thread id is the symbol ACTIVE, then ; execute the next instruction in thread id; else, do nothing. ; (run sched s) - step each thread indicated by the schedule, in the order ; listed by sched. Return the final state. ; Answers: (defun do-inst (inst id s) (case (op-code inst) (CONST (execute-CONST inst id s)) (POP (execute-POP inst id s)) (LOAD (execute-LOAD inst id s)) (STORE (execute-STORE inst id s)) (DUP (execute-DUP inst id s)) (ADD (execute-ADD inst id s)) (SUB (execute-SUB inst id s)) (MUL (execute-MUL inst id s)) (GOTO (execute-GOTO inst id s)) (IFEQ (execute-IFEQ inst id s)) (IFNE (execute-IFNE inst id s)) (IFGT (execute-IFGT inst id s)) (IFLT (execute-IFLT inst id s)) (NEW (execute-NEW inst id s)) (INSTANCEOF (execute-INSTANCEOF inst id s)) (GETFIELD (execute-GETFIELD inst id s)) (PUTFIELD (execute-PUTFIELD inst id s)) (INVOKEVIRTUAL (execute-INVOKEVIRTUAL inst id s)) (INVOKESPECIAL (execute-INVOKESPECIAL inst id s)) (INVOKESTATIC (execute-INVOKESTATIC inst id s)) (XRETURN (execute-XRETURN inst id s)) (RETURN (execute-RETURN inst id s)) (THROW (execute-THROW inst id s)) (MONITORENTER (execute-MONITORENTER inst id s)) (MONITOREXIT (execute-MONITOREXIT inst id s)) (otherwise s))) (defun next-inst (id s) (nth (pc (top-frame id s)) (code (get-method (mloc (top-frame id s)) (ct s))))) (defun step (id s) (cond ((equal (stat (find :id id (tt s))) 'active) (do-inst (next-inst id s) id s)) (t s))) (defun run (sched s) (if (endp sched) s (run (cdr sched) (step (car sched) s))))