1
; Copyright (C) 2014, ForrestHunt, Inc.
3
; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2.
5
; Codewalker (Version 15)
7
; with help from Warren Hunt and Matt Kaufmann
10
; =============================================================================
13
; ``Codewalker'' is a utility for exploring code in any programming language
14
; specified by an ACL2 model to discover certain properties of the code.
16
; Two main facilities are provided by Codewalker: the abstraction of a piece of
17
; code into an ACL2 ``semantic function'' that returns the same machine state,
18
; and the ``projection'' of such a function into another function that computes
19
; the final value of a given state component using only the values of the
20
; relevant initial state components.
22
; Codewalker is independent of any particular machine model, as long as a
23
; step-based operational semantics for the machine is defined in ACL2. To
24
; facilitate this language-independent analysis, the user must declare a
25
; ``model API'' that allows Codewalker to access functionality of the model
26
; (e.g., setting the pc in a symbolic state). Generally speaking, Codewalker
27
; accesses the model by forming symbolic ACL2 expressions that answer certain
28
; questions, then applying the ACL2 simplifier with full access to user-proved
29
; lemmas, and then inspecting the resulting term to recover the answer.
31
; This book starts with an extensive comment -- over 3000 lines (~50 pages).
32
; This comment is structured like a paper and its intended audience includes
33
; both users of Codewalker and any future developers of Codewalker. The major
34
; sections of the comment are listed below. Each section starts with a line of
37
; Codewalker has many limitations:
39
; * You must have a suitable ACL2 lemma data base configured for code proofs
42
; * It must be possible to express the API in the terms required by
43
; def-model-api. You must be able to identify a ``machine state,'' a
44
; single-step state transition function, here called ``step,'' and a ``pc''
45
; that points to the next instruction to be stepped.
47
; * Every reachable pc (in the region of code to be explored) must be constant,
48
; starting with the initial pc, i.e., you have to know, in concrete terms,
49
; where the instructions are stored.
51
; * Given the instruction at a reachable pc it must be possible to determine,
52
; by rewriting the step function, what the possible next values of the pc
53
; will be. This means Codewalker cannot handle instructions that set the pc
54
; to data dependent values.
56
; * The program should not exercise aliasing, i.e., writing in a way that
57
; changes the values of parts of the state not explicitly mentioned.
59
; * The region of code to be explored must terminate.
61
; * The region of code to be explored should not modify itself during execution.
63
; These limitations and a couple of ways to mitigate some of them are discussed
66
; Here are the major sections of this file. We recommend they be read in this
67
; order, by the audiences identified:
69
; [For All Potential Users and Developers:]
71
; A Friendly Introduction to Codewalker
72
; a worked example of def-model-api, def-semantics, and def-projection for
73
; a very simple machine, M1, including examples of output produced by
76
; Reference Guide to Def-Model-API, Def-Semantics, and Def-Projection
77
; a full explanation of the options available
79
; Appendix A: More on Four Similiar Data Structures: :updater-drivers,
80
; :constructor-drivers, :state-comps-and-types, and :var-names.
81
; an elaboration of several features; you may or may not be interested in
82
; this material, depending on whether the explanations in earlier sections
83
; suffice for your use
85
; Limitations and Mitigations
86
; what Codewalker cannot handle and a few suggestions that might permit
87
; Codewalker to help you, some, anyway
89
; [For Developers Only:]
91
; Following Some Examples through the Implementation
92
; the same examples as in the Friendly Introduction, but seen from the
93
; ``inside;'' examples of internal functions and data structures are
94
; shown to give a sense of how Codewalker works
96
; Guide to the Implementation of Codewalker descriptions of the books upon
97
; which Codewalker is built, the basic data structures driving Codewalker,
98
; and high level sketches of the individual steps used by def-semantics and
99
; def-projection to derive their results; following these high level
100
; descriptions are more detailed descriptions of each step, including
101
; reference to the relevant function names in the Code
103
; The Code for Codewalker
104
; the definitions of all the functions and data structures in Codewalker,
105
; interspersed with comments explaining many low-level details not covered
106
; in the material above; these comments freely use the terminology
107
; introduced above and may be hard to understand if you haven't read the
110
; How to Certify Codewalker
111
; instructions for how to rebuild all the books and replay the the simple
112
; examples discussed in the Friendly Introduction
114
; Search for the section headers above to find the beginning of each section
117
; =============================================================================
118
; A Friendly Introduction to Codewalker
120
; The events mentioned in the text below are taken from basic-demo.lsp.
122
; We have an operational semantics for the simple JVM-like machine M1. It is
123
; contained in the file m1-version-3.lisp, which also contains all the necessary
124
; lemma development for M1 code proofs.
126
; The M1 machine has a stobj state with 4 fields
128
; field accessor updater
130
; pc (rd :pc s) (wr :pc v s)
131
; locals (nth i (rd :locals s)) (wr :locals (update-nth i v (rd :locals s)) s)
132
; stack (rd :stack s) (wr :stack v s)
133
; program (rd :program s) (wr :program v s)
135
; Note that the locals field is really an array accessed by nth and update-nth.
136
; So while the stobj has 4 fields we actually think of the state as having n+3
137
; ``components'': the pc, n independently readable/writable locals, the stack,
138
; and the program. Except for initializing the state, we never write to the
139
; program field. The locals are indexed, from 0, and we actually refer to them
140
; colloquially as ``registers'' and use the informal notation reg[i] below.
142
; The M1 machine has 9 simple instructions
143
; (ILOAD i) push reg[i] on stack
144
; (ISTORE i) pop stack into reg[i]
145
; (ICONST i) push i on stack
146
; (IADD) pop 2 items, add, and push answer
147
; (ISUB) pop 2 items, subtract, and push answer
148
; (IMUL) pop 2 items, multiply, and push answer
149
; (GOTO d) increment pc by d (d may be negative)
150
; (IFEQ d) pop stack and if item is 0, increment pc by d
153
; We use M1 because it is arithmetically simple: unbounded integers, no
154
; limits on the number of registers or the size of the stack, and only a few
155
; instructions. We use the stobj version of M1 because stobjs are the most
156
; common paradigm for machine models.
158
; So consider the following program constant:
160
; (defconst *program1*
162
; (ISTORE 1) ; 1 reg[1] := 1;
164
; (ISTORE 2) ; 3 reg[2] := 0;
166
; (ISTORE 3) ; 5 reg[3] := 1;
167
; (ILOAD 0) ; 6 ; <--- loop
168
; (IFEQ 14) ; 7 if R0=0, goto 14+7;
172
; (ISTORE 1) ;11 reg[1] := reg[0] * reg[1];
176
; (ISTORE 2) ;15 reg[2] := reg[0] + reg[2];
180
; (ISTORE 0) ;19 reg[0] := reg[0] - reg[3];
181
; (GOTO -14) ;20 goto 20-14; ; goto loop
183
; (HALT))) ;22 halt with reg[1] on top of stack;
185
; What does this program do? What does it leave in reg[1]? Reg[2]? On the
186
; stack? These kinds of questions are answered by Codewalker.
188
; As a puzzle for the reader consider this: Why does it terminate?
190
; The ``what does it do?'' question is answered by def-semantics which
191
; invents an ACL2 function that returns the same final state as the program.
192
; This exposes the first big restriction on Codewalker: it only works for
193
; programs that terminate. However, you can always run Codewalker on just a
194
; region of code (e.g., a straightline segment or a loop body) to
195
; ``understand'' what that part does.
197
; The ``what does it leave in some state component?'' question is answered by
198
; the def-projection command, which invents an ACL2 function that returns the
199
; final value of the given state component. The projection facility operates
200
; on the output of def-semantics. So you should always first run def-semantics
201
; on the code of interest and then ``project out'' the final values of selected
202
; components if def-semantics's answer is still too hard to understand.
204
; Def-semantics discovers the loops in the program and writes a function for
205
; each loop. There is a loop starting at pc = 6 in our program above and
206
; def-semantics' function for that loop is named sem-6.
208
; The definition of sem-6, created by def-semantics, is shown below. When
209
; def-semantics was run it was told it could assume that the state statisfies
210
; (hyps s) which is the ``good state'' invariant for M1. We've deleted
211
; DECLAREs and other noise but included the entire logical part of the
216
; (EQUAL (NTH 3 (RD :LOCALS S)) 1))
217
; (IF (EQUAL (NTH 0 (RD :LOCALS S)) 0)
219
; (WR :STACK (PUSH (NTH 1 (RD :LOCALS S))
227
; (UPDATE-NTH 0 (+ (NTH 0 (RD :LOCALS S))
228
; (- (NTH 3 (RD :LOCALS S))))
229
; (UPDATE-NTH 1 (* (NTH 0 (RD :LOCALS S))
230
; (NTH 1 (RD :LOCALS S)))
231
; (UPDATE-NTH 2 (+ (NTH 0 (RD :LOCALS S))
232
; (NTH 2 (RD :LOCALS S)))
237
; Notice that the function does not mention code, just basic operations on the
238
; state components manipulated by the code. Notice also that we can just read
239
; from the ``base case'' that the final state has PC 22 and the final value of
240
; reg[1] is pushed on the stack. However, it may be harder to understand what
241
; the final value of reg[1] is since reg[1] is modified as the function recurs.
242
; On the other hand, def-semantics invents a measure (not shown) that explains
243
; why the function -- and the code loop -- terminates.
245
; Another thing that def-semantics does is prove that its invented functions are
246
; correct. In particular, it proves this:
248
; (defthm sem-6-correct
249
; (implies (and (hyps s) (equal (rd :pc s) 6))
250
; (equal (m1 s (clk-6 s))
253
; This reveals another fact about def-semantics: it invents a second
254
; function, CLK-6, that counts how many M1 instructions are executed from the
255
; time the loop is entered to the HALT. The theorem establishes that if the
256
; state satisfies the invariant and the initial pc is 6, then running the state
257
; for the number of steps specified by CLK-6 produces the very same state as
258
; SEM-6. That is, SEM-6 really does what was promised.
260
; To explore what SEM-6 does to the registers, we can use def-projection. If we
261
; project out the reg[1] component of the state produced by SEM-6 we get the
262
; following function. Again, certain DECLAREs and other non-logical noise has
265
; (defun fn1-loop (r0 r1 r3)
266
; (cond ((or (not (integerp r3))
268
; (not (integerp r0))
270
; (not (integerp r1))
273
; ((or (not (equal r3 1)) (equal r0 0))
275
; (t (fn1-loop (+ -1 r0) (* r0 r1) 1))))
277
; Here are some immediate observations we can make about this function -- and
278
; thus about the code.
280
; (1) The new function does not take state s as an argument! It just takes
281
; three values, r0, r1, and r3 -- which happen to be the initial values of
282
; reg[0], reg[1], and reg[3] respectively. It assumes they are natural numbers
283
; -- it short-circuits to 0 if they're not.
285
; (2) We can immediately see that the final value of reg[1] does not depend on
286
; reg[2], since reg[2] (``r2'') is not mentioned above.
288
; (3) We see that if the hypotheses on r0, r1, and r3 are satisfied then the
289
; final value of r1 is just the product of the naturals from r0 down to 0.
291
; (4) R3 seems a bit irrelevant. Its only role is to short-circuit the
292
; computation if it is not 1 upon entry. Thereafter it is always 1. But note
293
; that if R3 is not 1, this function doesn't correspond to the code! The code
294
; loops by replacing R0 by R0 - R3. But the function recurs by replacing R0 by
297
; The def-projection command also proves this theorem:
299
; (defthm fn1-loop-correct
301
; (equal (nth 1 (rd :locals (sem-6 s)))
302
; (fn1-loop (nth 0 (rd :locals s))
303
; (nth 1 (rd :locals s))
304
; (nth 3 (rd :locals s))))))
306
; which we can count as a fifth observation and which leads to another:
308
; (5) The final value of reg[1] after running sem-6 is what fn1-loop computes,
309
; given only the initial values of reg[0], reg[1], and reg[3].
311
; (6) Since we already know (from the theorem sem-6-correct, above) that sem-6
312
; produces the same state as running the code starting at pc = 6, we can put
313
; the two theorems together to conclude that fn1-loop computes the final value
314
; of reg[1] after running the code starting at pc = 6.
316
; Next we discuss what you must do to make def-semantics and def-projection produce
317
; such answers. There are really four steps.
319
; Step 1: Decide what the independently readable/writeable state components in
320
; your model are, decide what you want the canonical expressions to be for
321
; those components, develop a collection of lemmas about your model for
322
; reducing finite-length runs of program segments to those terms, and develop
323
; the ``opener'' and ``seqential execution'' lemmas you'd need if you were
324
; doing code profos about your model. To see the lemmas actually proved about
325
; the M1 model here, see the tail end of the file m1-version-3.lisp which
326
; contains the most basic code proof lemmas, plus the lemmas in the encapsulate
327
; after (hyps s) is defined in the basic-demo.lsp script.
329
; Step 2: Tell the Codewalker utilities how to access the model.
332
; :run M1 ; the run function of the model
333
; :svar S ; name of state variable
334
; :stobjp T ; and whether it's a stobj
335
; :hyps ((HYPS S)) ; invariant to assume about state
336
; :step STEP ; name of step function
337
; :get-pc (LAMBDA (S) (RD :PC S)) ; how to fetch the pc
338
; :put-pc (LAMBDA (V S) (WR :PC V S)) ; how to set the pc
340
; ; the ``drivers'' below specify how to
341
; ; dive through updaters (and constructors)
342
; ; and their accessors
343
; :updater-drivers (((UPDATE-NTH I :VALUE :BASE)
345
; ((WR LOC :VALUE :BASE)
347
; :constructor-drivers nil
348
; ; list patterns that match each state component
349
; ; and its inherent type under the :hyps. See below.
350
; :state-comps-and-types (((NTH I (RD :LOCALS S)) (NATP (NTH I (RD :LOCALS S))))
351
; ((RD :STACK S) (NATP-LISTP (RD :STACK S)))
352
; ((RD :PC S) (NATP (RD :PC S))))
354
; :callp nil ; recognizer fn for states with pc on call instruction
355
; :ret-pc nil ; how to fetch the return pc after a call
356
; :returnp nil ; recognizer for states with pc on return instruction
358
; :clk+ binary-clk+ ; how to add two clocks
359
; :name-print-base nil ; base to use for pcs appearing in names
360
; ; (2, 8, 10, or 16)
362
; ; how to generate variable names from state comps
363
; :var-names (((RD :PC S) "PC")
364
; ((NTH I (RD :LOCALS S)) "R~x0" I)
365
; ((RD :STACK S) "STK"))
368
; The constructor drivers are generally unnecessary for stobj-based models.
369
; When might you need it? Suppose your chosen canonical form for register
372
; (wr :locals (cons new-r0 (cons new-r1 (cons ... (cd...dr (rd :locals s))))) s)
376
; (wr :locals (update-nth 0 new-r0 (update-nth 1 new-r1 ... (rd :locals s))) s)
378
; Then you would need to tell def-semantics how to dive through conses and would
381
; ((cons a b) (car :base) (cdr :base))
383
; to :constructor-drivers in your API. If your new states were constructed by
384
; (make-state pc locals stack program) expressions, instead of wr expressions,
385
; you'd need to add a tuple like
387
; ((make-state pc locals stack program)
388
; (rd :pc :base) (rd :locals :base) (rd :stack :base) (rd :program :base))
390
; in addition to the cons tuple above. Note the convention that :base denotes
391
; the location of the state argument in the accessor expressions.
393
; :Var-names is used in the generation of variable symbols to use in place of
394
; state components. For example, Codewalker may need to generalize the state
395
; component (NTH 7 (REGS S)) and you may prefer for it to generate the variable
396
; name R7. Technically, :var-names is always a function which maps a term to a
397
; string and that string is used as the root name of a new variable symbol.
399
; But as illustrated above, def-model-api supports the idea that :var-names may
400
; be a list of tuples, of the form (pattern fmt-string term_0 term_1 ...). These
401
; are called ``var name rules.'' When such a list is provided, def-model-api
402
; actually generates a suitable lambda expression and sets :var-names to that
405
; The meaning of a var name rule is:
407
; if a state component matching pattern [see caveat below] must be
408
; generalized, then obtain the root string for the new variable by formatting
409
; fmt-string under an alist binding #\0 to the value of term_0, #\1 to the
410
; value of term_1, etc. There may be no more than 10 term_i. The evaluation
411
; of the term_i is done with respect to an environment determined by the
412
; substitution produced by matching the pattern with the state component.
414
; Caveat: The substition produced by the match must satisfy two rules: (a)
415
; The svar of the API can only be bound to itself -- thus if S is the svar,
416
; then the pattern (NTH I (REGS S)) matches component (NTH '7 (REGS S)) but
417
; does not match the term (NTH '7 (REGS ST)). (b) Every other variable in
418
; the pattern must be bound to a quoted constant. Since the only variable
419
; that may appear in a state component produced by Codewalker is svar,
420
; neither of these restrictions matter much. However, (b) insures that if
421
; the term_i involve only the (non-svar) variables of the pattern, then it is
422
; possible to evaluate the term_i under the substitution.
424
; Step 3: Issue the command to explore your code. To do this you have to
425
; decide at what pc exploration is to begin and, perhaps, the ``focus region''
426
; to be explored, a root-name to use in the generation of the clock and
427
; semantic function names, additional invariant :hyps to extend those in the
428
; API, and some annotations to modify the otherwise automatically generated
431
; The focus region is specified by a predicate that takes the pc and returns t
432
; or nil depending on whether the pc is in the region you care about. That's
433
; the :focus-regionp argument mentioned below. It might be used if you want to
434
; simulate through a fixed region or stop when you encounter certain
435
; instructions that def-semantics doesn't ``understand.'' (Codewalker must be
436
; able to follow the flow of control and if an instruction sets the pc to some
437
; function of the data, def-semantics will signal an error.)
439
; In this example, we defined the state invariant to be:
442
; (declare (xargs :stobjs (s)))
445
; (< (rd :pc s) (len (rd :program s)))
446
; (< 16 (len (rd :locals s)))
447
; (natp-listp (rd :locals s))
448
; (natp-listp (rd :stack s))))
450
; Note that it makes no requirement on the program component of s, so the code
451
; in this state s could be anything. We'll show below how this invariant is
452
; strengthened so that we have a particular program in the state.
454
; In basic-demo.lsp you will see that in order to constrain the state
455
; to contain our *program1* above, we defined:
457
; (defun program1p (s)
458
; (declare (xargs :stobjs (s)))
459
; (equal (rd :program s) *program1*))
461
; and then strengthened the :hyps of the API when we issued the
462
; following command to explore the code:
466
; :focus-regionp nil ; optional - to limit the region explored
467
; :root-name nil ; optional - to change the fn names chosen
468
; :hyps+ ((program1p s)) ; optional - to strengthen the :hyps of API
469
; :annotations nil ; optional - to modify output generated
472
; We could have used:
474
; :hyps+ ((equal (rd :program s) *program1*))
476
; in the def-semantics command but as you'll see from looking at
477
; basic-demo.lsp we introduced program1p, proved some lemmas about it, and
478
; disabled it. Otherwise, where you see (program1p s) in the derived functions
479
; below you would see *program1*. When the program in question is very large,
480
; you might prefer the approach used here.
482
; Def-semantics explores the state satisfying the extended invariant starting
483
; at the :init-pc 0. It discovers the loop at pc = 6 and ultimately defines
484
; four functions, clk-6, clk-0, sem-6, and sem-0, and two defthms, one stating
485
; the correctness of sem-6 (wrt the clock function clk-6) and one the
486
; correctness of sem-0 (wrt clk-0). If we wanted to make the function names
487
; reflect the fact that they were generated from *program1* we could have
490
; :root-name "PROGRAM-1-PC" ; or just the symbol program-1-pc
492
; in the def-semantics above and then the names would be clk-program-1-pc-0,
493
; sem-program-1-pc-0, etc.
495
; Def-semantics actually prints a lot of stuff as it goes. It also often
496
; fails! Some of its error messages make supposedly helpful suggestions as to
497
; what's ``wrong.'' Often your response will be to prove more lemmas because
498
; things aren't being reduced to the canonical forms. Another response might
499
; be to restrict the focus region or strengthen the invariant so as to avoid
500
; certain cases. Another common failure is the inability to guess why a
501
; function (loop) terminates, in which case the right response might be to add
502
; an :annotation to tell it the :measure for the troublesome function or,
503
; instead of addining an :annotation, to teach the Terminatricks package a new
504
; measure pattern. Sometimes you can figure out what you need to do by reading
505
; the checkpoints of failed proofs. If you're still lost, you might try
506
; (assign acl2::make-event-debug t) and look at that output!
508
; Sometimes, if def-semantics generates definitions and theorems but cannot
509
; admit them, the best response is to take the ``bad'' definitions and theorems
510
; it was trying to admit and use them as starting points for your own
511
; definitions and theorems. In that case, you'd just comment out the original
512
; def-semantics event in your evolving script and substitute the ``bad''
513
; definitions and theorems -- and then hand-edit them so they are correct and
516
; But when def-semantics succeeds, here is how you can get a sketch of what it
520
; d 8:x(DEF-SEMANTICS :INIT-PC 0 ...)
521
; (TABLE ACL2::ACL2-DEFAULTS-TABLE ; update tables used
522
; :VERIFY-GUARDS-EAGERNESS ...) ; by Terminatricks
523
; (TABLE ACL2::MEASURE-PATTERNS :LIST ...)
524
; L d (DEFUN CLK-6 (S) ...) ; clock fn for pc=6
525
; (TABLE ACL2::MEASURE-PATTERNS :LIST ...)
526
; L d (DEFUN CLK-0 (S) ...) ; clock fn for pc=0
527
; L (DEFUN SEM-6 (S) ...) ; semantic fn for pc=6
528
; L (DEFUN SEM-0 (S) ...) ; semantic fn for pc=0
529
; (DEFTHM SEM-6-CORRECT ...) ; correctness for pc=6
530
; (IN-THEORY (DISABLE CLK-6))
531
; (DEFTHM SEM-0-CORRECT ...) ; correctness for pc=0
532
; (IN-THEORY (DISABLE CLK-0))
534
; Note: The output above was correct as of May, 2014. It may change. In
535
; addition, for simplicity we sometimes ``prettyify'' the output shown in these
536
; comments, when in fact the events generated are in fully translated form.
537
; The output shown here is highly suggestive of what is actually produced!
538
; Re-play basic-demo.lsp and inspect the output to see EXACTLY what is
541
; Then you can print out the definitions and theorems if you so choose, e.g.,
546
; (DECLARE (XARGS :NON-EXECUTABLE T :MODE :LOGIC))
547
; (DECLARE (XARGS :STOBJS (S)))
548
; (PROG2$ (ACL2::THROW-NONEXEC-ERROR 'CLK-0 (LIST S))
549
; (IF (AND (HYPS S) (PROGRAM1P S))
553
; (WR :LOCALS (UPDATE-NTH 1 1
560
; (pe 'sem-0-correct)
561
; (DEFTHM SEM-0-CORRECT
562
; (IMPLIES (AND (HYPS S)
564
; (EQUAL (RD :PC S) 0))
565
; (EQUAL (M1 S (CLK-0 S))
568
; Recall that after def-semantics we can project out selected components. Here
569
; is how we project out the final value of reg[1] from the loop semantics,
574
; :projector (nth 1 (rd :locals s))
576
; :hyps+ ((program1p s))
579
; The function name ``FN1-LOOP'' was chosen by the user to be memorable. It is
580
; meant to suggest ``the function that computes the final value of reg[1]
581
; starting from the loop.'' The function fn1-loop returns the (nth 1 (rd
582
; :locals s)) of the state s obtained by running sem-6. That function could be
583
; defined trivially as:
585
; (defun fn1-loop (s) (nth 1 (rd :locals (sem-6 s))))
587
; but that is not what def-projection does! Instead, it does a ``cone of
588
; influence'' analysis to identify which state components contribute to the
589
; final value of the one of interest and tracks how those components change as
592
; To see what a successful def-projection did, use:
595
; 9:x(DEF-PROJECTION FN1-LOOP (NTH 1 #) ...)
596
; L (DEFUN FN1-LOOP (R0 R1 R3) ...)
597
; (DEFTHM FN1-LOOP-CORRECT ...)
599
; You may inspect the details with:
602
; (DEFUN FN1-LOOP (R0 R1 R3)
604
; (XARGS :MEASURE (ACL2::DEFUNM-MARKER (ACL2-COUNT R0))
605
; :WELL-FOUNDED-RELATION O<))
606
; (COND ((OR (NOT (INTEGERP R3))
608
; (NOT (INTEGERP R0))
610
; (NOT (INTEGERP R1))
613
; ((OR (NOT (EQUAL R3 1)) (EQUAL R0 0))
615
; (T (FN1-LOOP (+ -1 R0) (* R0 R1) 1))))
619
; (pe 'fn1-loop-correct)
620
; (DEFTHM FN1-LOOP-CORRECT
621
; (IMPLIES (AND (HYPS S) (PROGRAM1P S))
622
; (EQUAL (NTH '1 (RD ':LOCALS (SEM-6 S)))
623
; (FN1-LOOP (NTH '0 (RD ':LOCALS S))
624
; (NTH '1 (RD ':LOCALS S))
625
; (NTH '3 (RD ':LOCALS S))))))
627
; We claim that the definition of FN1-LOOP as derived by def-projection makes
628
; it easy to understand what the code is doing to compute the final value of
631
; In answering the puzzle mentioned earlier: it is also easy to see why the
632
; loop terminates. It counts R0 down to 0 by subtracting 1 from it. But the
633
; code in *program1* (pc = 19) actually subtracts reg[3] from it. However,
634
; def-semantics detects that the assignment at pc = 5 sets reg[3] to 1 and that
635
; it is unchanged throughout the loop, so it suffices to model the program as
638
; We can go on and project the value of reg[1] starting from pc = 0, with:
642
; :projector (nth 1 (rd :locals s))
644
; :hyps+ ((program1p s))
651
; (IF (OR (NOT (INTEGERP R0)) (< R0 0))
653
; (FN1-LOOP R0 1 1)))
658
; (DEFTHM FN1-CORRECT
659
; (IMPLIES (AND (HYPS S) (PROGRAM1P S))
660
; (EQUAL (NTH '1 (RD ':LOCALS (SEM-0 S)))
661
; (FN1 (NTH '0 (RD ':LOCALS S))))))
663
; We might wish to establish that fn1 is actually factorial. We can do that
669
; (* n (! (- n 1)))))
671
; (defthm fn1-loop-is-!-gen
672
; (implies (and (natp r0) (natp r1))
673
; (equal (fn1-loop r0 r1 1)
681
; And because of all we know, we can immediately relate it to the
682
; result of running the code:
684
; (defthm reg[1]-of-code-is-!
685
; (implies (and (hyps s)
687
; (equal (rd :pc s) 0))
688
; (equal (nth 1 (rd :locals (m1 s (clk-0 s))))
689
; (! (nth 0 (rd :locals s))))))
691
; We can, also or instead, project reg[2]:
695
; :projector (NTH 2 (RD :LOCALS S))
697
; :hyps+ ((program1p s))
702
; :projector (NTH 2 (RD :LOCALS S))
704
; :hyps+ ((program1p s))
707
; and thus learn that from the perspective of its effect on reg[2], the loop
708
; computes the sum of the numbers below reg[0]:
711
; (DEFUN FN2-LOOP (R0 R2 R3)
713
; (XARGS :MEASURE (ACL2::DEFUNM-MARKER (ACL2-COUNT R0))
714
; :WELL-FOUNDED-RELATION O<))
715
; (COND ((OR (NOT (INTEGERP R3))
717
; (NOT (INTEGERP R0))
719
; (NOT (INTEGERP R2))
722
; ((OR (NOT (EQUAL R3 1)) (EQUAL R0 0))
724
; (T (FN2-LOOP (+ -1 R0) (+ R0 R2) 1))))
728
; (IF (OR (NOT (INTEGERP R0)) (< R0 0))
730
; (FN2-LOOP R0 0 1)))
733
; (DEFTHM FN2-CORRECT
734
; (IMPLIES (AND (HYPS S) (PROGRAM1P S))
735
; (EQUAL (NTH '2 (RD ':LOCALS (SEM-0 S)))
736
; (FN2 (NTH '0 (RD ':LOCALS S))))))
738
; We could prove reg[2] is the sum of the naturals from reg[0] down, in the
739
; conventional manner and immediately relate it to the code:
741
; (defthm fn2-loop-is-sum-gen
742
; (implies (and (natp r0) (natp r2))
743
; (equal (fn2-loop r0 r2 1)
744
; (+ r2 (/ (* r0 (+ r0 1)) 2)))))
749
; (/ (* r0 (+ r0 1)) 2))))
751
; (defthm reg[2]-of-code-is-sum
752
; (implies (and (hyps s)
754
; (equal (rd :pc s) 0))
755
; (equal (nth 2 (rd :locals (m1 s (clk-0 s))))
756
; (/ (* (nth 0 (rd :locals s))
757
; (+ (nth 0 (rd :locals s)) 1))
760
; If we wanted to explore a different M1 program would could define, say,
761
; program2p in a way analogous to program1p above, keep the M1 API as is, and
762
; issue def-semantics and def-projection commands about program2p.
764
; To replay this demo you will need to have certified the Codewalker books.
765
; See the section How to Certify Codewalker. But once they are certified, you
766
; can replay this demo by starting ACL2 and doing:
768
; (ld "basic-demo.lsp" :ld-pre-eval-print t)
770
; You can then inspect the output or query the ACL2 data base. By the way, the
771
; ld above leaves you in the "ACL2" package, but all the definitions mentioned
772
; above are in the "M1" package and to poke around after the ld you should do
775
; If you intend to use Codewalker, we recommend that you first try your hand at
776
; a few examples. We strongly recommend you use the M1 model. You can find
777
; many examples of simple M1 programs in the ACL2 Community Books directory
778
; models/jvm/m1. See the README file there for a list of files containing
781
; =============================================================================
782
; Reference Guide to Def-Model-API, Def-Semantics, and Def-Projection
784
; After presenting the reference guide for def-model-api, we discuss the
785
; requirements on the ACL2 data base usually necessary for the other two
786
; commands to succeed. Then we provide the reference guides for def-semantics
787
; and def-projection. The subsections of this section are:
789
; Example/General Form of Def-Model-API
790
; About the ACL2 Data Base
791
; Example/General Form of Def-Semantics
792
; Example/General Form of Def-Projection
794
; All of the arguments to all three of the commands are presented in keyword
795
; form. Some arguments are optional, as noted. We present example settings
796
; for each keyword and then describe the general form and interpretation.
798
; The commands themselves generally pre-check the appropriateness of their
799
; arguments before attempting to generate tables, semantic functions, and
800
; projections. However, the commands do not necessarily pre-check all of the
801
; appopriateness conditions mentioned here. If the conditions described below
802
; are violated by your settings you will likely get a pre-check error message
803
; but sometimes the command will fail in less obvious ways. If it turns out
804
; that these failures are difficult to debug, we might be able to strengthen
805
; the pre-checks or clarify the error messages.
807
; -----------------------------------------------------------------------------
808
; Example/General Form of Def-Model-API
812
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
813
; :run RUN ; the general form:
815
; function symbol or lambda expression from a machine state and natural number
816
; to a state. If, for example, your actual ``run'' function takes its
817
; arguments in the other order you could write: (lambda (s n) (run n s)).
818
; This is a required field.
820
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
823
; variable symbol denoting the machine state. This is a required field.
825
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
828
; flag indicating whether svar is a stobj. This is a required field.
830
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
833
; invariant on state, expressed as a list of terms, in svar, implicitly
834
; conjoined. Thus, the empty list denotes the vacuous hypothesis T. The conjunction
835
; of hyps should be an invariant preserved by the run function (at least on
836
; the states and region of code of interest). This is an optional field in
837
; the sense that it has a sensible default value: nil, the conjunction over
838
; which results in the invariant T.
840
; However, it is overwhelmingly likely that you will need to provide :hyps to
841
; characterize the expected ``shape'' of state and perhaps the contents of
842
; the ``program'' part of the state to be analyzed. The def-semantics and
843
; def-projection commands provide a similar argument named :hyps+ that allows
844
; you to add conjuncts to the :hyps in the API. This feature allows you to
845
; specify an API that is independent of any particular program and then
846
; further constrain the state to contain the programs of interest each time
847
; you create a semantic function or projection.
849
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
852
; function symbol or lambda from state to state. This is a required field.
854
; Your :run and :step functions must satisfy
857
; (run s n) = (if (zp n) s (run (step s) (- n 1))),
859
; where run and step are the values of the :run and :step fields. It is
860
; possible your model does not adhere to this constraint and you will have to
861
; re-define it. Codewalker does not try to prove this constraint -- it just
862
; may fail to work if it is violated. If Codewalker reports that it worked,
863
; i.e., that the defuns it created were admitted and the theorems it created
864
; were proved, then it did work insofar as its ``claims'' are formally
867
; Your model may satisfy Constraint even though your run may not be defined
868
; exactly in this syntactic form or you have not explicitly defined a step
869
; function in your own development of the model.
871
; For example, if your run function is defined like this:
876
; (if (error-statusp s)
878
; (run (do-inst (next-inst s) s)
881
; your setting for the :step function should be
884
; (if (error-statusp s)
886
; (do-inst (next-inst s) s))).
888
; which makes the constraint between the :run and :step functions provable,
889
; assuming that (error-statusp s) implies that (do-inst (next-inst s) s) = s.
891
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
894
; function symbol or lambda expression from state to program counter of
895
; state. This is a required field.
897
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
900
; function symbol or lambda expression from new pc, v, and state, s, to a
901
; state with :get-pc v and otherwise like s. This is a required field.
903
; If, for example, the pc of your model were (nth 3 s) and your convention
904
; was to update it with update-nth, then the appropriate settings for :get-pc
905
; and :put-pc would be:
907
; :get-pc (lambda (s) (nth 3 s))
908
; :put-pc (lambda (x s) (update-nth 3 x s))
910
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
912
; (((UPDATE-NTH I :VALUE :BASE) (NTH I :BASE))
913
; ((!PC :VALUE :BASE) (PC :BASE))
914
; ((!REGS :VALUE :BASE) (REGS :BASE))
915
; ((!MEM :VALUE I BASE) (MEM I :BASE)))
917
; list of tuples (updater-term accessor-term) listing every updater and the
918
; corresponding accessor used in the simplified canonical state expressions
919
; produced from the model. The keyword :VALUE marks the slot in the updater
920
; holding the new value, the keyword :BASE marks the slot holding a nest of
921
; other updaters, constructors (see :constructor-drivers, below), or the
922
; state. Some nest of these expressions (possibly mixed with nests of
923
; constructors) around the model's :svar should match the canonical form of
924
; states produced by ACL2's simplifier on the model. All those accessor
925
; nests should be orthogonal in the sense that updating the value of one
926
; accessor nest should not change the value of a different nest.
928
; This is a required field, unless the simplified canonical state expressions
929
; from the model are expressed entirely as constructors (see next field).
930
; See also Appendix A.
932
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
933
; :constructor-drivers
934
; (((CONS A B) (CAR :BASE) (CDR :BASE))
935
; ((MAKE-STATE A B C D) (PC :BASE) (REGS :BASE) (MEM :BASE) (PROGRAM :BASE)))
937
; list of tuples of the form (constructor accessor-term_1 ...
938
; accessor-term_k) listing every constructor and the corresponding accessor
939
; terms used in the simplified canonical state expressions produced from the
940
; model. The constructor expressions must list distinct variables in their
941
; slots and the accessors are listed in the order of their corresponding
942
; slots of the constructor. The keyword :BASE marks the slot in the
943
; accessors where nests of constructors, updaters, or the state variable may
944
; appear. Some nest of these expressions (possibly mixed with nests of
945
; updaters) around the model's :svar should match the canonical form of
946
; states produced by ACL2's simplifier on the model. All those accessor
947
; nests should be orthogonal in the sense that updating the value of one
948
; accessor nest should not change the value of a different nest.
950
; This is a required field, unless the simplified canonical state expressions
951
; from the model are expressed entirely in the updater paradigm.
953
; The example setting above is unlikely in light of the :updater-drivers
954
; above: the canonical state is most likely produced either by an updater or
955
; a constructor, not both. Updaters and constructors on other data
956
; structures (e.g., update-nth and cons) used within state expressions is not
957
; unusual. See also Appendix A.
959
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
960
; :state-comps-and-types
961
; (((NTH I (REGS S)) (NATP (NTH I (REGS S))))
962
; ((STACK S) (LIST-OF-NATSP (STACK S)))
963
; ((PC S) (NATP (PC S))))
965
; list of tuples of the form (comp type), where both comp and type are terms.
966
; The state variable, svar (the contents of the :svar field of the API), must
967
; occur in comp and is treated specially. Furthermore, unless type is T, comp
968
; must occur in type, the only use of the :svar in type must be its
969
; occurrence in the comp subterm of type, and every other variable in type
970
; must occur in comp. This is a required field if def-projection is to be
973
; This list is used to determine the ``state components'' that def-projection
974
; can generalize to produce functions independent of state. A subexpression,
975
; x, of a canonical state expression is a ``state component'' precisely if
976
; there is a comp listed here such that comp matches x under the restriction
977
; that the svar in comp is bound to itself (i.e., to the contents of the
978
; :svar field) and every other variable in comp is bound to a constant. For
979
; example, given the comps above, the term (NTH 7 (LOCALS S)) is a state
980
; component, but (NTH (+ U V) (LOCALS S)) and (NTH 7 (LOCALS (FN S))) are
983
; The type of each state component is as specified by the corresponding
984
; instance of the type expression listed. For example, the type of state
985
; component (STACK S), as specified above, is (LIST-OF-NATSP (STACK S)).
986
; Thus, if def-projection generalizes (STACK S) to some new variable STK,
987
; then it will add the hypothesis that (LIST-OF-NATSP STK). Type information
988
; about the new variables is often crucial to insuring that projected
989
; functions terminate. If you want no type information added when a state
990
; component is generalized, use the type term T. Otherwise, the type term
991
; should (a) contain an occurrence of the comp term, (b) should not use svar
992
; any place but in the comp term, and (c) should use no variables other than
993
; those in the comp term.
995
; See also Appendix A.
997
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
998
; :callp ; (*** this feature not yet implemented ***)
999
; (LAMBDA (S) (MEMBER-EQ (OPCODE (NEXT-INSTR S)) '(JSR CALL)))
1001
; function symbol or lambda expression recognizing when the pc in state
1002
; points to a call instruction. This is a required field if subroutine calls
1003
; are to be explored.
1006
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1007
; :ret-pc ; (*** this feature not yet implemented ***)
1010
; term in svar indicating where the return pc is stored after a call. This
1011
; is a required field if subroutine calls are to be explored.
1014
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1015
; :returnp ; (*** this feature not yet implemented ***)
1016
; (LAMBDA (S) (EQ (OPCODE (NEXT-INSTR S)) 'RET))
1018
; function symbol or lambda expression recognizing when the pc in state
1019
; points to a return. This is a required field if subroutine calls are to be
1022
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1025
; function symbol or lambda expression for adding together two ``clocks''
1026
; (natural numbers). This is a required field.
1028
; Logically this function is just BINARY-+ (or a version of it that coerces
1029
; arguments to naturals), but most code proof lemma configurations use a
1030
; special symbol so that clock expressions are not subjected to the same
1031
; canonicalization rules as arithmetic expressions.
1033
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1034
; :name-print-base 16
1036
; the print base used for the pc when the pc is part of the name of an
1037
; automatically generated function. The :name-print-base must be 2, 8, 10, or
1038
; 16. This is an optional field which defaults to 10.
1040
; For example, the name generated for the semantic function derived starting
1041
; at pc 123 is one of the following, depending on the :name-print-base:
1044
; 8 SEM-O173 [``O'' as in ``Octal'']
1048
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1050
; (((PC S) "PC") ; general form: a function name, a lambda-
1051
; ((NTH I (REGS S)) "R~x0" I) ; expression, or as shown here, a list of
1052
; ((STACK S) "STK") ; tuples of the form
1053
; (:OTHERWISE "X")) ; (pattern fmt-string term_0 term_1...)
1055
; a function name, lambda expression or list of tuples used to produce the
1056
; variable name for a given state component (see :state-comps-and-types
1057
; above). Roughly speaking, whatever legal value is provided, the :var-names
1058
; field allows us to map a state component term into a msg (as handed by fmt
1059
; and related ACL2 printing functions) and hence into a string to use as the
1060
; root name for the variable used to generalize that state component.
1062
; This is an optional field, but if left unspecified all generated variable
1063
; names are based on the "NO-VAR-NAME-STRING", so that the formals of any
1064
; projection will be NO-VAR-NAME-STRING, NO-VAR-NAME-STRING-1,
1065
; NO-VAR-NAME-STRING-2, etc. If you have provided :var-names in your API
1066
; your will presumably be surprised to see such ugly names! By looking at
1067
; the correctness theorem for the projection (the correctness theorem for a
1068
; projection function named fn has the name fn-CORRECT) you will be able to
1069
; see the state components for which your :var-names setting suggested no
1072
; As noted above, the :var-names field may be a function symbol, lambda
1073
; expression, or a list of tuples. The third form, a list of tuples, is
1074
; illustrated above and discussed below because it is probably the most
1075
; common form. See Appendix A for a discussion of the function/lambda case
1076
; and fancier uses of the list of tuples form. In all cases, given a state
1077
; component x, :var-names determines a string which is used to generate a
1078
; unique variable symbol in the same symbol package as the :package-witness
1081
; The general handling of (pattern fmt-string term_0 ...) is as follows:
1082
; Pattern must be a term, fmt-string is a string suitable for printing with
1083
; fmt, the term_i must be terms involving only the non-:svar variables in
1084
; pattern, and there may be no more than 10 term_i. To use such a list of
1085
; tuples to generate a msg (and hence a string): Each tuple is considered in
1086
; turn and the first one to succeed produces the string to be used. Match
1087
; the pattern in the current tuple against a state component term to be
1088
; generalized. (If the patttern is :OTHERWISE, consider it matched with the
1089
; empty substitution alist.) If the match is successful, this tuple
1090
; succeeds; else it fails. The match for a successful tuple binds all the
1091
; variables in the pattern (except the :svar) to constants; it binds the
1092
; :svar to itself. Create the msg pair as with (msg fmt-string term_0 ...),
1093
; except evaluate the term_i under the alist created by the match (see note
1094
; immediately following). Then print the resulting msg to a string to obtain
1095
; the root name of the variable symbol to be used in place of the matched
1096
; state component term. [Note: technically, the alist produced by the match
1097
; binds the (non-svar) variables to quoted constants but the evaluation of
1098
; the term_i is done under an alist binding those variables to the unquoted
1101
; For example, recall the list of tuples presented above:
1104
; ((NTH I (REGS S)) "R~x0" I)
1108
; where the :svar is S. The root string generated for the state component
1109
; (PC S) is "PC". The root string generated for (NTH '3 (REGS S)) is "R3"
1110
; and the root string for (NTH '12 (REGS S)) is "R12". The root string for
1111
; (STACK S) is "STK". The root string for any state component not matching
1112
; one of the four patterns in the list is "X". In all cases, the variable
1113
; name is made unique, if necessary, by appending a hyphen and a numeric
1114
; suffix. So if there are three state components to be generalized and none
1115
; match any of the given patterns, the variable symbols X, X-1, and X-2 are
1118
; Suppose terms like (NTH '123 (MEM S)) were state components in our API
1119
; and that we added this tuple to the list above (and made sure to place it
1120
; before the :OTHERWISE tuple):
1122
; ((NTH I (MEM S)) "WORD-~x0-BYTE-~x1" (floor I 8) (mod I 8))
1124
; then the string generated for (NTH '123 (MEM S)) would be "WORD-15-BYTE-3"
1125
; because 123 = 15*8 + 3.
1127
; See also Appendix A.
1129
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1130
; :package-witness nil
1132
; a symbol used to determine the package of every function, variable, and
1133
; event name created by Codewalker. This is an optional field. If not
1134
; provided, the :svar symbol is used.
1136
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1137
; (end of keyword arguments for def-model-api)
1140
; Def-model-api translates all the alleged terms involved in the arguments and
1141
; pre-checks most of the syntactic conditions. Conditions not checked but
1142
; violated, such as failure to supply a well-formed fmt string or to supply
1143
; bindings for all of the tilde-variables in some fmt string in :var-names,
1144
; will signal errors either when def-semantics or def-projection is invoked.
1145
; If def-model-api detects no errors, it stores the results in three tables:
1147
; (table acl2::model-api) ; used by Codewalker
1148
; (table acl2::generalized-updater-drivers) ; used by Terminatricks
1149
; (table acl2::constructor-drivers) ; used by Terminatricks
1151
; -----------------------------------------------------------------------------
1152
; About the ACL2 Data Base
1154
; Before any def-semantics or def-projection commands can succeed, you must
1155
; be sure that the ACL2 lemma data base is configured for code proofs about the
1156
; functions used in your model API. Def-model-api does not check the
1157
; configuration of the ACL2 data base! Attempting to use def-semantics or
1158
; def-projection in the absence of a suitable data base will likely fail. Some
1159
; failures may be resource exhaustion, if for example, the model is being
1160
; expanded too readily by rewriting. Other failures will print terms or
1161
; Codewalker data structures containing terms that will ``suggest'' the missing
1162
; lemmas in the way that the informed ACL2 user uses ``The Method'' to find
1165
; If we let run, step, hyps, and clk+ be the contents of the corresponding
1166
; fields of the API, then the lemmas to which we refer include:
1168
; * lemmas to canonicalize terms produced by simplifying step. These include
1169
; lemmas often referred to as ``read-over-write'' and ``write-over-write'' --
1170
; lemmas that allow the rewriter to recover the symbolic value of a state
1171
; component from a symbolic state to which some modifications have been made,
1172
; and lemmas that allow the rewriter to ignore redundant or overwritten
1173
; writes. Typically these lemmas also canonicalize arithmetic expressions
1174
; and other theories arising from the step function. All of your state
1175
; components (as identified by the various fields in the API) should be in
1176
; the chosen canonical form.
1178
; * lemmas, sometimes called ``step opener'' lemmas, that prevent step from
1179
; expanding until and unless the next instruction can be adequately decoded.
1180
; Typically, the step function is a big case split on the opcode of the next
1181
; instruction and if, for example, the opcode of the next instruction cannot
1182
; be determined by rewriting, then expanding the step function on successive
1183
; instructions produces a combinatoric explosion. This is normally solved by
1184
; having one or more lemmas that force step to expand when syntactic
1185
; conditions are right and then disabling step.
1187
; * the ``sequential execution'' lemma that states that
1188
; (run s (clk+ i j)) is (run (run s i) j). Typically, clk+ is disabled in
1189
; the data base so that arithmetic canonicalization does not apply to it.
1191
; * lemmas that establish the invariance of hyps under step and run.
1193
; All subsequent def-semantics and def-projection commands are done relative to
1194
; the most recent settings of these tables. Thus, you may invoke def-model-api
1195
; repeatedly in the same session to change or debug your settings. However,
1196
; functions derived under one API are unlikely to be compatible with those
1197
; derived under another API. For example, do not expect automatic success if
1198
; you produce a semantic function under one API and then compose it with a
1199
; function derived under another, or if you try to project it under a different
1202
; -----------------------------------------------------------------------------
1203
; Example/General Form of Def-Semantics
1205
; Def-semantics, described below, explores all reachable code from a given pc
1206
; and within a specified focus region. It detects and explores loops. Its
1207
; non-erroneous output is a sequence of defun-like events defining clock and
1208
; semantic functions followed by a sequence of defthms proving those functions
1209
; correct with respect to the code and semantics. The ``defun-like'' events
1210
; are typically DEFUNM-NX events -- that is, Terminatricks is responsible for
1211
; guessing a measure (hence the ``M'' in ``DEFUNM...'') and they are declared
1212
; non-executable (``-NX'') because their bodies do not necessarily follow the
1213
; syntactic rules on single-threaded objects (since their bodies are derived by
1218
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1221
; the pc at which exploration is to start; the value is not translated. When
1222
; def-semantics uses this value as a term it embeds it in a QUOTE. This
1223
; technicality is unimportant for models with numeric pcs since quoted numbers
1224
; evaluate to themselves. But if the model uses a structured pc, e.g., (FOO
1225
; . 5), perhaps meaning instruction 5 of subroutine FOO, and one wants the
1226
; analysis to start at that location, then write:
1228
; :init-pc (FOO . 5)
1232
; :init-pc '(FOO . 5)
1234
; This is a required field.
1236
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1237
; :focus-regionp nil
1239
; a function or lambda expression that maps a pc to a Boolean value.
1240
; Def-semantics explores all reachable code from :init-pc within the region
1241
; allowed by :focus-regionp. When this predicate evaluates to nil on a pc
1242
; while def-semantics is exploring a piece of code, exploration of that branch
1243
; stops -- so the resulting semantic function will produce a state for that
1244
; branch that is ready to execute the first instruction outside the focus
1245
; region. The :focus-regionp predicate can be used to limit def-semantics to
1246
; a particular region of code, as in the setting:
1248
; (lambda (pc) (and (<= 0 pc) (<= pc 100)))
1250
; and/or to prevent def-semantics from causing an error because control from
1251
; an instruction at a certain pc cannot be determined. For example, if the
1252
; instruction at pc 53 sets the next pc to some computed value, then
1253
; def-semantics would signal an error if that instruction is reached. To
1254
; prevent that instruction from being reached one could exclude it from the
1255
; :focus-regionp, as with the setting:
1257
; (lambda (pc) (and (<= 0 pc) (<= pc 100)
1258
; (not (equal pc 53))))
1260
; If a function symbol is used for :focus-regionp, it may be a :program mode
1261
; function. This field is optional. If not supplied, the default value is
1264
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1267
; A symbol or string used as part of the names of the functions created by
1268
; def-semantics. The names all have the form CLK-<root>-<pc> and
1269
; SEM-<root>-<pc>, where <root> is derived from :root-name and <pc> is the pc
1270
; at which exploration for this function started. For example, with the
1271
; settings used here, the names of two of the functions defined would be
1272
; CLK-PROG-A-0 and SEM-PROG-A-0. (Additional names would be defined if the
1273
; reachable region involves loops.) If root-name is nil, the empty string is
1274
; used, so the generated names would be CLK-0 and SEM-0. If root-name is any
1275
; other symbol, the symbol-name string of the root-name is used, with a hyphen
1276
; tacked on to the end if one is not already there. Otherwise, root-name must
1277
; be a string and it is likewise extended with a hyphen if need be. All
1278
; generated names are in the package of the :package-witness of the API.
1280
; This is an optional field. If :root-name is not supplied, the empty string
1283
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1286
; A list of terms to be conjoined to the :hyps of the API while doing this
1287
; def-semantics. The :hyps of the API are not permanently extended, so
1288
; def-projections of functions derived by this def-semantics are likely to
1289
; require the same :hyps+ extension.
1291
; Note that you cannot ``override'' the :hyps of the API, only conjoin new
1292
; ones! If for example, the :hyps of the API say that the machine has 8
1293
; registers and you used :hyps+ to ``extend'' it to say that there are 16
1294
; registers, you would in fact have contradictory hypotheses in the extended
1295
; API and anything could be derived and proved correct!
1297
; Perhaps the most common use of :hyps+ is to constrain the contents of the
1298
; state dealing with the program being explored. Otherwise, it would be
1299
; impossible to determine the ``next instruction'' with enough specificity to
1300
; interpret it. The exact form of this characterization depends on the
1301
; model of course. The M1 model has a particular component, (program s),
1302
; containing the instructions to be executed, the JVM model has (class-table
1303
; s) containing a structure specifying classes and methods and their bytecode
1304
; instructions, and the X86 model has a read/write/execute memory but
1305
; typically devotes a region of memory to execute-only programs. In all
1306
; cases, the most common way to characterize the program space is to include a
1307
; conjuct asserting that the program area is equal to some constant list of
1308
; instructions or bytes to be interpreted as instructions. The question is
1309
; whether this assertion is included in the :hyps of the API or is part of the
1310
; :hyps+ of def-semantics. The answer is up to you and depends on whether you
1311
; intend to use the API to explore only one particular program or to explore
1312
; various programs that could be loaded into the machine. If the former,
1313
; making the constraint part of the API's :hyps makes sense because then that
1314
; API contains everything you need to use def-semantics. If the latter, it is
1315
; better to put the constraint in the :hyps+ of each def-semantics so that the
1316
; API is program-independent and can be re-used over and over as you explore
1317
; different programs on that machine.
1319
; The :hyps+ extension of the API's :hyps is used by def-semantics as the
1320
; top-level test on the incoming state to the derived semantic function; if
1321
; those extended :hyps are violated, the derived function is defined to be a
1322
; no-op returning the same state. These tests can affect the admissibility of
1323
; the derived function, the cases tested along the different paths through the
1324
; code, the canonical forms of any states produced from the derived function,
1325
; and the governing hypotheses of the ``theorem'' alleging that the derived
1326
; function is correct. However, for the correctness theorems to be provable
1327
; it is generally necessary that the extended :hyps be invariant on every call
1328
; of ANY derived function produced by this def-semantics.
1330
; This is an optional field that defaults to nil (i.e., no additional
1331
; hypotheses are added).
1333
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1336
; An alist allowing you to modify the automatically generated output of
1337
; def-semantics. Thus, if def-semantics ``almost'' succeeds in deriving good
1338
; semantic functions and their correctness theorems but the events need a
1339
; little minor tweaking to be admissible, you can add that tweaking here and
1340
; leave the def-semantics command in your script. If, on the other hand,
1341
; def-semantics fails badly, you might just take part of its output and use it
1342
; as a starting point for your own definitions and theorems.
1344
; Each element of the :annotations alist must be in one of two forms and the
1345
; form dictates how the output is modified:
1347
; * (name (DECLARE ...)) -- means that name is the name of a function that
1348
; will be generated by this def-semantics and the automatically generated
1349
; declarations are to be replaced in their entirety by the given DECLARE
1350
; form. Furthermore, the DEFUNM-NX that would have been generated becomes a
1351
; standard ACL2 DEFUN-NX! Thus, if you provide a DECLARE :annotation you
1352
; are using def-semantics to generate the body but you are completely taking
1353
; over the admission of the function.
1355
; * (name :keyword . rest) -- means different things depending on what sort of
1356
; generated event has the given name.
1358
; + If name is defun-like (i.e., DEFUNM-NX), :keyword and everything
1359
; following it is added to the front of the automatically generated XARGS,
1360
; so that (DECLARE (XARGS . auto-xargs)) becomes (DECLARE (XARGS :keyword
1361
; ,@rest . auto-xargs)) Thus, adding an :in-theory (for example)
1362
; :annotation means that you are just telling def-semantics to go ahead
1363
; with its guesses but to use your hints.
1365
; + If name is a DEFTHM, :keyword must be :hints and it and everything
1366
; following it are added to the generated defthm in the :hints position.
1368
; Note that we don't actually check what sort of event name there is until we're
1369
; asked to add the appropriate annotation. So our pre-processing error
1370
; checking on annotations is limited. However, when we attempt to use an
1371
; annotation we check for certain conditions and signal a hard or soft error
1372
; if violations are detected. Of course, ultimately the final events are
1373
; processed and must be admissible or the def-semantics will fail.
1375
; Other annotations could be implemented if they seem useful. We regard the
1376
; current :annotations as a starting point.
1378
; This is an optional field with default nil.
1380
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1381
; (end of keyword arguments for def-semantics)
1384
; Def-semantics makes certain pre-checks on the arguments and then attempts to
1385
; walk the code in question, resulting either in a supposedly self-explanatory
1386
; error message or the admission of clock and semantic functions corresponding
1387
; to :init-pc and the proof of their correctness theorem.
1389
; If run, svar, and get-pc are the contents of the :run, :svar, and :get-pc
1390
; fields of the API, init-pc is the :init-pc of the def-semantics and hyps' is
1391
; the :hyps+ extension of the :hyps field of the API, and clk and sem are the
1392
; names generated by def-semantics for the clock and semantic functions
1393
; corresponding to :init-pc, then the correctness theorem is:
1395
; (DEFTHM sem-CORRECT
1396
; (IMPLIES (and hyps'
1397
; (equal (get-pc svar) 'init-pc))
1398
; (EQUAL (run svar (clk svar))
1402
; Def-semantics disables clk after this correctness proof. Def-semantics will
1403
; define other functions and prove them correct as required by the loop
1404
; structure of the code walked.
1406
; During the exploration of the paths through a region of code, def-semantics
1407
; prints out two kinds of reports. The first kind look like this:
1409
; pc 6 ==> (7) [unkn: NIL]
1410
; pc 7 ==> (8) [unkn: NIL]
1412
; pc 337 ==> (338 350) [unkn: NIL]
1415
; and the second kind are ``SNORKEL REPORT''s as explained below.
1417
; The first kind of reports record a superficial exploration of the code to
1418
; compute the topology, i.e., loops, branches, and terminal pcs. The line
1420
; pc 337 ==> (338 350) [unkn: NIL]
1422
; means that from the state with pc 337 has two immediate successor states, one
1423
; with pc 338 and the other with pc 350. There are no successors with
1424
; indeterminate pcs. We see from this line that some kind of branch occurs at
1425
; pc 337. But this exploration superficial because it does not take into
1426
; account the tests made along the path to 337. It could be that those tests
1427
; force the test at 337 to always be T so that, in fact, pc 350 is never an
1428
; immediate successor.
1430
; The more expensive, context-sensitive exploration is done after collecting
1431
; the ``cutpoints'' from the code. (Cutpoints are discussed further below.)
1433
; Let s_0 be some machine state poised at the top of some path in the code,
1434
; e.g., state with pc 6. To explore that path, Codewalker calls the rewriter
1435
; on a term that STEPs the state until it loops, terminates or reaches some
1436
; other ``cutpoint.'' Let s_i be the state reached from s_0 after i steps.
1437
; As Codewalker steps the state it composes the changes of successive
1438
; instructions, introducing IFs to explain branches in the path.
1440
; But each step involves a call of the ACL2 rewriter, which pushes more
1441
; information onto the Common Lisp stack. Long paths can cause the Common Lisp
1442
; stack to overflow. To avoid stack overflow, Codewalker takes at most 300
1443
; steps and then stops and returns a term representing the incomplete answer,
1444
; i.e., an IF-expression with some ``tip'' states in it (states that reached
1445
; cutpoints) and also some states, e.g., s_300, not yet at cutpoints. By
1446
; stopping the rewriting and returning the (incomplete) answer, Codewalker
1447
; clears the Common Lisp stack. It then applies the rewriter to the incomplete
1448
; answer, which has the effect of extending the path 300 steps further from the
1449
; states that have not yet reached cutpoints. This is called ``snorkeling''
1450
; because it is as though the rewriter has to come up periodically for air.
1452
; Every 300 steps, Codewalker prints a snorkel report such as:
1454
; SNORKEL REPORT: pc: 6; steps 600
1455
; number of continuations: = 1
1457
; splitter pcs: (337)
1458
; partial-path-tree =
1459
; (IF (EQUAL (NTH '0 (RD ':LOCALS S)) '0) :TIP (:CONTINUATION-FROM-PC 410))
1461
; In a snorkel report, pc is the program counter at which the current path
1462
; begins, steps is the number of steps taken so far along that path and will
1463
; generally be a multiple of 300. The number of continuations is the number of
1464
; states in the incomplete answer that have not yet reached cutpints, splitter
1465
; pcs lists the pcs at which IFs were introduced, and the partial path tree is
1466
; a term-like expression that sketches the current incomplete state. In the
1467
; example above, the path beginning at 6, after 600 steps, contains on IF
1468
; (introduced by the instruction at 337) testing the term (EQUAL (NTH '0 (RD
1469
; ':LOCALS S)) '0). On the branch of the path where that term is true, some
1470
; cutpoint was reached. But on the branch where that term is false, we reached
1471
; s_300 which is a state with pc 410. After the report has been printed,
1472
; Codewalker resumes rewriting, eventually reaching a cutpoint on every branch
1475
; These reports are intended to give you a sense of the progress made so far
1476
; while exploring long branches. If you witness behavior different from that
1477
; described above, please report it.
1479
; The frequency of snorkel reports (and, more importantly, of ``coming up for
1480
; air'') is determined by the defconst *snorkel-depth*. Its value is set to
1483
; -----------------------------------------------------------------------------
1484
; Example/General Form of Def-Projection
1486
; Def-projection attempts to derive a function that returns the final value of
1487
; a given state component of the state produced by a given semantic function --
1488
; as a function only of the values of the relevant input state components. The
1489
; motivation of doing this is usually so you can better understand ``what the
1490
; code does,'' by understanding its effects on any part of the state, phrased
1491
; in terms of just those operations and inputs that affect the part of
1492
; interest. We call this ``projecting'' a component out of a semantic
1493
; function. The result is a function, called the ``projection'' of the
1494
; component. Def-projection attempts to derive a given projection of a given
1495
; semantic function and to prove that the projection is correct.
1498
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1501
; a new function symbol, to be used as the name of the projection. This is
1504
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1505
; :projector (NTH 3 (REGS S))
1507
; a state component expression, i.e., an instance of one of the comp terms in
1508
; the :state-comps-and-types field of the API, ((comp type) ...), such that
1509
; the :svar of the API is bound to itself and all other variables are bound to
1510
; constants. In the example def-model-api shown above the :svar is S and one
1511
; of the comps in the :state-comps-and-types is (NTH I (REGS S)). This comp
1512
; matches the :projector shown above, with S bound to S and I bound the
1515
; This is a required field.
1517
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1518
; :old-fn SEM-PROG-A-0
1520
; the function symbol of a semantic function written by def-semantics; the
1521
; value returned by this function is a state and the value of the function,
1522
; :new-fn, to be defined, is supposed to be the :projector component of that
1523
; state. However, def-projection attempts to derive a function definition
1524
; that does not take the entire state as an argument and instead is
1525
; sensitive only to the values of the relevant state components in the state
1526
; to which :old-fn is applied. The correctness theorem proved by
1527
; def-projection is shown below and makes clear what we mean.
1529
; This is a required field.
1530
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1533
; A list of terms to be conjoined to the :hyps of the API while doing this
1534
; def-projection. The :hyps of the API are not permanently extended. To
1535
; succeed, the extension used for this def-projection should probably be
1536
; identical to that used by the def-semantics that produced :old-fn. See the
1537
; discussion of :hyps+ in def-semantics above. This is an optional field with
1540
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1541
; (end of keyword arguments for def-projection)
1544
; Def-projection makes certain pre-checks on the arguments and then attempts to
1545
; derive a suitable definition of :new-fn. It also generates a correctness
1546
; theorem for the :new-fn. If svar is the :svar of the API and hyps' is the
1547
; :hyps+-extended :hyps in the API and (proj0 s), (proj1 s), ..., (projk s) are
1548
; all state component terms of the API, and new-fn is the name of the newly
1549
; defined function :new-fn, :projector is (proj0 s), and sem is the :old-fn
1550
; being projected, then the correctness theorem is:
1552
; (DEFTHM new-fn-CORRECT
1554
; (EQUAL (proj0 (sem s))
1555
; (new-fn (proj1 s) ... (projk s))))
1558
; Note that this theorem can be composed with sem-CORRECT to show that running
1559
; the code and projecting out the final value of proj0 is the same as computed
1560
; by new-fn on the values of components progj1, ..., projk in initial state s.
1561
; If def-projection fails to define :new-fn or to prove the correctness
1562
; theorem, a supposedly self-explanatory error message is printed.
1564
; A common error message concerns what are called ``subprojections.'' Suppose
1565
; the semantic function, say sem, calls some other semantic function, say
1566
; sub-sem. This would happen if the code explored for sem encountered a simple
1567
; loop; sub-sem would be the semantic function generated for the loop. Before
1568
; projecting some component of sem you must first project the relevant
1569
; components of sub-sem. For example, suppose you want to project out the
1570
; final value of register 1 from sem. Then you will need to first project out
1571
; the final value of register 1 from sub-sem. We call that a
1572
; ``sub-projection.'' If you attempt to project out from sem before the
1573
; necessary sub-projections have been created, def-projection will print an
1574
; error message. Usually the error message will exhibit the sub-projections
1577
; You might ask why def-projection doesn't just do the required sub-projections
1578
; if it knows what they are?
1580
; The answer is that def-projection is designed so that you choose the names of
1581
; every relevant projection (i.e., :new-fn). If sub-projections were done
1582
; automatically, the names would be arbitrarily generated symbols. We have
1583
; found this makes it harder to understand what the ultimate projection is
1584
; doing because it talks about concepts not named by the user. That defeats
1585
; the main purpose of def-projection. So do not be surprised if you're asked
1586
; to do a particular sub-projection! And when you are asked, think of a
1587
; meaningful name for the concept you're introducing!
1589
; Also note that def-projection must discover which are the ``relevant''
1590
; components affecting the final value of the one of interest. This is done
1591
; iteratively in the sense that def-projection may note that the final value of
1592
; interest depends on certain other state components and may ask you to do
1593
; sub-projections of them. In any case, you are not responsible for
1594
; identifying the ``cone of influence.'' Def-projection is responsible for
1595
; that. But do not be surprised if you are asked to name sub-projections that
1596
; are on different components than the one in which you're interested!
1598
; This completes the reference guide.
1600
; =============================================================================
1601
; Appendix A: More on Four Similiar Data Structures: :updater-drivers,
1602
; :constructor-drivers, :state-comps-and-types, and :var-names.
1604
; This Appendix discusses all four of the model API fields named in the title.
1605
; We present a few more examples to explain their individual uses and how
1606
; they're interpreted, and we discuss their relationships.
1608
; The Appendix is divided into four sections:
1610
; The :UPDATER-DRIVERS and :CONSTRUCTOR-DRIVERS Fields
1611
; The :STATE-COMPS-AND-TYPES Field
1612
; The :VAR-NAMES Field
1613
; Discussion of All Four Fields
1615
; The reason we conflate the discussions of these four fields is that all four
1616
; concern the identification of the state components being changed as a
1617
; semantic function recurs, the same state components that might be generalized
1618
; to variables in projections, the ``inherent'' types of those newly introduced
1619
; variables, and the names of those variables. There are reasons that we have
1620
; four fields instead of one, but the reasons are not necessarily good ones!
1621
; This discussion also attempts to document those reasons to inform (and
1622
; perhaps encourage) future attempts to unify the fields.
1624
; The :UPDATER-DRIVERS and :CONSTRUCTOR-DRIVERS Fields
1626
; The :updater-drivers and :constructor-drivers fields are used to explore the
1627
; canonical state expressions produced by simplifying the state expressions
1628
; derived by executing sequences of instructions in the model. Both
1629
; def-semantics and def-projection use these fields in guessing measures to
1630
; explain derived functions. In addition, def-projection uses them to identify
1631
; state components that can be generalized.
1633
; Suppose for example that some sequence of instructions produces a state expression
1634
; that canonicalizes to:
1637
; (!regs (update-nth 0 (- (nth 0 (regs s)) 1)
1638
; (update-nth 2 (+ (nth 0 (regs s)) (nth 7 (regs s)))
1639
; (update-nth 3 (nth 7 (regs s))
1641
; (!stack (nth 7 (regs s))
1644
; Then the state components that are modified in this expression are derived
1645
; entirely from information in the :updater-drivers setting:
1647
; ``modified'' components
1654
; (Technically, perhaps we should say ``targets of the writes'' since we do not
1655
; mean to imply that the new value is necessarily different from the old
1658
; These terms are called ``virtual formals'' of any semantic function that
1659
; transforms state s to the new canonicalized state expression above. The idea
1660
; behind the name is that the values of the virtual formals are being changed
1661
; independently in recursion and we might find a decreasing measure of these
1662
; virtual formals to admit the semantic function.
1664
; Determining the virtual formals (i.e., modified state components) involves
1665
; recursively diving through the canonicalized state expression confirming that
1666
; just the right nest of updaters occurs, with just the right :value and :base
1669
; Consider our determination that (nth 2 (regs s)) is modified. Naively one might
1670
; expect from this determination that the new state is (!regs (update-nth 2
1671
; ... (regs s)) s). No such expression even occurs in the new state above.
1672
; Instead we see that (!pc ... (!regs ... (update-nth 2 ... (update-nth 3
1673
; ... (regs s))) (!stack ... s))) occurs. Starting at the top, we see that
1674
; (!pc ... ...) not only modifies the pc of whatever state is in its :base, but
1675
; that it also modifies whatever that :base modifies. That :base is (!regs
1678
; Reasoning recursively, we see that its :value modifies positions 0, 2, and 3
1679
; of its ultimate base, which (regs s) -- here repeating the exact recursive
1680
; reasoning through the :values and :bases of the update-nth expressions.
1682
; Furthermore, it is not sufficient to notice that position 2 of (regs s) is
1683
; modified unless we also note that the result of all those update-nths is
1684
; ultimately written back to (regs s) via the (!regs ... ...).
1686
; Once we identify the modified slots of the canonicalized state expression, we
1687
; can look for one that is decreasing and see that (nth 0 (regs s)) is
1688
; (probably) decreasing -- if we can be sure it is a non-0 natural.
1690
; The reasoning above involves only the :updater-drivers because only updaters
1691
; are used to build the new state. If the canonicalized state expressions
1692
; involve constructors then we would have to also mix in exploration through
1693
; :constructor-drivers.
1695
; For example, an equivalent new state expression could be obtained if we
1696
; adopted a different canonical form, one in which update-nth and nth
1697
; expressions are expanded into cons/car/cdr nests. (The expression below is
1698
; equivalent to that above if (regs s) has at least 8 elements so all the
1699
; update-nth and nth expressions expand appropriately. We use extended
1700
; cad..dr/cdd..dr nests for succinctness below.)
1703
; (!regs (cons (- (car (regs s)) 1)
1704
; (cons (cadr (regs s))
1705
; (cons (+ (car (regs s)) (cadddddddr (regs s)))
1706
; (cons (cadddddddr (regs s))
1707
; (cddddr (regs s))))))
1709
; (!stack (cadddddddr (regs s))
1712
; which would result in the modified state components
1716
; (car (cdr (cdr (regs s))))
1717
; (car (cdr (cdr (cdr (regs s)))))
1720
; The identification that (car (regs s)) is probably decreasing requires
1721
; exactly the same analysis as shown above, even though the canonical form is
1724
; This also makes it clear why we impose the orthogonality requirement. If
1725
; both (cadr (regs s)) and (nth 1 (regs s)) were allowed in the canonical form
1726
; -- and thus in :updater-drivers and :constructor-drivers -- then the
1727
; ``canonical'' form wouldn't be canonical. This can confuse the termination
1728
; analysis, which is designed to suggest a decreasing measure for recursively
1729
; defined functions. For example, one standard iterative/recursive paradigm is
1730
; to count some value up to a fixed upper bound. The termination analysis
1731
; therefore might look for a state component that is used as an upper bound in
1732
; a test and that is not being changed in the new state expressions. In
1733
; non-canonical forms, the termination analysis might settle on the component
1734
; (cadr (regs s)) as fixed even though it might detect that (nth 1 (regs s)) is
1737
; The use of :updater-drivers and :constructor-drivers to identify virtual
1738
; formals is actually done by code in the Terminatricks book, where the two
1739
; fields are actually tables, named generalized-updater-drivers and
1740
; constructor-drivers. Def-model-api stores :updater-drivers and
1741
; :constructor-drivers in those tables, in addition to making them available
1742
; in the API. See the section of Terminatricks entitled Virtual Formals and
1743
; Proto Distilled Machines for more detailed comments on the use of these
1746
; The use of the keywords :value and :base in the driver patterns could be a
1747
; problem if those keywords play important roles in the model. Let us know and
1748
; we'll adopt another convention. (This faulty convention stems from an early
1749
; implementation in which these terms had to be in translated form and
1750
; thus the user actually wrote (rd ':pc :base), where the UNQUOTED :base
1751
; denoted the special slot. But when we added the automatic translation of
1752
; these patterns, allowing (rd :pc :base), suddenly the role of :base is
1753
; ambiguous: is it a built-in constant or a special token marking the slot?)
1755
; The :STATE-COMPS-AND-TYPES Field
1757
; Now we turn to the :state-comps-and-types field. This field determines which
1758
; parts of a state def-projection can generalize to new variables.
1760
; Recall that the shape of each element is (comp type), as in
1763
; ((NTH I (REGS S)) (NATP (NTH I (REGS S))))
1765
; where both comp and type are terms, comp mentions the :svar variable of the
1766
; API, and, except when type is T, comp occurs in type so that when an instance
1767
; of comp is generalized, the same generalization of that instance of type
1768
; produces a constraint on the new variable. For example, if (NTH 7 (REGS S))
1769
; is generalized to R7, then (NATP R7) is the constraint imposed by the above
1772
; When def-projection identifies a state component, (sc s), to be generalized
1773
; and become a formal parameter, v, of the projection it also identifies
1774
; constraints, (p v), on the new variable. These come from three sources: (a)
1775
; tests on the state component made by the semantic function being projected,
1776
; (b) tests on the state component derived from the invariant :hyps assumed in
1777
; the API, and (c) the type test associated with the state component in the
1778
; :state-comps-and-types.
1780
; One might think that (c) is unnnecessary in light of (b), e.g., one might
1781
; reason, incorrectly, that ``if the user wants to add (p v) when (sc s) is
1782
; generalized to v, it is sufficient for the user to add the conjunct (p (sc
1783
; s)) to :hyps in the API.'' This fails because it (p (sc s)) might be always
1784
; T due to ``inherent'' properites of sc rather than to properties conferred
1785
; by the particular state.
1787
; For example, one might define the register accessor (RD-REG I S). In fact,
1788
; one might define RD-REG so that it is known to return a natural number less
1789
; than 2^32 by construction. If (RD-REG 7 S) is a state component to be
1790
; generalized, one might hope to recover (< (RD-REG 7 S) (EXPT 2 32)) by
1791
; inspecting the :hyps of the API. But that fact, even if it had been included
1792
; explicitly as a conjunct, would have been simplified to T by properties of
1795
; We could get constraints (c) via ACL2's :GENERALIZE lemmas. But experiment
1796
; has found that those lemmas might introduce additional constraints that
1797
; complicate the projections. So (c) -- and thus the type terms in
1798
; :state-comps-and-types -- really serve two purposes: to get necessary
1799
; intrinsic properties of the formal parameters and to avoid picking up junk
1800
; the user doesn't want, i.e., to allow the user to specify exactly what is
1803
; The :VAR-NAMES Field
1805
; The :var-names setting used in the Reference Guide example was:
1808
; ((NTH I (REGS S)) "R~x0" I)
1812
; and its interpretation is explained in the Reference Guide for def-model-api.
1813
; This form of :var-names was called the ``list of tuples'' format.
1815
; But it is also legal to set the :var-names to a function name (or equivalent
1816
; lambda expression). The function may be in either :logic or :program mode.
1817
; It is sometimes easier to code a :program mode function than to arrange a
1818
; suitable list of tuples. Here we explain how to achieve the same effect by
1819
; setting :var-names to a function.
1821
; Before executing the def-model-api, define my-var-names as:
1823
; (defun my-var-names (term) ; term is a state component; we return
1824
; ; ; a string or fmt msg that prints the string we
1825
; ; ; choose. Remember that term is in translated
1826
; ; ; form, so constants are all QUOTEd!
1828
; (declare (xargs :mode :program))
1831
; (('NTH ('QUOTE I) '(REGS S)) (msg "R~x0" I))
1832
; (('STACK 'S) ; or equivalently '(STACK S)
1836
; Note that (my-var-names '(NTH '7 (REGS S))) generates the root name "R7".
1837
; When '7, aka (QUOTE 7), is matched by case-match against ('QUOTE I), the I is
1838
; let-bound to 7. When (msg "R~x0" I) is then evaluated (as part of applying
1839
; my-var-names) (msg "R~x0" I) produces the msg pair ("R~x0" . ((#\0 . 7))) as
1840
; the result of my-var-names. That pair is then printed with fmt to produce
1841
; "R7". Note also that the :svar of the machine model is built into the
1842
; definition above, as 'S.
1844
; Suppose we wanted to map (NTH 123 (MEM S)) to the string "WORD-15-BYTE-3",
1845
; since 123 = 15*8 + 3. We could do that with either the list of tuples form
1846
; or the function/lambda expression form. The list of tuples would be:
1849
; (((PC S) "PC") ; general form:
1850
; ((NTH I (REGS S)) "R~x0" I) ; (pattern fmt-string term_0 term_1...)
1851
; ((NTH I (MEM S)) "WORD-~x0-BYTE-~x1" (floor I 8) (mod i 8))
1855
; Alternatively, we could define:
1857
; (defun my-var-names (term)
1858
; (declare (xargs :mode :program))
1861
; (('NTH ('QUOTE I) '(REGS S)) (msg "R~x0" I))
1862
; (('NTH ('QUOTE I) '(MEM S)) (msg "WORD-~x0-BYTE-~x1"
1863
; (floor I 8) (mod i 8)))
1864
; (('STACK 'S) "STK")
1867
; It is sometimes easier to define a :var-names function than to use the
1868
; list-of-tuples approach, especially if you want to use sophisticated tests to
1869
; steer the function function to the right string or msg. For more, and more
1870
; elaborate, examples, See the Essay on :var-names -- Two Ways for the User to
1871
; Control the Generation of Variable Names in the Code section of this file.
1873
; Discussion of All Four Fields
1875
; Clearly, all four of these fields are involved in the user's specification of
1876
; of what a ``state component'' is. The urge to unify the fields, perhaps into
1877
; a single field, is strong. That single field might describe the shape of a
1878
; state component and its type, a la :state-comps-and-types, and additionally
1879
; encode how to generate the appropriate variable names from instances of the
1880
; pattern. This would obviate :updater-drivers and :constructor-drivers.
1882
; However, Terminatricks needs those two lists, which are stored there as
1883
; tables. Recall that Terminatricks is charged with looking at a proposed
1884
; function definition and guessing a decreasing measure. Terminatricks
1885
; ``learns'' from previously admitted definitions with user-supplied measures
1886
; as well as patterns in certain user-controlled tables. A key idea introduced
1887
; in Terminatricks is that of ``virtual formal,'' a part of an argument being
1888
; changed in recursion.
1890
; For example, the following is an easy-to-admit function for Terminatricks
1891
; which is not admitted without an explicit measure by ACL2.
1896
; (if (atom (car x))
1898
; (foo (cons (caar x)
1899
; (cons (cdar x) (cdr x)))))))
1901
; Terminatricks guesses that the measure (acl2-count (car x)) decreases,
1902
; because it identifies (car x) as a ``virtual formal'' of this function based
1903
; on the :constructor-driver ((cons a b) (car :base) (cdr :base)).
1905
; Terminatricks has nothing to do with Codewalker, semantic functions, machine
1906
; models, machine states, etc.
1908
; Thus, if Codewalker were to have a single unified field to answer the
1909
; questions that def-semantics and def-projection have about state components
1910
; and Codewalker expects to use Terminatricks, then the developer of
1911
; Codewalker must implement some transformation of the unified field into
1912
; appropriate settings for Terminatricks' driver tables. While this is
1913
; probably practical, we decided it was better to get on with developing
1914
; Codewalker's functionality.
1916
; =============================================================================
1917
; Limitations and Mitigations
1919
; When we say that ``Codewalker fails'' we mean that its attempt to admit
1920
; definitions or prove theorems fails in one of the standard ways ACL2 events
1921
; may fail: resource exhaustion, running ``forever,'' or error messages. If
1922
; Codewalker succeeds, i.e., terminates without such failures, then the derived
1923
; definitions are admissible and the alleged correctness ``theorems'' are
1924
; indeed theorems, notwithstanding any statements below about the assumptions
1927
; Limitation 0: You must have a suitable ACL2 lemma data base configured for
1928
; code proofs about your model. We discuss this in more detail in the
1929
; reference guide for def-model-api. The ``friendly introduction'' section
1930
; below cites a worked example of Codewalker functionality whose source files
1931
; exhibit the necessary setup.
1933
; Limitation 1: It must be possible to express the API in the terms required by
1934
; def-model-api below, e.g., the model is an ACL2 operational semantics based
1935
; on some notion of ``state,'' a single step transition function, a function
1936
; that ``runs'' a state some number of steps, and a ``pc'' that points to the
1937
; next instruction to be stepped.
1939
; Limitation 2: Codewalker requires that every reachable pc traversed must be
1940
; constant, starting with the initial pc. For example, a typical def-semantics
1941
; command says ``start exploration at :init-pc 0'' or ``:init-pc 12345'' but
1942
; should not say ``:init-pc (+ x 23).''
1944
; Limitation 3: Given the instruction at a reachable pc it must be possible to
1945
; determine, by rewriting the step function, what the possible next values of
1946
; the pc will be. All of those next pc values must be constants. To be more
1947
; precise, rewriting the application of the step function on a state with a
1948
; constant pc should canonicalize to an IF-expression whose tips are state
1949
; expressions and the pcs in all those states should be constant. This means,
1950
; for example, that an ISA that includes instructions that may set the pc to
1951
; data-dependent values may cause trouble if encountered. An example of such
1952
; an instruction would be a jump to the value of a computed arithmetic
1953
; expression. A more common example is a call instruction to a subroutine
1954
; whose starting pc cannot be resolved to a constant.
1956
; Limitation 4: Codewalker assumes that the canonical expressions for state
1957
; components arising from expanding the step function on the program of
1958
; interest are all independent or ``orthogonal.'' Thus, if a program exploits
1959
; aliasing or accesses and modifies data via different canonical idioms, it is
1960
; likely to cause Codewalker to fail. For example, suppose the idiom for
1961
; accessing memory is (rd-mem addr sz s), where addr is the memory address, sz
1962
; is the number of bytes to read, and s is the state variable. Then the two
1963
; ``canonical'' expressions (rd-mem 100 8 s) and (rd-mem 103 2 s) are not
1964
; orthogonal. Memory writes that change one of those values may change the
1965
; other whereas Codewalker assumes otherwise and may produce incorrect semantic
1966
; functions on code that uses both idioms.
1968
; Limitation 5: Codewalker will not work if the code to be explored does not
1969
; terminate under the hypotheses of the API. This is a fundamental limitation
1970
; of the current design: the semantic functions derived by Codewalker must be
1971
; admissible in the ACL2 logic.
1973
; Limitation 6: Codewalker will probably not work on self-modifying code. The
1974
; control flow graph of the program is determined by static analysis of the
1975
; code. We suspect that if the control flow graph of the original code is the
1976
; same as the graph of the running, self-modifying code, Codewalker might
1977
; actually succeed in producing the correct semantics. But the truth is that
1978
; we haven't thought about such exploring self-modifying programs (yet) because
1979
; we need to walk before we can run!
1981
; It is possible to mitigate some of these limitations some of the time.
1982
; Imagine that the code of interest contains instructions that would cause
1983
; Codewalker to fail. Def-semantics can still be used to explore that portion
1984
; of the code that Codewalker can handle. Two obvious ways to do this are:
1986
; * use the :focus-regionp argument of def-semantics to limit the exploration
1987
; to regions of code containing instructions Codewalker can handle
1989
; * use the :hyps argument of def-model-api or the :hyps+ argument of
1990
; def-semantics to restrict Codewalker's attention to paths that it can
1993
; The second idea, of changing the hypotheses under which the code is analyzed,
1994
; sometimes admits a way to partially handle some limitations. For example, if
1995
; the code doesn't in general terminate but can be shown to terminate under
1996
; some hypothesis, then adding that hypotheses to :hyps or :hyps+ might be
1999
; Similarly, if the program contains the instruction ``jump to the unknown
2000
; value of register 2'' you might add the hypothesis that register 2 contains
2001
; 123. Because the meaning of any instruction is actually computed by the ACL2
2002
; rewriter, that assumption -- if it interacts properly with your rewrite rules
2003
; -- could make the jump instruction's new pc resolve to a constant as
2006
; Changing the assumptions may well violate assumed invariants causing proofs
2007
; to fail. The :hyps (as extended by :hyps+) are supposed to be invariant
2008
; under the step function. But even if the correctness proofs fail, Codewalker
2009
; will produce and print semantic functions derived under these (bogus)
2010
; hypotheses and you may well find those definitions helpful in understanding
2011
; the code or building a provably correct semantic function.
2013
; The mitigation techniques outlined here will not allow the complete analysis
2014
; of code that Codewalker inherently cannot ``understand.'' But the larger
2015
; point is that Codewalker should be viewed as an assistant that may help you
2016
; understand the code. You may find that Codewalker fails every time you use
2017
; it and yet prints things that are helpful! Remember, if worse comes to
2018
; worst, you can use Codewalker to take a stab at the semantics, grab its
2019
; ill-formed, half-baked, incorrect ideas out of the session log, and use them
2020
; in a hand-built model of the code. In the end, Codewalker may not play a
2021
; role in your certified book, but could still play an important role in the
2022
; creation of that book.
2024
; =============================================================================
2025
; Following Some Examples through the Implementation
2027
; Before we start with the details of the implementation it may be helpful to
2028
; go through one of the examples above ``from the inside,'' i.e., with our
2029
; attention on how the results are produced rather than just the user input and
2032
; In this section we'll talk about some of those. For convenience we reproduce
2033
; the *program* being walked and the derived definitions of CLK-6 and SEM-6.
2035
; (defconst *program1*
2037
; (ISTORE 1) ; 1 reg[1] := 1;
2039
; (ISTORE 2) ; 3 reg[2] := 0;
2041
; (ISTORE 3) ; 5 reg[3] := 1;
2042
; (ILOAD 0) ; 6 ; <--- loop
2043
; (IFEQ 14) ; 7 if R0=0, goto 14+5;
2047
; (ISTORE 1) ;11 reg[1] := reg[0] * reg[1];
2051
; (ISTORE 2) ;15 reg[2] := reg[0] + reg[2];
2055
; (ISTORE 0) ;19 reg[0] := reg[0] - reg[3];
2056
; (GOTO -14) ;20 goto 20-14; ; goto loop
2058
; (HALT))) ;22 halt with a on top of stack;
2061
; :init-pc 0 ; initial pc where exploration starts
2062
; ) ; optional args default
2064
; The first steps in def-semantics are to analyze the control flow and
2065
; identify pc = 6 as a loop and pc = 22 as the exit. These, along with the
2066
; entry, 0, are called the ``cutpoints'' of the program. Roughly speaking
2067
; we do this by building context-free flow graph like the one shown below:
2071
; 0 --> 1 --> 2 --> 3 --> 4 --> 5 --> 6 --> 7
2073
; | 8 --> ... --> 20
2074
; |_____________________|
2076
; We do this by taking a state s sastisfying the :hyps+-extended :hyps of the
2077
; API, setting the pc to 0, and stepping it once with the simplifier to get an
2078
; IF-expression with new symbolic states at the tips. We collect all the pcs
2079
; of those tips and know that the instruction at pc 0 transitions to (at most)
2080
; one of those pcs. We repeat this until we've explored the whole focus
2083
; Note that each step is ``context free:'' we don't compose transitions from
2084
; state to state at this stage.
2086
; Having identified (0 6) as non-terminal cutpoints and (22) as the only halt
2087
; we simulate forward from each non-terminal cutpoint to whatever cutpoint(s)
2088
; are encountered next. (By construction, we know some cutpoint will be
2089
; encountered before we loop back on ourselves, no matter where we start.) So,
2090
; for example, the first (and only) cutpoint reached from pc 0 is pc 6.
2092
; This simulation is done with the simplifier and compounds successive states,
2093
; so it is context sensitive (relative to the state invariant and previously
2094
; tested tests). This simulation may produce a big IF-expression with state
2095
; expressions at the tips -- except we use a rewriting trick to keep track of
2096
; how many steps we take to reach each final cutpoint pc (``fpc'') and the
2097
; particular path through the pcs we followed to get there. For example, the
2098
; expression produced by simulating forward from pc = 0 is shown below. This
2099
; is called a ``path-tree.'' (We have untranslated the expressions below by
2100
; hand for readability.)
2102
; (ACL2::CODEWALKER-TIP
2104
; '(0 1 2 3 4 5 6) ; path from 0 to 6 (``fpc'' = 6)
2105
; NIL ; splitters (pcs introducing IFs)
2106
; (WR :PC 6 ; final state (``s[6]'' =)
2114
; The CODEWALKER-TIP function just records the number of steps taken from pc 0,
2115
; the path followed (concluding with the fpc = 6), the pcs introducing IFs, and
2116
; the final state (here s[6]).
2118
; Such path-trees are the basis of the definitions of both the clock and the
2119
; semantic functions.
2121
; For example the clock function starting at pc 0 will basically be
2123
; (clk+ 6 ; step count of codewalker-tip for pc=0
2124
; (clk-6 ; name of clock function for pc=6
2125
; s[6])) ; final state in codewalker-tip for pc=0
2127
; These remarks ignore that fact that we assumed extended hyps. If we add that
2128
; as a hypothesis we get the final definition of CLK-0:
2131
; (IF (AND (HYPS S) (PROGRAM1P S))
2135
; (WR :LOCALS (UPDATE-NTH 1 1
2142
; Similarly, we see that the semantic function SEM-0 is just a call to the
2143
; semantic function for pc 6 applied to s[6]. So we get
2146
; (IF (AND (HYPS S) (PROGRAM1P S))
2150
; :LOCALS (UPDATE-NTH 1 1
2157
; We can derive these preliminary definitions for CLK-0 and SEM-0 even before
2158
; we define CLK-6 and SEM-6 because we know what names we'll use for the clock
2159
; and semantic functions for any given starting pc: CLK-pc and SEM-pc.
2161
; Here is the path-tree produced by simulating forward from pc = 6 to the next
2164
; (IF (EQUAL (NTH 0 (RD :LOCALS S)) 0)
2165
; (ACL2::CODEWALKER-TIP
2167
; '(6 7 21 22) ; path with t(erminal)pc = 22
2169
; (WR :PC 22 ; final state
2170
; (WR :STACK (PUSH (NTH 1 (RD :LOCALS S))
2173
; (ACL2::CODEWALKER-TIP
2175
; '(6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 6) ; path with tpc = 6
2177
; (WR :PC 6 ; final state
2178
; (WR :LOCALS (UPDATE-NTH 0 (+ (NTH 0 (RD :LOCALS S))
2179
; (- (NTH 3 (RD :LOCALS S))))
2180
; (UPDATE-NTH 1 (* (NTH 0 (RD :LOCALS S))
2181
; (NTH 1 (RD :LOCALS S)))
2182
; (UPDATE-NTH 2 (+ (NTH 0 (RD :LOCALS S))
2183
; (NTH 2 (RD :LOCALS S)))
2187
; Given that pc = 22 is known to be a halt (or exit from the region of
2188
; interest), we know there are no clock and semantic functions for it.
2190
; So, given that the path-tree above starts in a state satisfying (hyps s) and
2191
; (program1p s) with pc = 6, it is pretty obvious how to define CLK-6 and
2194
; * CLK-6: Visit the CODEWALKER-TIP expressions. At each, let tpc be the
2195
; terminal cutpoint (e.g., 22 in the first tip above and 6 in the second).
2196
; If tpc is a halt pc (tpc = 22) replace that CODEWALKER-TIP by the step
2197
; count (e.g., 3) and otherwise (tpc = 6) replace that CODEWALKER-TIP by
2198
; the CLK-+ of the step count (15) and a call of CLK-tpc (CLK-6) on the
2199
; final state in the tip.
2201
; * SEM-6: Visit the CODEWALKER-TIP expressions. At each, let tpc be the
2202
; terminal cutpoint (e.g., 22 in the first tip above and 6 in the second).
2203
; If tpc is a halt pc (tpc = 22) replace that CODEWALKER-TIP by the final
2204
; state in the tip, and otherwise (tpc = 6) replace that CODEWALKER-TIP by
2205
; a call of SEM-tpc (e.g., SEM-6) on the final state in tip.
2207
; Implicit in the descriptions above is the addition of an additional IF
2208
; testing (hyps s) and (program1p s) and laying down the body described above
2209
; if those extended hypotheses are true. In the case that they are false, we
2210
; lay down either 0 or s, depending on whether we're defining a clock or a
2211
; semantic function.
2213
; Now the ``definitions'' described above are still not quite right because
2214
; they do not record the fact that reg[3] is always +1 in CLK-6 and SEM-6. If
2215
; that fact is not discovered and recorded in the definition somewhere, then
2216
; the definitions won't be admissible because the only thing even possibly
2217
; decreasing is reg[0] and the CLK-6 and SEM-6 described above recur by
2218
; replacing reg[0] by reg[0] - reg[3], for an unknown value of reg[3]. So the
2219
; definitions derived above are considered ``preliminary.''
2221
; We discover that reg[3] = +1 in SEM-6 (say) by noting that the preliminary
2222
; definition of SEM-0 calls SEM-6 with reg[3] = +1 and that SEM-6 does not
2223
; change reg[3] (and no other function calls SEM-6). Having discovered this
2224
; invariant, we conjoin it into the extended hyps test, and get the final
2225
; definition of SEM-6.
2227
; The resulting final definitions are shown below (with DECLAREs and
2228
; non-logical noise deleted). Compare these two to the path-tree for pc 6
2234
; (EQUAL (NTH 3 (RD :LOCALS S)) 1))
2236
; (EQUAL (NTH 0 (RD :LOCALS S)) 0)
2242
; (WR :LOCALS (UPDATE-NTH 0 (+ (NTH 0 (RD :LOCALS S))
2243
; (- (NTH 3 (RD :LOCALS S))))
2244
; (UPDATE-NTH 1 (* (NTH 0 (RD :LOCALS S))
2245
; (NTH 1 (RD :LOCALS S)))
2246
; (UPDATE-NTH 2 (+ (NTH 0 (RD :LOCALS S))
2247
; (NTH 2 (RD :LOCALS S)))
2255
; (EQUAL (NTH 3 (RD :LOCALS S)) 1))
2256
; (IF (EQUAL (NTH 0 (RD :LOCALS S)) 0)
2258
; (WR :STACK (PUSH (NTH 1 (RD :LOCALS S))
2263
; (WR :LOCALS (UPDATE-NTH 0 (+ (NTH 0 (RD :LOCALS S))
2264
; (- (NTH 3 (RD :LOCALS S))))
2265
; (UPDATE-NTH 1 (* (NTH 0 (RD :LOCALS S))
2266
; (NTH 1 (RD :LOCALS S)))
2267
; (UPDATE-NTH 2 (+ (NTH 0 (RD :LOCALS S))
2268
; (NTH 2 (RD :LOCALS S)))
2273
; The correctness theorems for the functions are easy to generate. Just
2274
; consider what it is, say for pc = 6:
2276
; (DEFTHM SEM-6-CORRECT
2277
; (IMPLIES (AND (HYPS S)
2279
; (EQUAL (RD :PC S) 6))
2280
; (EQUAL (M1 S (CLK-6 S))
2283
; Of course, the functions for the loops must be defined before the top-level
2284
; functions, CLK-0 and SEM-0, and the correctness theorem for SEM-6 must be
2285
; proved before that for SEM-0. So implicit in the actual submission of these
2286
; events is determining the call ordering of the definitions.
2288
; If you inspect basic-demo.lsp you will see a trace$ command, just before
2289
; def-semantics. The trace$ command has been commented out. If you undo back
2290
; through the def-semantics, execute the trace$ command, and re-run
2291
; def-semantics you will see some of the internals of def-semantics in action.
2292
; We recommend that you only inspect the top-level entry and exit of the traced
2293
; functions (the entries labeled ``1>'' and ``<1'').
2295
; This completes our sketch of how def-semantics works. We have left
2296
; out a lot! We provide more details in the next section ... and complete
2297
; details in the code.
2299
; We now move on to the def-projection commands illustrated in A Friendly
2300
; Introduction to Codewalker section above.
2302
; For convenience, here is the user's definition of the state invariant, (hyps
2306
; (declare (xargs :stobjs (s)))
2309
; (< (rd :pc s) (len (rd :program s)))
2310
; (< 16 (len (rd :locals s)))
2311
; (natp-listp (rd :locals s))
2312
; (natp-listp (rd :stack s))))
2314
; Now we turn to the question of ``projecting'' the result of a given semantic
2315
; function so we can more easily understand what that function's effect is on a
2316
; given state component. Let's start with SEM-6 and consider its effect on
2317
; reg[1], i.e., (nth 1 (rd :locals s)). It helps to see the definition of SEM-6:
2322
; (EQUAL (NTH 3 (RD :LOCALS S)) 1))
2323
; (IF (EQUAL (NTH 0 (RD :LOCALS S)) 0)
2325
; (WR :STACK (PUSH (NTH 1 (RD :LOCALS S))
2330
; (WR :LOCALS (UPDATE-NTH 0 (+ (NTH 0 (RD :LOCALS S))
2331
; (- (NTH 3 (RD :LOCALS S))))
2332
; (UPDATE-NTH 1 (* (NTH 0 (RD :LOCALS S))
2333
; (NTH 1 (RD :LOCALS S)))
2334
; (UPDATE-NTH 2 (+ (NTH 0 (RD :LOCALS S))
2335
; (NTH 2 (RD :LOCALS S)))
2340
; Suppose we want to project (nth 1 (rd :locals s)) from SEM-6 and name the
2341
; resulting function FN1-LOOP. (Def-Projection requires the user to name each
2342
; function being introduced because the point of def-projection is to allow the
2343
; user to understand the effects of a piece of code. It helps if names ``make
2344
; sense'' to the user. Our naming convention in this example is that ``FN1''
2345
; refers to to the function that computes the final value of reg[1] and
2346
; ``LOOP'' refers to the fact that it does so starting from the loop in the
2349
; Of course, we could just
2351
; (defun fn1-loop (s) (nth 1 (rd :locals (sem-6 s))))
2353
; but that is not very illuminating. Our goal is for fn1-loop to actually
2354
; compute the final value of reg[1] using just what it needs from state s and no
2355
; more. In particular, it should not take state as an argument! It should
2356
; take just the values of whatever state components are necessary to compute
2357
; the final reg[1] -- and no others.
2359
; The first step is to create the expression (nth 1 (rd :locals (sem-6 s))),
2360
; expand the call of sem-6, and simplify. The result is:
2362
; (if (equal (nth 3 (rd :locals s)) 1)
2363
; (if (equal (nth 0 (rd :locals s)) 0)
2364
; (nth 1 (rd :locals s))
2365
; (NTH 1 (RD :LOCALS
2368
; (wr :locals (update-nth 0 (+ -1 (nth 0 (rd :locals s)))
2369
; (update-nth 1 (* (nth 0 (rd :locals s))
2370
; (nth 1 (rd :locals s)))
2371
; (update-nth 2 (+ (nth 0 (rd :locals s))
2372
; (nth 2 (rd :locals s)))
2375
; (nth 1 (rd :locals s)))
2377
; Note: A careful look at SEM-6 reveals that in its recursion, register 0 is
2378
; replaced by (+ (NTH 0 (RD :LOCALS S)) (- (NTH 3 (RD :LOCALS S)))), not (+ -1
2379
; (nth 0 (rd :locals s))) as shown above. The reason for the difference is
2380
; that there is a governing hypothesis that (NTH 3 (RD :LOCALS S)) is 1. One
2381
; might ask why that hypothesis wasn't used to further simplify the definition
2382
; of SEM-6. The reason is that we discovered the invariant that (NTH 3 (RD
2383
; :LOCALS S)) is 1 in this function after producing the preliminary body and we
2384
; don't bother to further simplify the body after adding that invariant.
2386
; Recall our goal is to define a new function FN1-LOOP and the expression above
2387
; is the beginning of a body for it. There are two things to note about this
2388
; expression. First, the occurrence of the expression
2390
; (NTH 1 (RD :LOCALS
2394
; suggests that that is the place where the new function, FN1-LOOP, will be
2395
; called recursively, since this expression denotes the value of reg[1] in
2396
; another call of SEM-6. There may be multiple places in the evolving body
2397
; where we call FN1-LOOP recursively. So it is handy to just abstract away
2398
; those places, enumerating them with unquoted numbers, and build a table
2399
; associating the numbers with the corresponding <new-s>. So we build the
2400
; ``term'' shown below for the abstracted body (with the ``unquoted numbers''
2401
; here preceded by ``#'' hash marks):
2403
; (if (equal (nth 3 (rd :locals s)) 1)
2404
; (if (equal (nth 0 (rd :locals s)) 0)
2405
; (nth 1 (rd :locals s))
2407
; (nth 1 (rd :locals s)))
2409
; where we know that #0 denotes a recursive call on
2411
; <new-s> = (wr :pc 6
2412
; (wr :locals (update-nth 0 (+ -1 (nth 0 (rd :locals s)))
2413
; (update-nth 1 (* (nth 0 (rd :locals s))
2414
; (nth 1 (rd :locals s)))
2415
; (update-nth 2 (+ (nth 0 (rd :locals s))
2416
; (nth 2 (rd :locals s)))
2420
; The second important thing to note about this evolving body is that outside
2421
; of the ``recursive call(s)'' -- that is, in the abstracted body above -- we
2422
; see three state components. These three state components will become
2423
; variables in the definition we're writing:
2425
; state component outside #0 new variable name to be used
2427
; (nth 0 (rd :locals s)) R0
2428
; (nth 1 (rd :locals s)) R1
2429
; (nth 3 (rd :locals s)) R3
2431
; These variable names are generated by the :var-names setting in the API.
2433
; But those state components (or variables, as they'll become) refer to the
2434
; final values after the recursion implicit at #0. Furthermore, to compute the
2435
; final values of those components/variables variables we have to track how
2436
; they change in the recursive call. The recursive call of the function we're
2437
; writing will NOT be on <new-s> but on the new values of the relevant state
2440
; So an important next step is to figure out the values of the relevant state
2441
; components in the <new-s> at each enumerated recursive call site, by
2444
; (NTH 0 (RD :LOCALS <new-s>)),
2445
; (NTH 1 (RD :LOCALS <new-s>)), and
2446
; (NTH 3 (RD :LOCALS <new-s>)).
2448
; Using the notation ``comp <-- val'' to mean ``state component comp is replaced
2449
; in recursion by expression val'' we learn:
2451
; (NTH 0 (RD :LOCALS s)) <-- (+ -1 (NTH 0 (RD :LOCALS S)))
2452
; (NTH 1 (RD :LOCALS s)) <-- (* (NTH 0 (RD :LOCALS S)) (NTH 1 (RD :LOCALS S)))
2453
; (NTH 3 (RD :LOCALS s)) <-- (NTH 3 (RD :LOCALS s)).
2455
; It could be that the new value of one of our ``relevant vars'' in recursion
2456
; is determined by some state component heretofore not identified as relevant.
2457
; So we must iterate the identification of relevant components and what their
2458
; new values are, until we have closed the set. In this example, the relevant
2459
; component was initially just that named reg[1], it became reg[0], reg[1],
2460
; reg[3], and that is closed. So we don't track how reg[2] changes.
2462
; So, after using :var-names to generate the new variable names for reg[0],
2463
; reg[1], and reg[3], namely R0, R1, and R3, we get the actuals at this call
2470
; We then introduce the recursive calls of the function we're defining,
2471
; FN1-LOOP, at the enumerated sites, on the new actuals. So #0 is replaced by
2472
; (FN1-LOOP (+ -1 R0) (* R0 R1) R3).
2474
; We also endeavor to capture the restrictions on the relevant state
2475
; components/variables imposed by the state invariant and the user's
2476
; declarations of the types of certain components. By ``capture the
2477
; restrictions ... imposed by the state invariant'' we mean ``what does (and
2478
; (hyps s) (program1p s)) tell us about R0, R1, and R3?'' Of course, it tells
2479
; us nothing about those variables! But it does tell us things about (nth 0
2480
; (rd :locals s)), etc. The question is how do we isolate from (and (hyps s)
2481
; (program1p s)) just the parts about the relevant state components? We
2482
; explain later but it is an important step because the termination of SEM-6
2483
; probably depends on some parts of the ``good state invariant'' and thus the
2484
; termination of FN1-LOOP will probably depend on the parts of that invariant
2485
; about these components.
2487
; Moving on, for sanity we want the formal parameters of FN1-LOOP to be in
2488
; alphabetical order. But we initially don't know what all the parameters are.
2489
; So we actually build expressions with the actuals of FN1-LOOP in the ``wrong
2490
; order'' and then build a ``permutation map'' to tell us how we swap arguments
2491
; to put them into order by formal name, and apply that map to all of our
2492
; definitions when we're done.
2494
; When we are done, the definition of FN1-LOOP is:
2496
; (DEFUN FN1-LOOP (R0 R1 R3)
2497
; (COND ((OR (NOT (INTEGERP R3))
2499
; (NOT (INTEGERP R0))
2501
; (NOT (INTEGERP R1))
2504
; ((OR (NOT (EQUAL R3 1)) (EQUAL R0 0))
2506
; (T (FN1-LOOP (+ -1 R0) (* R0 R1) 1))))
2508
; Note that the definition does not track the changes to R2: it is not relevant
2509
; to the final value of R1.
2511
; The correctness theorem reveals and records the mapping from state components
2514
; (DEFTHM FN1-LOOP-CORRECT
2515
; (IMPLIES (AND (HYPS S) (PROGRAM1P S))
2516
; (EQUAL (NTH '1 (RD ':LOCALS (SEM-6 S)))
2517
; (FN1-LOOP (NTH '0 (RD ':LOCALS S))
2518
; (NTH '1 (RD ':LOCALS S))
2519
; (NTH '3 (RD ':LOCALS S))))))
2521
; There is one more subtlety worth pointing out. Suppose we've done the
2522
; projection above and then apply this same technique to derive the value of R1
2523
; starting from SEM-0, defining the new function FN1. We form
2525
; (NTH 1 (RD :LOCALS (SEM-0 S)))
2527
; and then expand SEM-0 and simplify under (hyps s). The result is:
2529
; (NTH 1 (RD :LOCALS (SEM-6 <new-s>))).
2531
; But what we want is for this expression to be replaced by:
2533
; (FN1-LOOP (NTH 0 (RD :LOCALS <new-s>))
2534
; (NTH 1 (RD :LOCALS <new-s>))
2535
; (NTH 3 (RD :LOCALS <new-s>)))
2537
; So that we can then replace the state components ``outside'' the recursive
2538
; calls -- there aren't any recursive calls of (NTH 1 (RD :LOCALS (SEM-0
2539
; ...)))) -- and derive the preliminary definition of (FN1 R0) to be (FN1-LOOP
2540
; R0 1 1) which we then protect with the tests from (hyps s) to get:
2543
; (IF (OR (NOT (INTEGERP R0)) (< R0 0))
2545
; (FN1-LOOP R0 1 1)))
2547
; But how does def-projection introduce FN1-LOOP? How does def-projection know
2548
; that the register 1 projection of SEM-6,
2550
; (nth 1 (rd :locals (SEM-6 <new-s>))),
2552
; is computed by an already projected function, namely:
2554
; (FN1-LOOP (NTH 0 (RD :LOCALS <new-s>)) ...)?
2556
; The answer is really simple: Since FN1-LOOP was proved correct with the
2557
; FN1-LOOP-CORRECT theorem shown above, and since that theorem is now in the
2558
; :rewrite rule database, it is applied as we simplify
2560
; (NTH 1 (RD :LOCALS (SEM-0 S)))
2562
; after SEM-0 is expanded.
2564
; Finally, it is possible that we have not yet projected a given component from
2565
; a given semantic function occurring in the body of the semantic function
2566
; we're trying to project. If this occurs, the ``final'' body described above
2567
; will still contain other semantic functions. (Imagine trying to project R1
2568
; from sem-0 before we have projected R1 from sem-6.) We detect this and
2569
; advise the user to project that component from that other semantic function
2570
; first. We could, in principle, do it recursively, but we prefer the user to
2571
; name each projection.
2573
; This completes the walk through of a def-projection example.
2575
; =============================================================================
2576
; Guide to the Implementation of Codewalker
2578
; -----------------------------------------------------------------------------
2579
; Background on Supporting Books
2581
; The Codewalker book depends on three supporting books:
2584
; simplify-under-hyps.lisp
2585
; terminatricks.lisp
2587
; The first two provide us with the ability to simplify a term under some
2588
; hypotheses and recover an equivalent term. This is a bit tricky since the
2589
; ACL2 simplifier splits terms into clauses. The challenge, overcome by
2590
; if-tracker and simplify-under-hyps, is to take the resulting set of clauses
2591
; and reassemble a term, minus the hypotheses that were assumed.
2593
; The file terminatricks.lisp is the current incarnation of the Terminatricks
2594
; book. Terminatricks is documented with extensive comments but we sketch its
2595
; basic functionality here. Terminatricks provides the new macros DEFUNM and
2596
; DEFUNM-NX which are like DEFUN and DEFUN-NX except do not require :measures.
2597
; Instead, DEFUNM and DEFUNM-NX use heuristics to try to guess an appropriate
2598
; measure for the definition. These heuristics are derived from a table of
2599
; ``measure patterns'' that look for certain subterms in the proposed
2600
; definitions and conjecture the relevance of certain measures. The measure
2601
; patterns table may be augmented directly by the user but most often it is
2602
; augmented by mining DEFUN events for which a user supplied an explicit
2605
; Given a table of measure patterns and a proposed definition, Terminatricks
2606
; first collects every measure that is suggested for each call and its
2607
; governing tests. Then it attempts to prove, on a call-by-call basis, that
2608
; suggested measures decrease or do not increase. Finally, it attempts to
2609
; piece together lexicographic orderings of measures to explain all the calls.
2611
; Codewalker uses the Terminatricks facilities often and freely. In
2612
; particular, Codewalker generates clock, semantic, and projection functions
2613
; and -- unless user-supplied hints provide :measures -- DEFUNM/DEFUNM-NX is
2614
; used to admit them. So Codewalker critically depends on Terminatricks to
2615
; figure out why these functions terminate. Unfortunately, Terminatricks is
2616
; not as powerful as it might be -- the problem is, after all, undecidable! So
2617
; sometimes we see def-semantics or def-projection fail, when in fact the
2618
; failure ``belongs'' to Terminatricks.
2620
; Terminatricks introduces two concepts that are used directly in Codewalker.
2621
; The concepts are that of ``virtual formal'' (or ``vformal'') and the
2622
; associated idea of a ``call on virtual formals'' more often referred to
2623
; (misleadingly) as a ``virtual call''. Suppose st is a list of numbers and
2624
; you see a recursive function like:
2627
; (if (zp (nth 2 st))
2629
; (foo (update-nth 1 (+ (nth 1 st) (nth 2 st))
2630
; (update-nth 2 (+ (nth 2 st) -1)
2633
; Clearly, the decreasing measure is (acl2-count (nth 2 st)). But ACL2's
2634
; native DEFUN will not guess this, even though it would have no trouble with:
2636
; (defun foo' (n1 n2)
2639
; (foo' (+ n1 n2) (+ n2 -1))))
2641
; We call (nth 1 st) and (nth 2 st) of foo above ``virtual formals'' or
2642
; ``vformals''. Technically, a virtual formal is any structure component that
2643
; is being tested or changed in a definition, where the notion of a
2644
; ``component'' is as described by two Terminatricks tables
2645
; generalized-updater-drivers and constructor-drivers, which we discuss further
2646
; below. (The former table contains the :updater-drivers setting from your
2647
; API, the latter contains the :constructor-drivers.)
2649
; See changed-virtual-formal-slots in terminatricks.lisp for the function that
2650
; computes the vformals in a term.
2652
; It is convenient to re-represent some function calls to make the
2653
; virtual formals and their assignments more obvious. Given a call like:
2655
; (foo (update-nth 1 (+ (nth 1 st) (nth 2 st))
2656
; (update-nth 2 (+ (nth 2 st) -1)
2659
; we sometimes re-represent it as a ``call on virtual formals'' (or ``virtual
2662
; (foo (:slot (nth 1 st) (+ (nth 1 st) (nth 2 st)))
2663
; (:slot (nth 2 st) (+ (nth 2 st) -1)))
2665
; where, unlike normal calls, there may be different number of :slot
2666
; expressions in each virtual call of foo.
2668
; By explicitly identifying the state components being tested/manipulated in a
2669
; recursive function we make it a little easier to identify measures that are
2672
; The idea of virtual formals rears its head in Codewalker at the
2673
; user-interface level because Codewalker uses Terminatricks and Terminatricks
2674
; uses the two tables, generalized-updater-drivers and constructor-drivers
2675
; described below, to identify virtual formals. It also arises in the
2676
; description of the implementation of Codewalker because Codewalker detects
2677
; certain trivial invariants by analyzing calls on virtual formals.
2679
; -----------------------------------------------------------------------------
2680
; Data Structures Driving Codewalker
2682
; Three tables drive Codewalker. These tables are set by the def-model-api
2683
; command. The model API is a record that tells Codewalker such things as:
2685
; - the name of the run function
2686
; - the name of the step function
2687
; - the name of the state variable and whether it is a stobj
2688
; - how to set the pc in a state
2689
; - how to retrieve the pc from a state
2690
; - how to add two clocks together
2692
; This API allows Codewalker (both def-semantics and the def-projection
2693
; command) to access the functionality of the machine model, without building
2694
; in any particular model (e.g., X86, PCODE, M1, etc.). The various fields of
2695
; an API are supplied in untranslated form to def-model-api, which translates
2696
; and error checks the fields and stores them into a record named model-api
2697
; which, in turn, is stored in a table of the same name.
2699
; See the defrec of model-api.
2701
; There are two other global data structures, both represented by tables. They
2702
; are actually used by Terminatricks but since Codewalker uses DEFUNM/DEFUNM-NX
2703
; they are also set by def-model-api from the fields of similar names. The two
2706
; generalized-updater-drivers
2707
; constructor-drivers
2709
; These are described and exemplified in terminatricks.lisp. But typical
2710
; settings for the two tables might be:
2712
; (table generalized-updater-drivers
2714
; '(((update-nth i :value :base) ; doublets consisting of
2715
; (nth i :base)) ; an update expression and
2716
; ((wrm offset size :value :base) ; corresponding access
2717
; (rdm offset size :base)) ; expression. Such expressions
2718
; ((!i :value :base) ; are typically nested in
2719
; (i :base)) ; the :base argument position
2720
; ((!s :value :base)
2723
; Obviously, in the model hinted at above, wrm writes a :value of size at
2724
; address offset in the memory of :base, and rdm reads it. Similarly,
2725
; !i sets the instruction pointer and i fetches it, and !s sets the status
2726
; flag and s fetches it.
2728
; (table constructor-drivers
2730
; '(((cons a b) ; lists consisting of a
2731
; (car :base) (cdr :base)))) ; constructor expression and
2732
; ; the corresponding n accessor
2733
; ; expressons. Accessors may
2734
; ; appear nested in the :base
2737
; From the perspective of Codewalker, the first table,
2738
; generalized-updater-drivers, is relevant if the state object in the model is
2739
; a stobj or, more generally, the model is in the ``state updater paradigm.''
2740
; By that we mean that whenever the model needs to describe a new state it does
2741
; so by ``updating'' the (an) old state, as by applying update-nth or, more
2742
; generally, a stobj or record updater.
2744
; The second table, constructor-drivers, is only relevant for machine models
2745
; that use the ``state constructor paradigm'' -- where each instruction's
2746
; semantics explicitly constructs a new state with CONS or some higher level
2747
; function like M1's MAKE-STATE.
2749
; Almost all practical ACL2 machine models are stobj-based and thus are in the
2750
; updater paradigm. But these tables are used by Terminatricks and
2751
; Terminatricks can be used independently of Codewalker. The second table is
2752
; needed anytime Terminatricks is dealing with functions that recur by CONSing.
2754
; An obvious flaw in the current implementation is that def-model-api transfers
2755
; the contents of :updater-drivers and :constructor-drivers to Terminatricks'
2756
; generalized-updater-drivers and constructor-drivers tables, without
2757
; preserving any entries already in those tables. A user who is using DEFUNM
2758
; to define functions might have configured Terminatricks tables to identify
2759
; the virtual formals in the kinds of functions being defined -- functions that
2760
; need not be manipulating the state of any particular model. If that user
2761
; then starts using Codewalker, the def-model-api will smash the carefully
2762
; constructed Terminatricks tables so they are suitable for the API in use but
2763
; possibly no longer suitable for the other kinds of functions the user may end
2764
; up defining with DEFUNM. It would be better if Codewalker somehow merged the
2765
; API's entries into the Terminatricks tables.
2767
; -----------------------------------------------------------------------------
2768
; Overviews of How the Def-Semantics and Def-Projection Commands Work
2770
; Below we give overviews of the steps taken by both def-semantics and
2771
; def-projection. Each step is identified by a token, (A.1), (A.2), ...
2772
; for def-semantics and (B.1), (B.2), ... for def-projection. After these two
2773
; high level sketches we detail each of the steps, repeating the tokens.
2774
; Finally, the Code itself sometimes refers to these tokens.
2776
; Overview of How Def-semantics Works
2778
; def-semantics works in seven main steps:
2780
; (A.1) compute a conservative (over-estimate of the) control flow graph of the
2783
; (A.2) identify loops and halts, the so-called ``cutpoints''
2785
; (A.3) simulate from cutpoint to cutpoint to get composed state transitions,
2786
; called path-tree expressions, along all paths
2788
; (A.4) compute reflexive-transitive closure of cutpoint-to-cutpoint relations
2789
; to construct a call graph, inducing an order on the clock and semantic
2792
; (A.5) define clock and semantic functions from the path-tree expressions;
2793
; this would be straightforward except for two important additions:
2794
; (A.5.1) identifying certain trivial invariants that may be crucial to
2796
; (A.5.2) removing mutual recursion.
2798
; (A.6) generate the correctness theorem relating the clock and semantic
2801
; (A.7) apply the user-supplied :annotations argument to the generated events
2803
; We deal with each step in turn below, repeating verbatim the enumerated header.
2806
; Overview of How the Def-Projection Command Works
2808
; The def-projection command works in eight main steps:
2810
; (B.1) given a projector term (specifying the state component of interest) and a
2811
; semantic function, create the term (projector (semantic st)), expand
2812
; the semantic function call and simplify
2814
; (B.2) find every state component referenced outside the projected recursive
2815
; calls and collect the state component and its type; these are the
2816
; initially relevant components
2818
; (B.3) replace all projected recursive calls of the semantic function by
2819
; unquoted naturals and build an alist mapping those naturals to the new
2820
; states inside those calls
2822
; (B.4) for each site, determine the new value of each of the relevant state
2823
; components in the new state at that site; close the set of relevant
2824
; components by iteration
2826
; (B.5) introduce calls of the new function at each site, generalizing the
2827
; relevant state components and their occurrences in the actuals
2829
; (B.6) determine the restrictions imposed by the invariant on the relevant state
2832
; (B.7) rearrange all the definitions' formals and calls so that formals are
2833
; in alphabetical order
2835
; (B.8) determine whether there are other projected state components that
2836
; still occur in the body and if so cause an error
2838
; -----------------------------------------------------------------------------
2839
; More Details on def-semantics
2841
; As noted, def-semantics works in seven main steps. Below we repeat
2842
; verbatim the ``A'' headers describing each step and elaborate a little.
2845
; (A.1) compute a conservative (over-estimate of the) control flow graph of the
2848
; The first piece of functionality we develop is to build graphs that capture
2849
; (over approximate) control flow. The graph is represented by an adjacency
2850
; alist with entries of the form (pc . (pc_1 ... pc_k)) meaning the graph has a
2851
; directed edge from pc to each of the pc_i. We actually build two graphs,
2852
; one forward and one backwards.
2854
; In the forward link ``flink'' graph, an edge from pc to pc_i means that when
2855
; the instruction at pc is executed, the instruction at pc_i may be the next
2856
; instruction, e.g., control may transfer in one step from pc to pc_i. In the
2857
; backward link ``blink'' graph an edge from pc to pc_i means that the
2858
; instruction at pc may be the next instruction after the one at pc_i is
2859
; executed, i.e., control may reach pc in one step from pc_i.
2861
; In both cases, no context is kept. For example, if the instruction at pc
2862
; branches to either pc_1 or pc_2, then both are included in the flink graph
2863
; entry from pc, even if it turns out that context tracking and theorem proving
2864
; could show that the value of the test is known.
2866
; The two graphs are constructed by the function link-graphs. But the key
2867
; idea in the construction is the function next-pcs, which takes a given pc
2868
; value and simplifies the expression:
2870
; (get-pc (step (set-pc pc st)))
2872
; under the state invariant hypothesis (:hyps) provided to def-model-api. (By
2873
; the way, this idea of simplifying an expression under a hypothesis is used
2874
; repeatedly in this work and is managed by the function simplify-under-hyps
2875
; which is defined in the book of the same name.)
2877
; The result of that simplification should be an IF expression with a lot of
2878
; pcs at the tips. After the simplification, next-pc scans the IF-expression
2879
; and collects all the constant pcs, throwing away the tests since we carry
2880
; no context information forward from one instruction to the next in
2881
; constructing this conservative over-approximation flow graphs.
2883
; Suppose the instruction at pc 1 sets reg0 to 0 and advances to pc 2, and
2884
; suppose the instruction at pc 2 tests reg0 and branches to 3 or 30. In this
2885
; pass, we process the instruction at pc 1 independently of that at pc 2, i.e.,
2886
; we don't take the simplified state from pc 1 and carry in forward into pc 2.
2887
; So in this pass we say pc 1 transitions forward to pc 2 and that pc 2
2888
; transitions forward to either 3 or 30. If we simplified the instruction at
2889
; pc 2 with respect to the state produced by pc 1 we could detect that reg0 is
2890
; 0 and one branch would be pruned. But that risks state-explosion and
2891
; combinatoric problems before we even know where the loops are. The
2892
; overapproximation of the flow is set up in linear time since each instruction
2893
; is processed once, independently of all others.
2896
; (A.2) identify loops and halts, the so-called ``cutpoints''
2898
; Next, we wish to identify the ``loops,'' the ``branches,'' and the ``halts''
2899
; in the code. Loops are those pcs, x, such that one of the jumps to x is from
2900
; a pc greater than x, i.e., one of the jumps to x is a ``back jump.'' The
2901
; branches are where the forward flow diverges, i.e., where a pc in the forward
2902
; graph has multiple next pcs. (Note: The concept of branches is actually
2903
; irrelevant to our analysis. We thought we might need it and so compute it but
2904
; it turns out that as of codewalker.lisp, the concept is ignored.) The ``halts''
2905
; are places where the forward flow graph lists ONLY the pc itself as the next
2906
; pc. The ``cutpoints'' are the union of the loops and the halts plus the
2909
; Given that pcs need not always be numbers, e.g., (5 . 3) might be a pc in
2910
; some model, how do we determine whether one pc occurs before another? We use
2911
; lexorder! Thus, if one is coding up some ``strange'' notion of pc, code it
2912
; in such a way that (lexorder pc1 pc2) means that pc1 occurs before pc2 in
2913
; ``normal'' program flow. If this built-in sense of order is too specific we
2914
; could add some kind of ordering relation to the collection of functions
2915
; identified in the machine description API.
2917
; Instructions that may or may not change the pc are problematic. Such
2918
; behavior can mean different things. For example, consider a DIV instruction
2919
; which advances the pc if the denominator is non-0 but which does not change
2920
; the pc if the denominator is 0. DIV might even make other state changes,
2921
; such as setting an error condition somewhere in the state. So it is possible
2922
; for a useful instruction to not change the pc even though it changes other
2923
; state components. And it is not clear from the analysis of the pc alone
2924
; whether this is an error event or just an intermediate transition.
2926
; For a clear example of the ``intermediate transition,'', consider an
2927
; instruction which might be named POP-ACCUMULATE (or more likely, a block
2928
; transfer like instruction). Suppose POP-ACCUMULATE advances the pc if the
2929
; stack is empty and otherwise pops the stack, adds the item to the contents of
2930
; register a, but does NOT change the pc! One could use such an instruction to
2931
; sum the items on the stack. Repeated steps would eventually empty the stack
2932
; and advance the pc, but it would take as many clock cycles to complete as
2933
; there are items on the stack. It wouldn't actually be halting the machine
2934
; despite the unchanged pc, and it wouldn't even be an error event: it's just a
2935
; useful instruction that takes many cycles to complete.
2937
; The question then is how does def-semantics handle such problematic
2938
; instructions? In particular, what clock does it generate? Answer: when an
2939
; instruction doesn't change the pc, the clock stops. So this means def-semantics
2940
; handles DIV, above, correctly but is not quite appropriate for
2941
; POP-ACCUMULATE. If we could detect (or be told) that an instruction just
2942
; takes time to complete but doesn't REALLY halt the machine -- or if we could
2943
; be told that there is some error flag in the state that distinguishes these
2944
; two situations, we might improve the situation. These possibilities suggest
2945
; additions to the API but so far haven't been explored, as we haven't seen an
2946
; instruction like POP-ACCUMULATE and DIV is handled correctly by this
2949
; The function for identifying loops, etc, is categorize-pcs.
2952
; (A.3) simulate from cutpoint to cutpoint to get composed state transitions,
2953
; called path-tree expressions, along all paths
2955
; Next, given a list of all the cutpoints (entry pc plus the union of the loops
2956
; and the halts), we simulate forward from each cutpoint to the next cutpoint.
2957
; This simulation is compositional. That is, we start at a cutpoint and
2958
; repeatedly step, passing the new symbolic state expression into the next
2959
; instruction (risking state explosion) stopping only when we encounter another
2960
; cutpoint. We repeatedly rewrite and normalize -- as part of the normal ACL2
2961
; simplifier -- and thus create a (possibly large) IF-expression as we go
2962
; through multiple tests in the code. We want to keep track of the number of
2963
; steps taken and also the path pursued to reach each state at the tips of this
2966
; We do this with a fairly clever rewriting hack. In particular, we introduce
2967
; two functions, codewalker-wrapper and codewalker-tip, and three rewrite rules
2968
; to manipulate such expressions. Codewalker-tip expressions look like this:
2970
; (CODEWALKER-TIP k (pc_0 pc_1 pc_2 ... pc_k) splitters s-final)
2972
; and the function symbol itself is just defstub'd, i.e., left undefined. In
2973
; these codewalker-tip expressions k is the number of steps taken to get to the
2974
; final state reached, s-final, and list of pc_i show the path from the
2975
; cutpoint (pc_0) we started at to the pc, pc_k, of s-final.
2977
; CODEWALKER-WRAPPER, on the other hand, is a defined function whose definition
2978
; cannot be produced until we know the cutpoints -- so you won't find its
2979
; definition in the tag table! Instead, it is introduced internally to the
2980
; make-event, after we've classified the pcs as above. See wrapper-events
2981
; for the function that creates its definition, but the scheme is shown below.
2983
; CODEWALKER-WRAPPER expressions look like this:
2985
; (CODEWALKER-WRAPPER cnt rpath known-cutpoints splitters depth s)
2987
; which is defined to step s repeatedly until its pc is a member of
2988
; known-cutpoints. It counts the number of steps it takes and accumulates into
2989
; rpath (reversed path) the list of pcs it visits. It also accumulates into
2990
; splitters the pcs causing branches and increments depth until it reaches the
2991
; given *snorkel-depth*. When it reaches a known cutpoint, it replaces itself
2992
; with: a CODEWALKER-TIP expression.
2994
; The definition of CODEWALKER-WRAPPER and the three rules about it are shown
2995
; below, but it can't be expanded until we have the API for the machine
2996
; (telling us the functions for manipulating these machine states) and the
2997
; cutpoints. But the ``meta-definitions'' should be clear. We use the Common
2998
; Lisp back-quote notation below and you should understand ``,s'' to mean the
2999
; machine state name from the API and ``,get-pc'' to mean the term from the API
3000
; for fetching the current pc from the machine state.
3002
; (defun-nx codewalker-wrapper (cnt rpath known-cutpoints splitters depth ,s)
3003
; (declare (xargs :measure (nfix (- *snorkel-depth* (nfix depth)))))
3004
; (if (or (not (natp depth))
3005
; (>= depth *snorkel-depth*))
3006
; (codewalker-wrapper-snorkeler cnt rpath known-cutpoints
3007
; splitters depth s)
3008
; (if (or (member-equal ,get-pc rpath)
3010
; (member-equal ,get-pc
3011
; known-cutpoints)))
3012
; (codewalker-tip cnt
3013
; (revappend (cons ,get-pc rpath) nil)
3016
; (codewalker-wrapper (+ 1 cnt)
3017
; (cons ,get-pc rpath)
3023
; (defthm codewalker-wrapper-rule-1
3026
; (>= depth *snorkel-depth*))
3027
; (equal (codewalker-wrapper cnt rpath known-cutpoints
3028
; splitters depth ,s)
3029
; (codewalker-wrapper-snorkeler cnt rpath known-cutpoints
3030
; splitters depth ,s))))
3032
; (defthm codewalker-wrapper-rule-2
3035
; (< depth *snorkel-depth*)
3036
; (equal pc ,get-pc)
3037
; (syntaxp (quotep pc))
3038
; (or (member-equal pc rpath)
3040
; (member-equal pc known-cutpoints))))
3041
; (equal (codewalker-wrapper cnt rpath known-cutpoints
3042
; splitters depth ,s)
3043
; (codewalker-tip cnt
3044
; (revappend (cons pc rpath) nil)
3048
; (defthm codewalker-wrapper-rule-3
3051
; (< depth *snorkel-depth*)
3052
; (equal pc ,get-pc)
3053
; (syntaxp (quotep pc))
3054
; (not (or (member-equal pc rpath)
3056
; (member-equal pc known-cutpoints))))
3057
; (equal s1 (,step ,s))
3058
; (bind-free (update-codewalker-splitters
3059
; ,s s1 pc splitters)
3061
; (equal (codewalker-wrapper cnt rpath known-cutpoints
3062
; splitters depth ,s)
3063
; (codewalker-wrapper (+ 1 cnt)
3070
; As noted, these rules keep forcing us to step the machine until we reach a
3071
; cutpoint (or exhaust a natural number limit on the number of steps explored
3072
; along a path, or reach a pc that is not a constant). So by forming
3073
; `(CODEWALKER-WRAPPER '0 'NIL ',known-cutpoints nil 0 ,(make-fn-application
3074
; put-pc (list (kwote cutpoint) s))) and simpifying it under the hyps, we get a
3075
; normalized IF-expression with CODEWALKER-TIP terms at all the non-tested
3076
; exits. That is called a ``path-tree.''
3078
; The functions that build path-trees are path-tree-tuple-from-cutpoint and
3079
; path-tree-tuples-from-cutpoint-lst.
3082
; (A.4) compute reflexive-transitive closure of cutpoint-to-cutpoint relations
3083
; to construct a call graph, inducing an order on the clock and semantic
3086
; Each cutpoint gives rise to a (possibly) recursive function. E.g., if pc=4
3087
; is a cutpoint, there will be functions with names like CLK-4 and SEM-4.
3088
; Given a list of several cutpoints, in which order should their functions be
3089
; introduced? (From our current perspective, it suffices to treat the pcs
3090
; themselves as the function names.)
3092
; Suppose we have five cutpoints and there are simulated paths from one to
3093
; another as indicated by the graph:
3095
; ((1 2) (2 3) (3 4 5) (4 2) (5)).
3097
; This means that simulating forward from cutpoint 1 we reach cutpoint 2, from
3098
; 2 we reach 3, from 3 we reach both 4 and 5, etc. Each corresponds to a
3099
; function. In what order do we introduce those functions?
3101
; To determine the order we first compute the reflexive, transitive closure of
3102
; the cutpoint reachability relation, storing for each cutpoint the cutpoints
3103
; (somehow) reachable from it:
3105
; ((1 . (1 2 3 4 5)) ; meaning 1 (somehow) calls (1 2 3 4 5)
3111
; Then if we order these by subset, so 5 is defined first, then
3112
; 2, 3, and 4 which all have the same set of reachable cutpoints (and are thus
3113
; mutually recursive) and finally 1.
3115
; This is actually done in the Terminatricks book because Terminatricks uses
3116
; the same ordering technique to assign weights to mutually recursive
3119
; See the function call-graph-ordering. In particular,
3120
; (call-graph-ordering '((1 2) (2 3) (3 4 5) (4 2) (5)))
3122
; ((5) (2 3 4) (1)).
3125
; (A.5) define clock and semantic functions from the path-tree expressions;
3126
; this would be straightforward except for two important additions:
3127
; (A.5.1) identifying certain trivial invariants that may be crucial to
3129
; (A.5.2) removing mutual recursion.
3131
; Next, we build clock and semantic function definitions for each cutpoint from
3132
; the path-tree for that cutpoint.
3134
; Every path-tree corresponds to a cutpoint. Let the initial pc in the
3135
; path-tree be pc. Then we define a clock function, named something like
3136
; CLK-pc, and a semantic function, SEM-pc, that takes a state and returns a
3137
; state. For the clock function body, we take the path-tree and eliminate all
3138
; the codewalker-tips, leaving the tests in place and replacing the tips with
3139
; the sum of the step count to the tip plus a call of the CLK-pc' function,
3140
; where pc' is the pc at the tip. We do an analogous thing to produce the body
3141
; of the semantic functions except we replace the tips with the call of SEM-pc'.
3143
; (Of course, if the tip is a terminal cutpoint -- e.g., we've reached a HALT
3144
; or [eventually] a RETURN, or exited the region of code we're supposed to
3145
; explore -- we don't generate the CLK-pc' or SEM-pc' recursive calls and just
3146
; return the count or state as appropriate.
3148
; The functions that do this are: generate-clock-function-body and
3149
; generate-semantic-function-body.
3151
; However, the results they return are not exactly the ones ultimately
3152
; submitted by def-semantics! The results of the two functions above are called
3153
; the ``preliminary'' definitions of the clock and semantic functions. We
3154
; process them further:
3156
; (A.5.1) identifying certain trivial invariants that may be crucial to
3158
; (A.5.2) removing mutual recursion.
3160
; We sketch those two processes now.
3162
; Regarding (A.5.1) the ``trivial invariants,'' consider our initial example,
3163
; *program* above, in which the semantic function SEM-6 has a virtual call
3166
; (:slot (nth 0 (rd :locals st))
3167
; (- (nth 0 (rd :locals st)) (nth 3 (rd :locals st)))).
3169
; That is, in the colloquial, we are dealing with a recursion in which
3172
; Clearly, in the absence of additional information, this vformal is not
3173
; decreasing. But suppose that (nth 3 (rd :locals st)) is held constant in the
3174
; recursion of SEM-6 and suppose that in every external virtual call of SEM-6,
3175
; we have (:slot (nth 3 (rd :locals st)) 1). Then SEM-6 is subtracting 1 from
3176
; R0 as it recurs, it's just that the 1 is found as a constant value in some
3177
; other vformal, R3. We are prepared for a vformal to take on several
3178
; different constant values, e.g., R3 might be 1 or 2 in some function, but
3179
; never any other value.
3181
; We detect such ``disguised constants'' by processing the preliminary clock
3182
; and semantic function definitions with an iterative process that propagates
3183
; constant settings through a system of function definitions. We make two
3184
; really basic assumptions. First, the top-level entry to the system may be
3185
; called with any arguments (satisfying the state invariant :hyps) so external
3186
; context must be captured by the state invariant. Second, all the functions
3187
; in the system are called on the state and hence, if g calls f and certain
3188
; things are known about the status of various vformals in g, then those same
3189
; things are propagated to f unless they're overridden by explicit vformal
3190
; settings in the call of f from g. For example, if it can be deduced that
3191
; R3 = 1 in g and then g calls f with a virtual call of
3195
; then we know R3=1 in f, because the actual (not virtual) call of f from g is
3196
; on (f (wr :locals (update-nth 2 23 (rd :locals s)) s)), so everything we know in
3197
; g about state components of s are known to hold in f except those involving
3198
; components explicitly assigned in the call to f.
3200
; For every vformal we build an alist that pairs the vformal with either
3201
; :CHANGING, meaning we know nothing about it or with a true list of evgs,
3202
; meaning that in every call seen so far the vformal has one of those constant
3203
; values. We start by assuming all vformals used by the top-level entry are
3204
; :changing and repeatedly propagate this information (appropriately modified
3205
; via the virtual calls in that function) through all other functions. We stop
3206
; when the data collected from one pass is the same as that from the last. We
3207
; keep the collected constants in lexorder to insure that an equality test will
3208
; suffice. We also build in a maximum number of iterations, just in case.
3209
; When we finish, we have, for every function (pc) in the system, a data
3210
; structure that tells us all the vformals that are always (one of several)
3211
; constants in every call of that function. We then turn those discoveries
3212
; into hypotheses about each function, e.g., (member (nth 3 (rd :locals s)) '(1
3213
; 2)) whenever we're inside a given function, and then modify the preliminary
3214
; definition of each function by adding the discovered hypotheses to the state
3215
; invariant for each function. The relevant functions are:
3217
; generate-fn-to-pc-and-vcalls-alist -- transform preliminary defuns to just
3218
; their virtual calls
3220
; disguised-constant-4-tuple-lst -- identification of disguised constants and
3221
; their lexordered ranges in the form of a list of 4-tuples, each of the form
3222
; (fn pc v_i u'_i), where u'_i is the lexordered range of the disguised
3223
; constant v_i in fn (which was derived starting at pc).
3225
; disguised-constant-hyp -- creates a hyp expressing the discovered invariants
3227
; modify-hyps-in-defun-pairs -- adds the discovered hyp to the preliminary
3230
; Regarding (A.5.2) the handling of mutual recursion, it should be noted that
3231
; mutually recursive clock and semantic functions occur when we encounter
3232
; nested loops. For example, the semantic function for the outer loop will
3233
; call that for the inner, and that for the inner will call back to the outer
3234
; when it is done. But ACL2 does not handle mutual recursion well: it cannot
3237
; So we transform mutually recursive defuns of clock and semantic functions
3238
; into singly-recursive definitions that use the pc as the flag. This is done
3239
; toward the very end of the processing. In particular, all the analysis
3240
; described above takes place on ``function symbols'' that are (in principle)
3241
; mutually recursive. So, for example, SEM-2 may call itself and SEM-10 and
3242
; SEM-10 may similarly call itself and SEM-2. Even the names SEM-2 and SEM-10
3243
; are used to identify the functions being ``defined'' and their subroutines.
3244
; But after we have modified each function definition with its discovered
3245
; disguised constant hypotheses, we look at the call-graph-ordering and may
3246
; determine that SEM-2 and SEM-10 are mutually recursive. At that point we
3247
; invent a new name, e.g., SEM-2-10, and create a new body by combining (and
3248
; renaming the functions called within) the bodies of the two functions. This
3249
; mapping of several distinct proto-function definitions into one is done by
3250
; apply-call-graph-ordering-to-defun-pairs, which uses the function
3251
; transform-to-singly-recursive to do the transformation the name suggests.
3252
; There is an essay about that transformation in the code.
3254
; The results are a list of DEFUNM/DEFUNM-NX events, in the right order, for
3255
; the clock and semantic functions.
3258
; (A.6) generate the correctness theorem relating the clock and semantic
3261
; The final step in this whole process is to generate the correctness theorems.
3262
; This is pretty simple: for every cutpoint we know the clock and semantic
3263
; function, and we know the initial pc and the state invariant, hyps. So the
3264
; correctness theorem is
3266
; (implies (and ,@hyps
3267
; (equal (get-pc st) pc))
3268
; (equal (run st (clk-pc st))
3271
; The correctness theorem is generated by generate-correctness-theorem.
3273
; Of course, if SEM-2 and SEM-10 are mutually recursive, then instead of
3274
; generating the theorem above (which would be about those non-existent
3275
; function symbols) we generate the corresponding theorem about clk-2-10 and
3278
; Then, cleverly, Terminatricks knows how to guess weights on the flags so help
3279
; find a measure that decreases.
3282
; (A.7) apply the user-supplied :annotations argument to the generated events
3284
; def-semantics allows the user to specify some :annotations that may
3285
; modify the automatically generated events.
3287
; Annotations will be an alist and each pair in it will be of one of two
3290
; (name (DECLARE ...)) -- means that name is the name of a generated defun-like
3291
; event and the automatically generated declarations are to be replaced in
3292
; their entirety by the given DECLARE form. Furthermore (!!!), the DEFUNM-NX
3293
; that would have been generated becomes a standard ACL2 DEFUN-NX! That is,
3294
; providing an entire DECLARE means that the user is using def-semantics to
3295
; generate the body but is taking over the admission entirely.
3297
; (name :keyword . rest) -- means different things depending on what sort of
3298
; generated event has the given name.
3300
; * If name is defun-like, :keyword and everything following it is added to
3301
; the front of the automatically generated XARGS, so that (DECLARE (XARGS
3302
; . auto-xargs)) becomes (DECLARE (XARGS :keyword ,@rest . auto-xargs))
3303
; Thus, adding an :in-theory (for example) annotation means that the user
3304
; is just telling def-semantics to go ahead with its guesses but here are some
3307
; * If name is a defthm, :keyword must be :hints and it and everything
3308
; following it are added to the generated defthm in the :hints position.
3310
; Note that we don't actually know what sort of event name there is until we're
3311
; asked to add the appropriate annotation. So our pre-processing error
3312
; checking on annotations is limited. However, when we attempt to use an
3313
; annotation pair we check more and might cause a hard error.
3315
; The application of :annotations to the generated events is scattered around
3316
; the code in the functions:
3318
; generate-clock-function-defun-pair
3319
; generate-semantic-function-defun-pair
3320
; transform-to-singly-recursive
3321
; generate-correctness-theorem
3323
; In general, to find these locations, search for :annotations, specifically
3324
; where we (assoc-eq :annotations dsem-alist) which is the idiom for extracting
3325
; the translated annotations from the alist holding all the arguments to
3328
; This completes the sketch of how def-semantics works.
3331
; More Details on the Def-Projection Command
3333
; As noted, the def-projection command works in eight main steps. Below we
3334
; repeat verbatim the headers describing each step and elaborate a little.
3337
; (B.1) given a projector term (specifying the state component of interest) and a
3338
; semantic function, create the term (projector (semantic st)), expand
3339
; the semantic function call and simplify
3341
; A projector term must be a state component pattern in the state variable.
3342
; A typical projector is (nth 3 (rd :locals s)), where s is the state variable
3345
; Projectors can only be applied to semantic functions: functions of one state
3346
; argument, namely the state variable. Semantic functions are generally
3347
; created by def-semantics.
3349
; To carry out this first step, we substitute the body of the semantic function
3350
; for the state variable in the projector and then use simplify-under-hyps to
3351
; simplify that term under the state invariant.
3353
; See apply-projector-to-term.
3356
; (B.2) find every state component referenced outside the projected recursive
3357
; calls and collect the state component and its type; these are the
3358
; initially relevant components
3360
; We will eventually make up a variable name for each relevant state component
3361
; referenced outside the projected recursive calls. Roughly speaking, these
3362
; new variables will become the formals of the new function to be defined.
3363
; However, to determine the final values of those components, we have to track
3364
; their changes through each recursion and make sure that the new function
3365
; makes those same changes to the corresponding formals. The set of state
3366
; components identified here can be thought of as controlling the termination
3367
; tests and the base case. But those components constitute just the initial
3368
; set of relevant components; the set will be have to be closed under
3369
; recursion. That is, if R0 and R1, say, are used in the test and base, but
3370
; the recursion sets R1 to R1 * R2, then we also have to make a formal for R2
3371
; and track it. That is done later.
3373
; In addition, we want to allow the user to assert restrictions on the state
3374
; components, possibly stronger restrictions than those imposed by the state
3375
; invariant -- or restrictions that are intrinsic to the state accessors and so
3376
; cannot be captured in the invariant. (There is an Essay On Identifying State
3377
; Components and their Types in the code that elaborates this vague idea.) So
3378
; as we scan the simplified projected semantic function body to collect the
3379
; initially relevant state components we also collect their user-declared
3382
; See find-all-state-components-and-types-outside.
3385
; (B.3) replace all projected recursive calls of the semantic function by
3386
; unquoted naturals and build an alist mapping those naturals to the new
3387
; states inside those calls
3389
; We copy term, replacing ``projected recursive calls'' of the semantic
3390
; function by integers (not quoted evgs!) and build an alist pairing those
3391
; integers with the next states found within the ``projected recursive calls.''
3392
; The projected recursive calls are calls of the given semantic function symbol
3393
; surrounded by the projector, e.g., (NTH '1 (RD :LOCALS (sem-fn s'))).
3395
; For example, given the term
3399
; (NTH '1 (RD :LOCALS (sem-fn s')))
3400
; (NTH '1 (RD :LOCALS (sem-fn s''))))
3403
; where the projector term is (NTH '1 (RD :LOCALS S)) and s, s' and s'' are
3404
; various state expressions, we'd return:
3411
; '((1 . s'') (0 . s')))
3413
; Note that if the returned alist is nil there are NO calls of sem-fn term.
3414
; This could happen in several ways but we suspect the two most common are
3415
; because the code concerned is straight-line or because the code enters an
3416
; already analyzed loop after some preamble. By the way, it is possible for
3417
; term (and hence the returned term') to be constant: e.g., the code enters an
3418
; already-analyzed loop on known values and the simplifier just computes it
3421
; See enumerated-projected-body.
3424
; (B.4) for each site, determine the new value of each of the relevant state
3425
; components in the new state at that site; close the set of relevant
3426
; components by iteration
3428
; Think of the state components that occur outside of the ``projected recursive
3429
; calls'' of the semantic function as an initial set of relevant components.
3430
; We have to determine how those components are changed in recursion. So, for
3431
; example, the ``outside'' components might be R0 and R1, but as the function
3432
; recurs, R1 might become R1+R2. That means that R2 is relevant to the final value
3433
; of R1, even though R2 does not occur ``outside.'' So the computation done
3434
; in this step is really in two phases.
3436
; First, given a set of so-far-recognized as relevant state components, we
3437
; collect their new values in each of the states occurring inside the
3438
; enumerated projected recursive calls. This is done by the function
3439
; components-and-types-to-actual-expressions-by-call. The determination of the
3440
; new value is done by applying the relevant state component to the state and
3441
; simplifying -- just another projection. It might be possible to do it by the
3442
; simpler mechanism of converting the state to a list of :SLOT expressions as
3443
; by changed-virtual-formal-slots (from Terminatricks), but it is not done that
3444
; way! One advantage of doing it the slow way, by simplification, is that we
3445
; thus take advantage of any previously proved projections -- something that we
3446
; think is necessary.
3448
; The second phase is to scan the resulting list of new values looking for new
3449
; state components -- ones that now become recognized as relevant -- and
3450
; iterating. This is done by the function
3451
; components-and-types-to-actual-expressions-by-call*.
3453
; A minor aspect of the code that is not described above is that for each state
3454
; component identified as relevant we also keep a term that restricts its
3455
; ``type'' as specified by the user when the state component patterns were
3456
; identified. These types eventually become part of the governing hypotheses
3457
; of the function we'll define.
3460
; (B.5) introduce calls of the new function at each site, generalizing the
3461
; relevant state components and their occurrences in the actuals
3463
; Having closed the set of relevant components, we next produce a new formal
3464
; variable name for each component, turn each enumerated projected recursive
3465
; call into a call of the about-to-be-defined new function on the relevant
3466
; actuals, and then generalize away the state components in favor of their
3467
; corresponding formal variable names. The construction of the call of the new
3468
; function symbol is done by the function make-fn-call-for-call-no.
3470
; New variable names are generated by vformal-to-variable-name and there is an
3471
; Essay on :var-names -- Two Ways for the User to Control the Generation of
3474
; Note that at this time, the actuals to the new function are listed in some
3475
; arbitrary order depending on the order in which they were discovered. (We
3476
; haven't actually paid attention to how they are ordered.) We'll permute them
3477
; into a sensible order before we submit the generated defun.
3479
; Having created, for each of the enumerated projected recursive call sites, a
3480
; call of the new function on the appropriate actuals expressed in terms of new
3481
; formal variable names, we go back into the abstracted body (produced by step
3482
; (B.3) above) and replace the unquoted evgs by the corresponding calls of the
3483
; new function and generalize the state components outside of those call sites
3484
; to their corresponding formals. This is done by
3485
; re-introduce-recursions-and-generalize.
3488
; (B.6) determine the restrictions imposed by the invariant on the relevant state
3491
; Naively, the definition of the new projection function will be protected by a
3492
; top-level test in its body on (hyps s), where hyps is the state invariant.
3493
; This is typically needed to make sure that whatever parts of the state
3494
; invariant insured termination of the semantic function is available for
3495
; termination of the new function.
3497
; But this is wrong because the new function will not take s as a formal, it
3498
; only takes the values of the relevant components of state, e.g., R0, R2, and
3499
; R7. Suppose that (nth 2 (rd :locals s)) is a relevant state component, which
3500
; will be known as R2 when it is a formal parameter. The question is, what
3501
; does (hyps s) tell us about (nth 2 (rd :locals s))? To find out, we
3502
; ``invert'' the state component, creating a term, s', that assigns R2 to that
3505
; (wr :locals (update-nth 2 R2 (rd :locals s)) s)
3507
; and we then simplify (hyps s') under the assumption of (hyps s). Presumably,
3508
; all the hypotheses about parts of s not changed in s' will be simplified away
3509
; and we'll be left with hypotheses about R2. Those are the hypotheses we will
3510
; put into the top-level test of the body of the new projector function.
3512
; This description is misleading only in that we ``invert'' all the relevant
3513
; state components in a single expression, s', e.g., assigning the new values
3514
; R0, R2, and R7 to the corresponding components of s, and simplify (hyps s')
3515
; under (hyps s), recovering all the hyps about the relevant components in one
3516
; big simplification.
3518
; See invariant-on-vformals.
3521
; (B.7) rearrange all the definitions' formals and calls so that formals are
3522
; in alphabetical order
3524
; For the user's sanity, we think it helps if the formals are listed in
3525
; alphabetical order. This is sensible since the user controls the naming of
3526
; the formals. For example, if registers are given the names R0, R1, R2, ...,
3527
; and the new function, fn, only uses R0, R2, and R7, it is easier to remember
3528
; that they're listed in ascending order than it is to remember some arbitrary
3529
; order. If we didn't do this, then the formals of fn might be (R7 R0 R2) and
3530
; when you saw a call like (fn a b c) you'd have to remember that ordering to
3531
; figure out that R0 has become expression b. (In fact, in earlier versions of
3532
; Codewalker we did not re-order and suffered exactly this problem.)
3534
; So having created the tentative body of the new projection fn with the
3535
; formals and actuals listed in some arbitrary (but internally consistent)
3536
; order, we order the formals alphabetically, build a ``permuation map'' that
3537
; tells us where to put each formal/actual to respect this order, and then
3538
; apply that map to the tentative body. For example, if the formals of
3539
; fn were originally (R7 R0 R2) then the permutation map would be
3540
; ((0 . 2) (1 . 0) (2 . 1)), and applying that map to the expression
3541
; (fn a b c) would produce (fn b c a).
3543
; See apply-permutation-map-to-term.
3545
; This rather late rearrangement of the formals/actuals could probably be
3546
; avoided had we thought about the issue earlier. As it actually happened, we
3547
; implemented all the steps above before this one, found the results a little
3548
; hard to comprehend -- especially when a projection function has 7 arguments
3549
; in some completely arbitrary order -- and decided to impose a sensible
3550
; ordering after the fact.
3553
; (B.8) determine whether there are other projected state components that
3554
; still occur in the body and if so cause an error
3556
; It is still possible that the proposed definition of the projected function
3557
; fails to be a definition because the state variable is still mentioned,
3558
; despite not being a formal. The easiest way for this to happen is if we
3559
; tried to project, say (NTH 1 (RD :LOCALS S)) from SEM-0 before we had
3560
; projected it from a subroutine of SEM-0, e.g., SEM-6. The foregoing
3561
; processing would produce a ``body'' for fn containing (NTH 1 (RD :LOCALS
3562
; (SEM-6 S))). If we see such a term while projecting SEM-0 we call it a
3563
; ``projected other call,'' whereas if we're projecting SEM-6 it would be a
3564
; ``projected recursive call.''
3566
; So we scan the body looking for such ``sub-projections'' and if we find any
3567
; we report sensible error messages telling the user to think of names for
3568
; those projections and to do them first. If the state variable still occurs,
3569
; we cause a less helpful message.
3571
; See all-projector-and-other-fnsymb.
3573
; =============================================================================
3574
; The Code for Codewalker
3576
; Because we have so extensively documented Codewalker above, the only comments
3577
; placed in the code below are (a) cross-references to the Implementation Guide
3578
; such as ``See Guide (A.3),'' (b) document specific functions interfaces, or
3579
; (c) futher elaborate the discussions above. We assume you've read all the
3580
; material above before attempting to really understand the code below.
3584
(include-book "terminatricks")
3586
; This must be in :LOGIC mode, so we put it up here, before shifting to
3587
; :PROGRAM mode. Technically, it ought to be down by (defconst
3588
; *snorkel-depth* ...) below.
3590
(encapsulate ; See Guide (A.3).
3592
(cnt path splitters s)
3594
(codewalker-wrapper-snorkeler
3595
(cnt rpath known-cutpoints splitters depth s)
3597
(local (defun codewalker-tip
3598
(cnt path splitters s)
3599
(declare (ignore cnt path splitters))
3601
(local (defun codewalker-wrapper-snorkeler
3602
(cnt rpath known-cutpoints splitters depth s)
3603
(declare (ignore cnt rpath known-cutpoints splitters depth))
3605
(defthm codewalker-tip-ignores-splitters
3606
(implies (syntaxp (not (equal splitters *nil*)))
3607
(equal (codewalker-tip cnt path splitters s)
3608
(codewalker-tip cnt path nil s))))
3609
(defthm codewalker-wrapper-snorkeler-ignores-splitters
3610
(implies (syntaxp (not (equal splitters *nil*)))
3611
(equal (codewalker-wrapper-snorkeler
3612
cnt rpath known-cutpoints splitters depth s)
3613
(codewalker-wrapper-snorkeler
3614
cnt rpath known-cutpoints nil depth s))))
3615
(in-theory (disable codewalker-tip-ignores-splitters
3616
codewalker-wrapper-snorkeler-ignores-splitters)))
3622
(defun update-codewalker-splitters (s0 s1 pc splitters)
3623
(cond ((or (not (quotep pc))
3624
(not (quotep splitters)))
3625
(er hard 'update-codewalker-splitters
3626
"The last two args of UPDATE-CODEWALKER-SPLITTERS are supposed ~
3627
to be quoted evgs, but pc = ~x0; splitters = ~x1."
3629
((> (count-ifs s1) (count-ifs s0))
3630
`((splitters1 . ,(kwote (cons (cadr pc) (cadr splitters))))))
3631
(t `((splitters1 . ,splitters)))))
3633
; Here is the ``API'' for the machine model. See Guide: Data Structures
3634
; Driving Codewalker for an overview. Individual fields are explained below.
3636
; No thought has been given to frequency of access. This was a balanced 16-tip
3637
; binary tree until package-witness was added.
3640
((((run . svar) . (stobjp . hyps))
3642
((step . get-pc) . (put-pc . updater-drivers)))
3644
(((constructor-drivers . state-comps-and-types) package-witness . (callp . ret-pc))
3646
((returnp . clk+) . (name-print-base . var-names))))
3649
; The fields above are the translated versions of the fields documented in the
3650
; Reference Guide for def-model-api. See translate-model-api-alist for how we
3651
; handle the translation of each field if it isn't obvious. Recall that the
3652
; :var-names field in this record is ALWAYS a function in this data structure:
3653
; translation converts the ``list of tuples'' option into a lambda expression.
3655
; Essay on the Passing of Untranslated Arguments
3657
; Three macros (def-model-api, def-semantics, and def-projection) in this system
3658
; take keyword arguments -- and the number of such arguments may grow in the
3659
; future. In all cases, the user-supplied arguments must be error-checked and
3660
; translated before being used. We adopt a uniform convention for how to do
3663
; The keys of the macro are paired with the untranslated, user-supplied values,
3664
; resulting in an alist. We then pass the alist into some kind of translate
3665
; function that either causes an error or assembles the final structure. In
3666
; the case of def-model-api, the final structure is a model-api defrec. In the
3667
; case of the def-semantics and def-projection commands, the final structure is an
3668
; alist pairing the keys of the macro to the translated values. These two
3669
; alists are named dsem-alist and dpro-alist, respectively.
3671
; The next block of code is devoted to translating API.
3672
; See Guide: Data Structures Driving Codewalker.
3674
(defun translate-fn-field (field ctx fn arity svar svar-pos state)
3675
(let* ((w (w state)))
3678
(equal (arity fn w) arity)
3679
(if (equal svar-pos -1)
3680
(not (member-eq svar (formals fn w)))
3681
(equal (len (member-eq svar (formals fn w)))
3682
(- arity svar-pos))))
3685
(eq (car fn) 'lambda)
3687
(true-listp (cadr fn))
3688
(equal (len (cadr fn)) arity)
3689
(if (equal svar-pos -1)
3690
(not (member-eq svar (cadr fn)))
3691
(equal (len (member-eq svar (cadr fn)))
3692
(- arity svar-pos))))
3694
; We know fn is of the form (LAMBDA (x1...xn) . any) and that the svar, if any,
3695
; is in the correct position. We create and translate the pseudo-term ((LAMBDA
3696
; (x1...xn) . any) x1...xn). Then we return the ffn-symb of the result. It
3697
; could be that the created pseudo-term fails to be a term because the xi are
3698
; illegal. But if that is the case, they will not be distinct variables either
3699
; and we'll report the illegal variables instead.
3701
(er-let* ((call (translate (cons fn (cadr fn))
3704
(value (ffn-symb (remove-guard-holders call)))))
3706
"The ~x0 argument must be either a an existing function symbol or ~
3707
a well-formed LAMBDA expression. The arity of the function ~
3708
symbol or LAMBDA expression must be ~x1 and ~#2~[the formals ~
3709
must not include~/the ~n3 formal must be~] the state variable ~
3710
~x4. But ~x5 does not satisfy these requirements."
3713
(if (equal svar-pos -1) 0 1)
3718
; Below we define some functions that translate true-lists of things. But the
3719
; functions themselves do not actually check the true-lisp condition because if
3720
; you check it only at the end the error message just prints the non-nil final
3721
; cdr, not the argument. So we define the following function and use it
3723
; (er-progn (chk-true-listp x ctx "The foo field of a bar" state)
3724
; (translate-list-of-terms x state))
3725
; so that either it reports a non-true-listp error about all of x or else it
3726
; complains about the translation of some element, or else it returns the
3727
; list of translated values.
3729
(defun chk-true-listp (x ctx msg state)
3731
((true-listp x) (value nil))
3733
"~@0 is supposed to be a true-list, but the value supplied is not: ~x1."
3737
(defun translate-list-of-terms (terms state)
3739
((atom terms) (value nil))
3741
(er-let* ((term (translate (car terms) t t nil
3742
'translate-list-of-terms
3744
(rest (translate-list-of-terms (cdr terms) state)))
3745
(value (remove-guard-holders-lst (cons term rest)))))))
3747
(defun translate-list-of-terms-list (lst state)
3749
((atom lst) (value nil))
3750
(t (er-let* ((term-lst (translate-list-of-terms (car lst) state))
3751
(rest (translate-list-of-terms-list (cdr lst) state)))
3752
(value (cons term-lst rest))))))
3754
(defun translate-list-of-term-term-doublets (doublets state)
3756
((atom doublets) (value nil))
3757
((and (consp (car doublets))
3758
(consp (cdr (car doublets)))
3759
(null (cddr (car doublets))))
3760
(er-let* ((term1 (translate (car (car doublets)) t t nil
3761
'translate-list-of-term-term-doublets
3763
(term2 (translate (cadr (car doublets)) t t nil
3764
'translate-list-of-term-term-doublets
3766
(rest (translate-list-of-term-term-doublets (cdr doublets) state)))
3767
(value (cons (list (remove-guard-holders term1)
3768
(remove-guard-holders term2))
3770
(t (er soft 'translate-list-of-term-term-doublets
3771
"This function takes a true list of doublets, each of the form ~
3772
(term1 term2), and translates each termi. The element ~x0 of your ~
3773
list is not of this form."
3778
(defun untranslate-updater-driver-term (term)
3779
; We replace every ':value and ':base by :value and :base, respectively.
3781
((variablep term) term)
3784
((eq (cadr term) :value) (cadr term))
3785
((eq (cadr term) :base) (cadr term))
3787
(t (cons (ffn-symb term)
3788
(untranslate-updater-driver-term-lst (fargs term))))))
3790
(defun untranslate-updater-driver-term-lst (lst)
3793
(t (cons (untranslate-updater-driver-term (car lst))
3794
(untranslate-updater-driver-term-lst (cdr lst)))))))
3798
(defun how-many-occurrences (term1 term2)
3799
; Count how many times term1 occurs in term2.
3801
((equal term1 term2) 1)
3802
((variablep term2) 0)
3804
(t (how-many-occurrences-lst term1 (fargs term2)))))
3806
(defun how-many-occurrences-lst (term1 lst)
3809
(t (+ (how-many-occurrences term1 (car lst))
3810
(how-many-occurrences-lst term1 (cdr lst)))))))
3814
(defun term-uses-lambdap (term)
3815
(cond ((variablep term) nil)
3816
((fquotep term) nil)
3817
((flambdap (ffn-symb term)) t)
3818
(t (term-uses-lambdap-lst (fargs term)))))
3820
(defun term-uses-lambdap-lst (lst)
3823
(t (or (term-uses-lambdap (car lst))
3824
(term-uses-lambdap-lst (cdr lst)))))))
3826
(defun translate-updater-drivers1 (doublets state)
3828
; Each element of doublets is (term1 term2) where both are translated terms.
3829
; We check that term1 satisfies the syntactic rules of an updater term and
3830
; term2 those of an accessor term, as per the comment in
3831
; translate-updater-drivers. If so, we translate each to their special forms,
3832
; by mapping ':value and ':base to :value and :base.
3835
((atom doublets) (value nil))
3836
(t (let* ((updater (car (car doublets)))
3837
(accessor (cadr (car doublets)))
3838
(xupdater (untranslate-updater-driver-term updater))
3839
(xaccessor (untranslate-updater-driver-term accessor)))
3841
; Warning: xupdater and xaccessor are not terms! They may contain unquoted
3842
; :VALUE and :BASE symbols. We nevertheless explore them like terms when we
3843
; can afford the mistaking of :VALUE and :BASE for variable symbols.
3846
((not (equal (how-many-occurrences :value xupdater) 1))
3847
(er soft 'translate-updater-drivers
3848
"The updater term of an updater driver doublet must contain ~
3849
exactly one occurrence of :VALUE and this term, ~x0, contains ~
3852
(how-many-occurrences :value xupdater)))
3853
((not (equal (how-many-occurrences :base xupdater) 1))
3854
(er soft 'translate-updater-drivers
3855
"The updater term of an updater driver doublet must contain ~
3856
exactly one occurrence of :BASE and this term, ~x0, contains ~
3859
(how-many-occurrences :base xupdater)))
3860
((term-uses-lambdap xupdater)
3861
(er soft 'translate-updater-drivers
3862
"The updater term of an updater driver must not use any LAMBDA ~
3863
expressions because it may confuse our hack for insuring that ~
3864
the term uses :VALUE and :BASE the correct number of times. ~
3865
This term contains a LAMBDA expression, ~x0."
3867
((not (equal (how-many-occurrences :value xaccessor) 0))
3868
(er soft 'translate-updater-drivers
3869
"The accessor term of an updater driver doublet must not ~
3870
contain :VALUE and this term, ~x0, does."
3872
((not (equal (how-many-occurrences :base xaccessor) 1))
3873
(er soft 'translate-updater-drivers
3874
"The accessor term of an updater driver doublet must contain ~
3875
exactly one occurrence of :BASE and this term, ~x0, contains ~
3878
(how-many-occurrences :base xaccessor)))
3879
((term-uses-lambdap xaccessor)
3880
(er soft 'translate-updater-drivers
3881
"The accessor term of an updater driver must not use any LAMBDA ~
3882
expressions because it may confuse our hack for insuring that ~
3883
the term uses :BASE the correct number of times. This term ~
3884
contains a LAMBDA expression, ~x0."
3886
((not (subsetp (all-vars accessor) (all-vars updater)))
3887
(er soft 'translate-updater-drivers
3888
"The variables of the updater term, ~x0, are not a superset of ~
3889
those of the accessor term, ~x1."
3892
(t (er-let* ((lst (translate-updater-drivers1 (cdr doublets) state)))
3893
(value (cons (list xupdater xaccessor)
3896
(defun translate-updater-drivers (doublets state)
3898
; The list of updater-drivers is supposed to be a list of doublets, each of the
3899
; form (update-term accessor-term), where update-term should involve two
3900
; special symbols, :value and :base and is otherwise a translatable term, and
3901
; accessor-term is a term involving the special symbol :base and the same
3902
; variables as the updater. We translate each doublet and then coerce the
3903
; ':value and ':base terms to their special counterparts or cause an error.
3904
; Each special symbol is to occur at most once. We prohibit lambda expressions
3905
; because that confuses the counting. Note that we might have checked that the
3906
; accessors actually extract the alleged :VALUE, but we don't.
3908
(er-let* ((doublets (er-progn
3909
(chk-true-listp doublets
3911
"The :UPDATER-DRIVERS argument"
3913
(translate-list-of-term-term-doublets doublets state))))
3914
(translate-updater-drivers1 doublets state)))
3916
; We now almost repeat the development of translate-updater-drivers1, above,
3917
; except for constructor. We think near duplication allows us to produce
3918
; better error messages with less complication than we could with a generalized
3919
; translation process capable of handling both.
3921
(defun translate-constructor-drivers1-accessors
3922
(xconstructor vars accessors state)
3924
; We untranslate and check each accessor against the rules laid out in
3925
; translate-constructor-drivers. Here xconstructor is the untranslated
3926
; constructor term for each of the accessors and vars is the set of vars of
3930
((atom accessors) (value nil))
3931
(t (let* ((accessor (car accessors))
3932
(xaccessor (untranslate-updater-driver-term accessor)))
3934
; Warning: xconstructor and xaccessor are not terms! They may contain unquoted
3935
; :VALUE and :BASE symbols. And note that we untranslate ':VALUE to :VALUE in
3936
; each accessor even though the special symbol is not supposed to appear. We
3937
; will give it special meaning simply because we suspect the user might since
3938
; it is given special meaning in updater doublets. Despite these violations of
3939
; of the notion of well-formed terms, we nevertheless explore them as though
3940
; they were when we can afford the mistaking of :VALUE and :BASE for variable
3944
((not (equal (how-many-occurrences :value xaccessor) 0))
3945
(er soft 'translate-updater-drivers
3946
"No accessor term of a constructor driver may contain ~
3947
:VALUE and this term, ~x0, does."
3949
((not (equal (how-many-occurrences :base xaccessor) 1))
3950
(er soft 'translate-updater-drivers
3951
"Each accessor term of a constructor driver must contain ~
3952
exactly one occurrence of :BASE and this term, ~x0, contains ~
3955
(how-many-occurrences :base xaccessor)))
3956
((term-uses-lambdap xaccessor)
3957
(er soft 'translate-updater-drivers
3958
"No accessor term of a constructor driver may use a LAMBDA ~
3959
expression because it may confuse our hack for insuring that ~
3960
the term uses :BASE the correct number of times. This term ~
3961
contains a LAMBDA expression, ~x0."
3963
((not (subsetp (all-vars accessor) vars))
3964
(er soft 'translate-updater-drivers
3965
"The variables of the constructor term, ~x0, are not a superset ~
3966
of those of one of its accessor terms, ~x1."
3969
(t (er-let* ((lst (translate-constructor-drivers1-accessors
3973
(value (cons xaccessor lst)))))))))
3975
(defun translate-constructor-drivers1 (lst state)
3977
; Each element of lst is (term0 term1 ... termn) where all elements are
3978
; translated terms. We check that term0 satisfies the syntactic rules of a
3979
; constructor term and that every other termi those of an accessor term, as per
3980
; the comment in translate-constructor-drivers. If so, we translate each to
3981
; their special forms, by mapping ':base to :base.
3984
((atom lst) (value nil))
3985
(t (let* ((constructor (car (car lst)))
3986
(accessors (cdr (car lst)))
3987
(xconstructor (untranslate-updater-driver-term constructor)))
3989
; Warning: xconstructor is not a term!. It may contain unquoted :VALUE and
3990
; :BASE symbols. And note that we untranslate ':VALUE to :VALUE here (and,
3991
; eventually, in each accessor) even though the special symbol is not supposed
3992
; to appear. We will give it special meaning simply because we suspect the
3993
; user might since it is given special meaning in updater doublets. Despite
3994
; these ``terms/lists of terms'' not being well-formed, we nevertheless explore
3995
; them as though they were when we can afford the mistaking of :VALUE and :BASE
3996
; for variable symbols.
3999
((not (equal (how-many-occurrences :value xconstructor) 0))
4000
(er soft 'translate-constructor-drivers
4001
"The constructor term of a constructor driver must not contain ~
4002
the special symbol :VALUE and this term does, ~x0."
4004
((not (equal (how-many-occurrences :base xconstructor) 0))
4005
(er soft 'translate-constructor-drivers
4006
"The constructor term of a constructor driver must not contain ~
4007
the special symbol :BASE and this term does, ~x0."
4009
((term-uses-lambdap xconstructor)
4010
(er soft 'translate-constructor-drivers
4011
"The constructor term of a constructor driver must not use any LAMBDA ~
4012
expressions because it may confuse our hack for insuring that ~
4013
the term uses :VALUE and :BASE the correct number of times. ~
4014
This term contains a LAMBDA expression, ~x0."
4016
(t (er-let* ((xaccessors
4018
(chk-true-listp accessors
4020
"The list of constructor drivers"
4022
(translate-constructor-drivers1-accessors
4024
(all-vars constructor)
4026
(lst (translate-constructor-drivers1 (cdr lst) state)))
4027
(value (cons (cons xconstructor xaccessors)
4030
(defun translate-constructor-drivers (lst state)
4032
; The list of constructor-drivers is supposed to be a list of elements, each of
4033
; the form (constructor-term accessor-term1 ... accessor-termn), where
4034
; constructor-term should involve one special symbol, :base, and is otherwise a
4035
; translatable term, and each accessor-termi is a term involving the special
4036
; symbol :base and the same variables as the updater. We translate each term
4037
; and then coerce ':base to its special counterpart or cause an error. :Base
4038
; is to occur exactly once in each term; :VALUE should not appear at all. We
4039
; prohibit lambda expressions because that confuses the counting. Note that we
4040
; might have checked that the accessors actually extract the corresponding
4041
; argument of the constructor-term, but we don't.
4043
(er-let* ((lst (er-progn
4046
"The :CONSTRUCTOR-DRIVERS argument"
4048
(translate-list-of-terms-list lst state))))
4049
(translate-constructor-drivers1 lst state)))
4051
; Essay on Generating Variable Names for Virtual Formals
4053
; A var-name-rules is a list of triples, (pattern fmt-str term_0 ... term_k),
4054
; where pattern is a term, fmt-str is a string appropriate for fmt and the
4055
; term_i are terms in the variables of the pattern (excluding svar). To
4056
; generate a name for a virtual formal, term, we find the first pattern
4057
; matching alist in term such that all variables in the pattern are bound to
4058
; constants except, possibly, svar, which must be bound to svar. Then we
4059
; create fmt-alist by replacing the pattern variables in bound in the unifying
4060
; alist with their evgs and then evaluating each term_i with respect to that
4061
; alist, and then binding successive characters, #\0, ..., \#k with those
4062
; values. Then we create a string by printing fmt-str under fmt-alist.
4064
; For example, if the pattern were (NTH i (NTH j svar)) then str might be
4065
; "REG-~x0~x1" and term_0 is j and term_1 is i. Suppose svar is FOO::SVAR.
4066
; Thus, if the pattern is used to match (nth '3 (nth '7 FOO::SVAR)) then the
4067
; variable name generated is FOO::REG-7-3. (Note that this example
4068
; intentionally swapped the order of the variables for illustrative purposes.)
4070
; We generate the (alleged) variable name using the str and alist of the
4071
; left-most pattern that matches term. Thus, for example, if the first pattern
4072
; in alist is (NTH i (NTH '1 svar)) and the second is (NTH i (NTH j svar)), we
4073
; would generate the variable name for (NTH i (NTH '1 svar)) preferentially.
4075
(defun member-instance (term i patterns alist0)
4077
; This function finds first pattern in patterns that matches term and returns
4078
; (mv flg alist i), where flg is t iff such a pattern exists, alist is the
4079
; unifying subst, and i is the index in patterns of the winning pattern (i=0
4080
; initially). All results are nil when no pattern is found.
4083
((endp patterns) (mv nil nil nil))
4086
(one-way-unify1 (car patterns)
4092
(t (member-instance term (+ i 1) (cdr patterns) alist0)))))))
4094
(defun translate-var-names (alist svar state-comps state)
4096
; State-comps should be (strip-cars state-comps-and-types). This function is
4097
; only used if the specified setting for :var-names is supposed to be a list of
4098
; (pattern fmt-string term_0 ...) tuples, not a function symbol or lambda
4104
((and (true-listp (car alist))
4105
(<= 2 (len (car alist)))
4106
(<= (len (car alist)) 12)
4107
(stringp (cadr (car alist))))
4109
((eq (car (car alist)) :otherwise)
4111
((null (cddr (car alist)))
4112
(value (cons (list :otherwise (cadr (car alist)))
4114
(t (er soft 'translate-var-names
4115
"The value supplied for :VAR-NAMES is ill-formed. Each element ~
4116
should be of the form (pattern fmt-string term_0 ... term_n), ~
4117
and pattern is allowed to be :OTHERWISE only on the last ~
4118
element and only if n=0, i.e., no term_i are supplied. Your ~
4119
element, ~x0, is thus ill-formed. The :OTHERWISE pattern ~
4120
specifies the default fmt-string for any state component not ~
4121
matching one of the earlier ones. We do not allow any term_i ~
4122
because they are evaluated with respect to the bindings of the ~
4123
non-:svar variables in the substitution produced by matching ~
4124
the pattern with the given state component to be generalized ~
4125
and that substitution will be empty, meaning each term_i must ~
4126
be a constant expression, in which case you might as well just ~
4127
specify the fmt-string you want."
4130
(er-let* ((pattern (translate (car (car alist)) t t nil
4131
'translate-var-names
4133
(term-lst (translate-list-of-terms (cddr (car alist)) state))
4134
(rest (translate-var-names (cdr alist) svar state-comps state)))
4138
(member-instance pattern
4141
(list (cons svar svar)))
4142
(declare (ignore subst-alist i))
4145
(er soft 'translate-var-names
4146
"The value supplied for :VAR-NAMES is ill-formed. Each ~
4147
element should be of the form (pattern fmt-string term_0 ... ~
4148
term_n), where pattern is an instance of some pattern in ~
4149
:STATE-COMPS-AND-TYPES with :SVAR, ~x0, bound to itself. But ~
4150
one of your :VAR-NAMES patterns, namely ~x1, is not such an ~
4154
((subsetp-eq (all-vars1-lst term-lst nil)
4155
(remove1-eq svar (all-vars pattern)))
4156
(value (cons (list* pattern
4157
(cadr (car alist)) ; fmt-string
4158
term-lst) ; term-lst for bindings
4160
(t (er soft 'translate-var-names
4161
"The value supplied for :VAR-NAMES is ill-formed. Each ~
4162
element should be of the form (pattern fmt-string term_0 ~
4163
... term_n). But your term_i involve variable~#0~[~/s~] ~
4164
~&0 not occuring in the pattern, ~x1, that triggers ~
4166
(set-difference-eq (all-vars1-lst term-lst nil)
4167
(remove1-eq svar (all-vars pattern)))
4169
(cadr (car alist))))))))))
4170
(t (er soft 'translate-var-names
4171
"The value supplied for :VAR-NAMES is ill-formed. It must be the ~
4172
name of a function of one argument, a lambda expression of one ~
4173
argument, or a true-list of ``var name rules.'' Each var name ~
4174
rule must be of the form (pattern fmt-string term_0 term_1 ...), ~
4175
where fmt-string is a string and there are no more than 10 term_i ~
4176
terms. You evidently tried to supply a list of var name rules, ~
4177
but your rule ~x0 is not of the correct form."
4180
; We will frequently form terms by consing a function name onto some arguments,
4181
; as would happen if we wrote `(,fn ,arg1 ,arg2). However, often, fn is a
4182
; (translated) lambda expression, as when we specify the :run function to be
4183
; (lambda (s n) (x86 s n)). We don't want to form ((lambda (s n) (x86 s n))
4184
; arg1 arg2) because it is unlikely to be a good rewrite or relieve hyps
4185
; target. So we beta-reduce terms by writing (make-fn-application fn args).
4187
(defun make-fn-application (fn args)
4189
; Fn is a function symbol of arity n or a translated lambda expression with n
4190
; formals. Args is a list of n translated terms. We form the term (fn
4191
; . args), but beta-reduce it at the top-level.
4193
(cond ((flambdap fn)
4194
(subcor-var (lambda-formals fn)
4197
(t (cons fn args))))
4199
; Given a virtual formal on some base and a new variable, new-var, to replace
4200
; that virtual formal in some derived function, we need to compute the
4201
; constraints imposed on new-var by the external invariant imposed on base.
4202
; This is source (b) mentioned below in the Essay On Identifying State
4203
; Components. For example, take the M1 machine and imagine a good-statep
4204
; condition on state s that requires all locals to be natural numbers. Suppose
4205
; (nth 7 (locals s)) is a virtual formal on base s and that we're going to
4206
; replace that virtual formal by the variable new-var. What may we assume
4207
; about new-var given (good-statep s)? Answer: (natp var).
4209
; The way we figure this out is described in the Guide, (B.6), where we discuss
4210
; ``inverting'' state accessors.
4212
(defun find-first-member-instance (term con-drivers alist0)
4214
((endp con-drivers) (mv nil nil nil nil))
4215
(t (mv-let (flg alist i)
4216
(member-instance term 0 (cdr (car con-drivers)) alist0)
4218
(find-first-member-instance term (cdr con-drivers) alist0))
4219
(t (mv t alist (car con-drivers) i)))))))
4221
(defun invert-vformal1 (vformal base gup-drivers con-drivers)
4223
; Vformal is a virtual formal in base and the last two arguments are our
4224
; standard updater and constructor drivers tables. We peel off one layer of
4225
; the virtual formal and return (mv update-expr1 next-base). If next-base is
4226
; nil, there is no next base. If update-expr1 is nil, vformal is unrecognized.
4229
((or (variablep vformal)
4231
(if (equal vformal base)
4236
(find-first-instance vformal 'cadr gup-drivers)
4237
; Note: find-first-instance is different from find-first-member-instance!
4240
(mv (sublis-var (cons '(:value . :value) alist) (car ele))
4241
(cdr (assoc-eq :base alist))))
4244
(find-first-member-instance vformal con-drivers nil)
4247
(mv (update-nth (+ i 1)
4249
(fcons-term (ffn-symb (car ele))
4250
(sublis-var-lst alist
4252
(cdr (assoc-eq :base alist))))
4253
(t (mv nil nil))))))))))
4255
; Now we return the (body of the) generalized setter function for a virtual
4256
; formal, vformal, on base, using var as the new value.
4258
(defun invert-vformal (vformal var base gup-drivers con-drivers)
4260
; Given a virtual formal on a base and the formal variable to replace it, var,
4261
; we return the ``assignment expression'' that assigns var as the value of
4262
; vformal in base. For example, if vformal is (nth 7 (locals s)) and
4263
; base is s and var is xxx, then we return:
4265
; (make-state (pc s) (update-nth 7 xxx (locals s)) (stack s) (program s)).
4267
; If we can't invert vformal, we return nil.
4269
(mv-let (updater next-vformal)
4270
(invert-vformal1 vformal base gup-drivers con-drivers)
4272
((null updater) nil)
4273
((null next-vformal) var)
4274
(t (invert-vformal next-vformal
4275
(subst-var var :value updater)
4276
base gup-drivers con-drivers)))))
4278
(defun invert-vformals (vformal-replacement-pairs
4279
base gup-drivers con-drivers assignments uninvertables)
4281
; Now we invert a list of vformal-replacement-pairs containing (vformali
4282
; . new-vari). However, for error reporting reasons we divide our answer into
4283
; two lists: (mv assignments uninvertables) where uninvertables is a list of
4284
; those vformals that we were unable to invert. In the case that uninvertables
4285
; is nil, the assignments is a list pairing each new variable with an
4286
; expression that sets the corresponding (but now unrecorded) virtual formal in
4287
; base to that variable.
4290
((endp vformal-replacement-pairs)
4291
(mv assignments uninvertables))
4292
(t (let* ((vformal1 (car (car vformal-replacement-pairs)))
4293
(var1 (cdr (car vformal-replacement-pairs)))
4294
(body1 (invert-vformal vformal1 var1
4295
base gup-drivers con-drivers)))
4297
(cdr vformal-replacement-pairs)
4298
base gup-drivers con-drivers
4299
(if body1 (cons (cons var1 body1) assignments) assignments)
4300
(if body1 uninvertables (cons vformal1 uninvertables)))))))
4302
; Because we've just exhibited what an ``assignment'' is, we go ahead and
4303
; define how to compose a series of assignments. This concept is not necessary
4304
; for the translation check and is used later when we try to figure out the
4305
; restrictions imposed by the invariant on individual vformals.
4307
(defun compose-vformal-assignments (assignments base ans)
4309
; Assuming that we were able to invert every virtual formal into an expression
4310
; that assigned a given new variable to that slot, we compose the assignments
4311
; into a single expression in the base and the new variables. This is the
4312
; ``generalization of the base state wrt the vformals.''
4314
; Assignments is a list of pairs, (vari . bodyi). Think of bodyi as a function
4315
; that assigns the value vari to some virtual formal slot. Call that function
4316
; set-fni. Then we can think of assignments as: ((var1 . set-fn1) (var2
4317
; . set-fn2) ... (vark . set-fnk)). We return the composed expression:
4318
; (set-fn1 var1 (set-fn2 var2 ... (set-fnk vark base))).
4320
; Ans should be nil initially and that is used as a flag to treat the first
4321
; assignment specially -- it doesn't need a lambda wrapper.
4323
; Note: In computing each composition we allow for the possibility that bodyi
4324
; contains variables other than base and vari. It is unclear whether this
4325
; possibility ever arises! It certainly doesn't if the only variable used in a
4326
; virtual formal is the base. However, if (nth i (locals s)) were somehow
4327
; being treated as a virtual formal, then i would be a variable symbol in the
4330
(cond ((endp assignments)
4331
(if (null ans) base ans))
4333
(compose-vformal-assignments (cdr assignments) base
4334
(cdr (car assignments))))
4335
(t (let* ((var1 (car (car assignments)))
4336
(body1 (cdr (car assignments)))
4337
(other-vars (set-difference-eq (all-vars body1) (list base var1)))
4338
(set-fn `(lambda (,var1 ,base ,@other-vars) ,body1))
4339
(ans1 `(,set-fn ,var1 ,ans ,@other-vars)))
4340
(compose-vformal-assignments (cdr assignments) base ans1)))))
4342
(defun translate-model-api-alist (alist state)
4344
; Alist is an alist in which each key is the keyword name of a field of a
4345
; proposed model-api and each key is bound in a pair to an untranslated value.
4346
; We translate each value appropriately and return a translated model-api
4347
; record. (In an earlier version we packaged the untranslated bindings into a
4348
; model-api record instead of an alist, and then we translated the record. But
4349
; we felt this was a violation (albeit a benign one) of the supposed invariant
4350
; that model-api records contain translated values so we abandoned it.)
4355
((eq (legal-variable-or-constant-namep
4356
(cdr (assoc-eq :svar alist)))
4358
(value (cdr (assoc-eq :svar alist))))
4359
(t (er soft 'translate-model-api-alist
4360
"The :SVAR value of a machine description must be a legal ~
4361
variable symbol and ~x0 is not."
4362
(cdr (assoc-eq :svar alist))))))
4367
(cdr (assoc-eq :run alist))
4371
(cond ((cdr (assoc-eq :stobjp alist))
4372
(if (stobjp svar t (w state))
4374
(er soft 'translate-model-api-alist
4375
"When the :STOBJP flag is set in a machine description, ~
4376
the state variable ~x0 ought to be the name of a ~
4377
single-threaded objected but it is not!"
4382
(chk-true-listp (cdr (assoc-eq :hyps alist))
4384
"The :HYPS argument"
4386
(translate-list-of-terms
4387
(cdr (assoc-eq :hyps alist))
4393
(cdr (assoc-eq :step alist))
4400
(cdr (assoc-eq :get-pc alist))
4407
(cdr (assoc-eq :put-pc alist))
4412
(chk-true-listp (cdr (assoc-eq :updater-drivers alist))
4414
"The :UPDATER-DRIVERS argument"
4416
(translate-updater-drivers (cdr (assoc-eq :updater-drivers alist))
4418
(constructor-drivers
4420
(chk-true-listp (cdr (assoc-eq :constructor-drivers alist))
4422
"The :CONSTRUCTOR-DRIVERS argument"
4424
(translate-constructor-drivers (cdr (assoc-eq :constructor-drivers alist))
4426
(state-comps-and-types
4428
(chk-true-listp (cdr (assoc-eq :state-comps-and-types alist))
4430
"The :STATE-COMPS-AND-TYPES argument"
4432
(translate-list-of-term-term-doublets
4433
(cdr (assoc-eq :state-comps-and-types alist))
4436
(let ((x (cdr (assoc-eq :var-names alist))))
4438
((or (and (symbolp x) (not (eq x nil)))
4440
(eq (car x) 'LAMBDA)))
4447
(t ; we treat the supplied value as an alist of vnrules
4452
"The :VAR-NAMES argument"
4454
(translate-var-names x svar
4455
(strip-cars state-comps-and-types)
4459
(trigger-var-name-rule term
4465
((null (cdr (assoc-eq :package-witness alist))) svar)
4466
((symbolp (cdr (assoc-eq :package-witness alist)))
4467
(cdr (assoc-eq :package-witness alist)))
4470
(cond ((or (eq (cdr (assoc-eq :callp alist))
4472
(eq (cdr (assoc-eq :callp alist))
4474
(value `(lambda (,svar) 'nil)))
4479
(cdr (assoc-eq :callp alist))
4483
(cond ((or (eq (cdr (assoc-eq :ret-pc alist))
4485
(eq (cdr (assoc-eq :ret-pc alist))
4487
(value `(lambda (,svar)
4490
,(make-fn-application get-pc (list svar))))))
4496
(cdr (assoc-eq :ret-pc alist))
4500
(cond ((or (eq (cdr (assoc-eq :returnp alist))
4502
(eq (cdr (assoc-eq :returnp alist))
4504
(value `(lambda (,svar) 'nil)))
4509
(cdr (assoc-eq :returnp alist))
4516
(cdr (assoc-eq :clk+ alist))
4519
(let ((name-print-base
4520
(or (cdr (assoc-eq :name-print-base alist))
4523
((not (member-equal name-print-base '(2 8 10 16)))
4524
(er soft 'def-model-api
4525
"The only :NAME-PRINT-BASE values supported are 2, 8, 10, and 16. ~
4530
(assignments uninvertables)
4532
(pairlis-x2 (strip-cars state-comps-and-types) ; just the components
4533
(genvar 'project-fn-to-fn "NEW-" 0 (list svar)))
4538
(declare (ignore assignments))
4540
; Note: We are ignoring the assignments because we are just doing error
4541
; checking here. We could perhaps improve efficiency marginally by storing
4542
; the assignmetns as part of the ``translation'' of the state-comps-and-types
4543
; but that (a) complicates the story and (b) probably doesn't help much because
4544
; we don't think inversion is all that expensive.
4548
(er soft 'def-model-api
4549
"Every state component must be invertable. The following were ~
4550
not: ~x0. This probably means you need to inspect the
4551
:UPDATER-DRIVER and/or :CONSTRUCTOR-DRIVERS fields of the API."
4559
:hyps (remove-guard-holders-lst hyps)
4563
:updater-drivers updater-drivers
4564
:constructor-drivers constructor-drivers
4565
:state-comps-and-types state-comps-and-types
4570
:name-print-base name-print-base
4571
:var-names var-names
4572
:package-witness package-witness))))))))))
4574
(defmacro def-model-api (&key run svar stobjp hyps step
4576
updater-drivers constructor-drivers state-comps-and-types
4577
callp ret-pc returnp
4578
clk+ name-print-base
4579
var-names package-witness)
4582
(translate-model-api-alist
4590
(:updater-drivers . ,updater-drivers)
4591
(:constructor-drivers . ,constructor-drivers)
4592
(:state-comps-and-types . ,state-comps-and-types)
4595
(:returnp . ,returnp)
4597
(:name-print-base . ,name-print-base)
4598
(:var-names . ,var-names)
4599
(:package-witness . ,package-witness))
4606
(table generalized-updater-drivers
4608
(quote ,(access model-api api :updater-drivers)))
4609
(table constructor-drivers
4611
(quote ,(access model-api api :constructor-drivers))))))))
4613
; Codewalker-tip and extracting pcs from state terms
4615
; A codewalker-tip expression has the form:
4616
; (CODEWALKER-TIP cnt path splitters s)
4619
; Note: We limit the length of the paths we can explore to the value below.
4620
; Furthermore, there is no current provision for handling coverage of the graph
4621
; when the max path length is reached. That is, the path trees we compute may
4622
; not actually go from cutpoint to cutpoint but only from cutpoint to some
4623
; random place max steps away -- we don't detect it unless (as will probably
4624
; happen) the proof of correctness fails.
4626
(defconst *snorkel-depth* 300) ; depth reaches 300 and then snorkels.
4628
(defun extract-pcs-from-if-term (term knowns unknowns)
4630
; Given a normalized IF-term that represents a pc, return (mv knowns unknowns)
4631
; where knowns is a list of all the constants that term might return and
4632
; unknowns is a list of all the other pc values encountered.
4634
(cond ((variablep term)
4636
(add-to-set term unknowns)))
4638
(mv (add-to-set (cadr term) knowns)
4640
((eq (ffn-symb term) 'IF)
4641
(mv-let (knowns unknowns)
4642
(extract-pcs-from-if-term (fargn term 2) knowns unknowns)
4643
(extract-pcs-from-if-term (fargn term 3) knowns unknowns)))
4645
(add-to-set term unknowns)))))
4648
; (A.1) compute a conservative (over-estimate of the) control flow graph of the
4651
(defun state-poised-at-pc (pc api)
4652
`(,(access model-api api :put-pc)
4654
,(access model-api api :svar)))
4656
(defun next-pcs (pc api state)
4658
; Given a pc and a machine description we step the machine once from that pc
4659
; and extract the new pcs. We return (mv knowns unknowns). The knowns is a
4660
; list of all constants that could be the new pc and unknowns is a list of all
4661
; the other (probably unresolved symbolic) pc values.
4663
(mv-let (knowns unknowns)
4664
(extract-pcs-from-if-term
4665
(simplify-under-hyps (access model-api api :hyps)
4666
`(,(access model-api api :get-pc)
4667
(,(access model-api api :step)
4668
,(state-poised-at-pc pc api)))
4672
(cw "pc ~x0 ==> ~x1 [unkn: ~x2]~%"
4674
(mv knowns unknowns))))
4676
(defun focus-regionp-approvesp (ctx pred pc state)
4680
(ev-fncall-w pred (list pc)
4681
(w state) nil nil nil nil nil))
4683
; If we were allowed to call ev-w we would use:
4684
; (ev-w (list pred (kwote pc))
4685
; nil (w state) nil nil nil nil nil)
4686
; But ev-w is on untouchables. Instead, I'll use simplify-under-hyps
4688
(simplify-under-hyps nil
4689
(list pred (kwote pc))
4692
((quotep val) (mv nil (cadr val)))
4698
"The focus-region predicate ~X01 caused an error (or at least ~
4699
failed to fully evaluate to a constant) when applied to the ~
4706
(defun make-backward-link-graph
4707
(pc last-pc blink-graph unknowns-alist dsem-alist api state)
4709
; We construct the backward graph first: An entry in blink-graph, (pc
4710
; . pc-lst), means that pc is ``reachable'' in one step from the pcs in pc-lst.
4711
; We reached pc from last-pc and we assume last-pc is within the focus region.
4713
; We explore the ``reachable'' pcs starting from the initial statep described
4714
; by api. We quote reachable because we do absolutely no contextual reasoning:
4715
; it is as though every branch were possible.
4717
; Think of pc and api together describing the state, s, which is the api initial
4718
; state but poised at pc. Imagine that control has been transferred to this s
4719
; from a state with pc last-pc, which is some constant. -1 should be
4720
; used initially, denoting the intended (top level) entry into the code.
4721
; Blink-Graph is a list of all the pcs visited so far and the pcs from which
4722
; each was visited. For example, blink-graph might be (except for order)
4724
; ((0 -1) (1 0) (2 1) (3 2 5) (4 3) (5 4) (6 5 6)))
4726
; which means we entered at 0 from the imaginary ``top'' and successively
4727
; visited each pc except 3, which we reached two ways: once from 2 and once
4728
; from 5, and 6, which we reached from 5 and also from 6. Note that since 6
4729
; transfers control to itself, one can think of the instruction at 6 as a
4730
; (conditional) HALT.
4732
; If the instruction at pc jumps to a non-constant place, we add a pc entry to
4733
; the alist unknowns-alist, which pairs each such pc with the list of symbolic
4734
; values the next pc may take on. If unknowns-alist is non-nil, then the
4735
; instructions at those pcs might jump ANYWHERE. Thus, if unknowns-alist is
4736
; non-nil, the rest of the graph is pretty useless. However, the user might
4737
; wish to inspect the instructions at those pcs to determine what is going on.
4739
; If the instruction at pc jumps to a pc outside the focus region, we record
4740
; that fact but we record the external pc as we would a HALT: it jumps to
4743
; Operationally, we store how we reached pc (i.e., from last-pc) and then
4744
; explore forward from pc provided pc is within the focus region. If pc is not
4745
; within the focus region, we record it as we would a HALT>
4747
; We quit exploring when we get no new entries in blink-graph.
4749
(let ((temp (assoc-equal pc blink-graph)))
4752
(mv (put-assoc-equal pc (append (cdr temp) (list last-pc)) blink-graph)
4756
(focus-regionp-approvesp
4757
'make-backward-link-graph
4758
(cdr (assoc-eq :focus-regionp dsem-alist))
4768
(mv-let (knowns unknowns)
4769
(next-pcs pc api state)
4770
(make-backward-link-graph-lst knowns pc blink-graph
4772
(cons (cons pc unknowns)
4775
dsem-alist api state)))
4776
(t (mv blink-graph unknowns-alist))))))))
4778
(defun make-backward-link-graph-lst
4779
(pcs last-pc blink-graph unknowns-alist dsem-alist api state)
4781
((endp pcs) (mv blink-graph unknowns-alist))
4782
(t (mv-let (blink-graph unknowns-alist)
4783
(make-backward-link-graph (car pcs) last-pc blink-graph
4784
unknowns-alist dsem-alist api state)
4785
(make-backward-link-graph-lst (cdr pcs) last-pc blink-graph
4787
dsem-alist api state))))))
4789
; Now we build the forward link graph by reversing the links.
4791
(defun make-forward-link-graph1 (pc from-pcs flink-graph)
4793
((endp from-pcs) flink-graph)
4794
(t (make-forward-link-graph1
4797
(put-assoc-equal (car from-pcs)
4798
(cons pc (cdr (assoc-equal (car from-pcs) flink-graph)))
4801
(defun make-forward-link-graph (blink-graph flink-graph)
4802
; Given a backward link graph we reverse the links.
4803
(cond ((endp blink-graph) flink-graph)
4804
(t (make-forward-link-graph
4806
(make-forward-link-graph1 (car (car blink-graph))
4807
(cdr (car blink-graph))
4810
(defun link-graphs (dsem-alist api state)
4812
; Given a machine description we construct the forward link graph and the
4813
; backward link graph. We return (mv unknowns-alist flink-graph blink-graph).
4814
; If unknowns-alist is non-nil, then the pcs listed as keys in it lead to
4815
; unknown (symbolically given) destinations and we return nil link graph
4818
(mv-let (blink-graph unknowns-alist)
4819
(make-backward-link-graph
4820
(cdr (assoc-eq :init-pc dsem-alist))
4821
-1 nil nil dsem-alist api
4824
(unknowns-alist (mv unknowns-alist nil nil))
4825
(t (let ((flink-graph (make-forward-link-graph blink-graph nil)))
4826
(mv nil flink-graph blink-graph))))))
4829
; (A.2) identify loops and halts, the so-called ``cutpoints''
4831
(defun some-element-not-lexorder (lst x)
4833
; We return t if there is a y in lst such that y > x.
4835
(cond ((endp lst) nil)
4836
((lexorder (car lst) x)
4837
(some-element-not-lexorder (cdr lst) x))
4840
(defun loop-pcs (blink-graph)
4841
(cond ((endp blink-graph) nil)
4842
((member-equal (car (car blink-graph)) (cdr (car blink-graph)))
4844
((<= 3 (len (cdr (car blink-graph))))
4845
(cond ((some-element-not-lexorder (cdr (car blink-graph)) (car (car blink-graph)))
4846
(cons (car (car blink-graph))
4847
(loop-pcs (cdr blink-graph))))
4848
(t (loop-pcs (cdr blink-graph)))))
4849
(t (loop-pcs (cdr blink-graph)))))
4850
((<= 2 (len (cdr (car blink-graph))))
4851
(cond ((some-element-not-lexorder (cdr (car blink-graph)) (car (car blink-graph)))
4852
(cons (car (car blink-graph))
4853
(loop-pcs (cdr blink-graph))))
4854
(t (loop-pcs (cdr blink-graph)))))
4855
(t (loop-pcs (cdr blink-graph)))))
4857
; The concept of ``branching pcs'' is defined and executed but its result is
4858
; never actually used. We could delete this function and its call below, if we
4861
(defun branching-pcs (flink-graph)
4862
(cond ((endp flink-graph) nil)
4863
((<= 2 (len (cdr (car flink-graph))))
4864
(cons (car (car flink-graph))
4865
(branching-pcs (cdr flink-graph))))
4866
(t (branching-pcs (cdr flink-graph)))))
4868
(defun halting-pcs (flink-graph)
4869
(cond ((endp flink-graph) nil)
4870
((and (equal (car (car flink-graph))
4871
(car (cdr (car flink-graph))))
4872
(null (cdr (cdr (car flink-graph)))))
4873
(cons (car (car flink-graph))
4874
(halting-pcs (cdr flink-graph))))
4875
(t (halting-pcs (cdr flink-graph)))))
4877
(defun categorize-pcs (flink-graph blink-graph)
4879
; We wrap the foregoing utilities up into one function because it is hard to
4880
; remember which graph to pass to which utility! We return (mv loop-pcs
4881
; branching-pcs halting-pcs cutpoint-pcs). The cutpoint pcs are those in the
4882
; union of the loop pcs and the halting pcs.
4884
(let ((loop-pcs (loop-pcs blink-graph))
4885
(halting-pcs (halting-pcs flink-graph)))
4887
(branching-pcs flink-graph) ; ignored by caller
4889
(union-equal halting-pcs loop-pcs))))
4891
; (A.3) simulate from cutpoint to cutpoint to get composed state transitions,
4892
; called path-tree expressions, along all paths
4894
; Now that we know the cutpoints we can compute the semantics of each path
4895
; between cutpoints.
4897
(defun wrapper-events (api)
4898
(let ((s (access model-api api :svar))
4899
(get-pc (access model-api api :get-pc))
4900
(step (access model-api api :step)))
4906
(set-irrelevant-formals-ok t)
4907
(defun-nx CODEWALKER-WRAPPER
4908
(cnt rpath known-cutpoints splitters depth ,s)
4910
(xargs :measure (nfix (- *snorkel-depth* (nfix depth)))))
4911
(if (or (not (natp depth))
4912
(>= depth *snorkel-depth*))
4913
(CODEWALKER-WRAPPER-SNORKELER
4914
cnt rpath known-cutpoints splitters depth ,s)
4915
(if (or (member-equal ,(make-fn-application get-pc (list s))
4918
(member-equal ,(make-fn-application get-pc (list s))
4923
(cons ,(make-fn-application get-pc (list s)) rpath)
4929
(cons ,(make-fn-application get-pc (list s))
4936
; The function above won't open under ACL2's heuristics, so we force it to
4937
; expand when either the pc is constant or the depth is exceeded. We separate
4938
; the three mutually exclusive cases into three rules, but the hyps -- except
4939
; for the one involving the step function in the third rule -- are not
4940
; expensive because everything involved should be constants.
4942
(defthm codewalker-wrapper-rule-1
4943
(implies (and (natp depth)
4944
(>= depth *snorkel-depth*))
4945
(equal (CODEWALKER-WRAPPER
4946
cnt rpath known-cutpoints splitters depth ,s)
4947
(CODEWALKER-WRAPPER-SNORKELER
4948
cnt rpath known-cutpoints splitters depth ,s))))
4950
(defthm codewalker-wrapper-rule-2
4951
(implies (and (natp depth)
4952
(< depth *snorkel-depth*)
4953
(equal pc ,(make-fn-application get-pc (list s)))
4954
(syntaxp (quotep pc))
4955
; Pc, rpath, and known-cutpoints are all quoted evgs, so this should be evaluable.
4956
(or (member-equal pc rpath)
4958
(member-equal pc known-cutpoints))))
4959
(equal (CODEWALKER-WRAPPER
4960
cnt rpath known-cutpoints splitters depth ,s)
4963
(revappend (cons pc rpath) nil)
4968
(defthm codewalker-wrapper-ignores-splitters
4969
(implies (syntaxp (not (equal splitters *nil*)))
4972
cnt rpath known-cutpoints splitters depth ,s)
4974
cnt rpath known-cutpoints nil depth ,s)))
4977
(enable codewalker-tip-ignores-splitters
4978
codewalker-wrapper-snorkeler-ignores-splitters)))))
4980
(defthm codewalker-wrapper-rule-3
4981
(implies (and (natp depth)
4982
(< depth *snorkel-depth*)
4983
(equal pc ,(make-fn-application get-pc (list s)))
4984
(syntaxp (quotep pc))
4985
; Pc, rpath, and known-cutpoints are all quoted evgs, so this should be evaluable.
4986
(not (or (member-equal pc rpath)
4988
(member-equal pc known-cutpoints))))
4989
; We need to know the next state to compute the new value of splitters.
4990
(equal s1 (,step ,s))
4991
; We bind splitters1 to either '(pc . splitters) or splitters, depending on whether
4992
; the next state has more IFs than the current one.
4993
(bind-free (update-codewalker-splitters ,s s1 pc splitters)
4996
(equal (CODEWALKER-WRAPPER
4997
cnt rpath known-cutpoints splitters depth ,s)
5002
splitters1 ; new value of splitters
5006
(in-theory (disable codewalker-wrapper))
5011
; The functions below should only be executed after the wrapper-events have
5014
(defun collect-terminal-cutpoints (path-tree halting-pcs)
5016
; A ``path-tree'' for pc0 is a normalized IF-expression that contains
5017
; CODEWALKER-TIP expressions at every non-trivial non-tested tip. The
5018
; path-tree for pc0 is equal to the result of running the state (described by
5019
; some implicit api) from pc0 to any known cutpoint. Each codewalker-tip is an
5020
; expression of the form:
5022
; (CODEWALKER-TIP 'k '(pc0 pc1 pc2 ... pck) splitters s')
5024
; where k is the number of steps to go from pc0 to another cutpoint, pck, the
5025
; listed pci are the pcs visited along the path, splitters is the list of pcs
5026
; that introduced additional IFs after rewriting, and s' is state reached along
5027
; that path (and which thus has pc pck).
5029
; This function collects all the terminal pcs listed in the path-tree, except
5030
; those that are halting pcs.
5032
(cond ((variablep path-tree) nil)
5033
((fquotep path-tree) nil)
5034
((eq (ffn-symb path-tree) 'CODEWALKER-TIP)
5035
(let ((k (fargn path-tree 1))
5036
(path (fargn path-tree 2))
5037
; (splitters (fargn path-tree 3)) ; splitters is irrel here.
5038
; (s1 (fargn path-tree 4)) ; state is irrel here
5040
(cond ((and (quotep k)
5043
(true-listp (cadr path))
5044
(equal (+ 1 (cadr k))
5045
(length (cadr path))))
5046
(let ((pck (car (last (cadr path)))))
5047
(cond ((member-equal pck halting-pcs)
5051
(er hard 'path-tree-tuple-from-cutpoint
5052
"In every (CODEWALKER-TIP k path ...) term, k is ~
5053
supposed to be a quoted natural indicating how many ~
5054
steps were taken, path is supposed to be a quoted ~
5055
true-list of the pcs visited along the path, and the ~
5056
length of path is supposed to be one greater than k. ~
5057
These invariants are not met by ~X01."
5060
((EQ (ffn-symb path-tree) 'IF)
5061
(union-equal (collect-terminal-cutpoints (fargn path-tree 2) halting-pcs)
5062
(collect-terminal-cutpoints (fargn path-tree 3) halting-pcs)))
5063
((eq (ffn-symb path-tree) 'CODEWALKER-WRAPPER)
5064
(er hard 'path-tree-tuple-from-cutpoint
5065
"Every tip in a path-tree is supposed to be a CODEWALKER-TIP ~
5066
expression and we've just encountered the CODEWALKER-WRAPPER ~
5067
term shown below. Look at the last argument, <s>, of that ~
5068
term, which is supposed to simplify to some semi-explicit ~
5069
state. We probably cannot determine the pc of <s>. This is ~
5070
generally an indication that the rewriter has insufficient ~
5071
rules to simplify such a term. You might submit the following ~
5072
challenge to ACL2 and see if you can prove rules to rewrite the ~
5073
left-hand side of the conclusion to a quoted constant.~%(thm ~
5074
(implies <hyps> (equal (<get-pc> <s>) xxx)))~%where <hyps> and ~
5075
<get-pc> are the :hyps and :get-pc of your model's API. This is ~
5076
clearly not a theorem -- note the arbitrary xxx -- but you need ~
5077
the left-hand side of the conclusion to simplify to a quoted ~
5078
constant! ~%~%Unexpected tip in path-tree, ~X01."
5081
(t (er hard 'path-tree-tuple-from-cutpoint
5082
"Every tip in a path-tree is supposed to be a CODEWALKER-TIP ~
5083
expression and we've just encountered an unexpected tip: ~X01."
5087
(defun max-snorkel-data (tuple1 tuple2)
5088
; See the next function.
5090
((null tuple1) tuple2)
5091
((null tuple2) tuple1)
5092
(t (let ((step-cnt1 (car tuple1))
5093
(cont-cnt1 (cadr tuple1))
5094
(nest-depth1 (caddr tuple1))
5095
(splitters1 (cadddr tuple1))
5096
(step-cnt2 (car tuple2))
5097
(cont-cnt2 (cadr tuple2))
5098
(nest-depth2 (caddr tuple2))
5099
(splitters2 (cadddr tuple2)))
5101
((not (equal step-cnt1 step-cnt2))
5102
(er hard 'snorkel-data
5103
"We thought the step counts of all CODEWALKER-WRAPPER-SNORKELER ~
5104
terms would be equal but they are not! We see these two ~
5105
tuples:~%tuple1 = ~x0~%~tuple2 = ~x1~%"
5108
(+ cont-cnt1 cont-cnt2)
5109
(max nest-depth1 nest-depth2)
5110
(union-equal splitters1 splitters2))))))))
5114
(defun snorkel-data (term depth)
5116
; This function returns non-nil iff term contains CODEWALKER-WRAPPER-SNORKELER
5119
; When non-nil, the answer is a tuple:
5120
; (step-cnt continuation-cnt nesting-depth splitters),
5123
; * step-cnt is the number of steps taken so far. It is always a multiple of
5126
; * continuation-cnt is the number of continuations, i.e.,
5127
; * CODEWALKER-WRAPPER-SNORKELER terms, in the partial path tree
5129
; * nesting-depth is the function-nesting depth of the deepest continuation.
5131
; * splitters is the list of pcs causing splits
5133
(cond ((variablep term) nil)
5134
((fquotep term) nil)
5135
((eq (ffn-symb term) 'IF)
5137
(snorkel-data (fargn term 2) (+ 1 depth))
5138
(snorkel-data (fargn term 3) (+ 1 depth))))
5139
((eq (ffn-symb term) 'CODEWALKER-WRAPPER-SNORKELER)
5140
(list (cadr (fargn term 1)) ; step cnt evg
5141
1 ; continuation cnt
5142
depth ; nesting depth
5143
(cadr (fargn term 4)) ; splitters
5145
(t (snorkel-data-lst (fargs term) (+ 1 depth)))))
5147
(defun snorkel-data-lst (terms depth)
5148
(cond ((endp terms) nil)
5149
(t (max-snorkel-data
5150
(snorkel-data (car terms) depth)
5151
(snorkel-data-lst (cdr terms) depth))))))
5154
(defun abstract-snorkeled-path-tree (term)
5156
((variablep term) term)
5157
((fquotep term) term)
5158
((equal (ffn-symb term) 'if)
5161
(abstract-snorkeled-path-tree (fargn term 2))
5162
(abstract-snorkeled-path-tree (fargn term 3))))
5163
((equal (ffn-symb term) 'codewalker-tip)
5165
((equal (ffn-symb term) 'codewalker-wrapper-snorkeler)
5166
(list :CONTINUATION-FROM-PC (car (cadr (fargn term 2)))))
5167
(t (cons-term (ffn-symb term)
5168
(abstract-snorkeled-path-tree-lst (fargs term))))))
5169
(defun abstract-snorkeled-path-tree-lst (terms)
5170
(cond ((endp terms) nil)
5171
(t (cons (abstract-snorkeled-path-tree (car terms))
5172
(abstract-snorkeled-path-tree-lst (cdr terms)))))))
5176
(defun replace-codewalker-wrapper-snorkelers (term)
5178
; In preparation for diving in again, we copy term and replace all the
5179
; CODEWALKER-WRAPPER-SNORKLER terms with fresh CODEWALKER-WRAPPER terms (with
5180
; depth reset to 0).
5182
(cond ((variablep term) term)
5183
((fquotep term) term)
5184
((eq (ffn-symb term) 'IF)
5187
(replace-codewalker-wrapper-snorkelers (fargn term 2))
5188
(replace-codewalker-wrapper-snorkelers (fargn term 3))))
5189
((eq (ffn-symb term) 'CODEWALKER-WRAPPER-SNORKELER)
5190
(cons-term* 'CODEWALKER-WRAPPER
5191
(fargn term 1) ; step cnt for this path so far
5192
(fargn term 2) ; rpath
5193
(fargn term 3) ; known-cutpoints
5194
(fargn term 4) ; splitters
5195
*0* ; depth in this round, reset to 0!
5196
(fargn term 6) ; machine state so far
5198
(t (cons-term (ffn-symb term)
5199
(replace-codewalker-wrapper-snorkelers (fargs term))))))
5201
(defun replace-codewalker-wrapper-snorkelers-lst (terms)
5202
(cond ((endp terms) nil)
5203
(t (cons (replace-codewalker-wrapper-snorkelers (car terms))
5204
(replace-codewalker-wrapper-snorkelers-lst (cdr terms)))))))
5206
(defun simplify-codewalker-wrapper-under-hyps-with-snorkeling
5207
(hyps concl pc0 last-data state)
5209
; We may eventually wish to implement some sort of loop stopping check in which
5210
; we compare the current data tuple with the last one. But at the moment we
5211
; don't because it is thought possible that successive data tuples might be
5212
; identical even though simplifications occurred, e.g., because the simplifier
5213
; for some reason worked on terms in the expression other than
5214
; codewalker-wrapper terms.
5216
(declare (ignore last-data))
5218
; We simplify concl under hyps and return the resulting term. However, we
5219
; implement snorkeling, but it is triggered only by
5220
; CODEWALKER-WRAPPER-SNORKELER terms in the answer. Thus, this is is NOT a
5221
; general-purpose simplify-under-hyps with snorkeling!
5223
(let* ((path-tree (simplify-under-hyps hyps concl state))
5224
(data (snorkel-data path-tree 0)))
5226
; If data is non-nil, then it is (max-depth . (cnt1 ... cntn)) and path-tree is
5227
; only partially simplified. In particular, the stack depth was in danger of
5228
; being exceeded and so the simplifier quit and replaced the codewalker-wrapper
5229
; term it was simplifying by a codewalker-wrapper-snorkeler term. The stack
5230
; near-overflow was almost certainly due to long paths through the code,
5231
; requiring many steps, the simplification of each of which pushes a new frame.
5232
; So if data is non-nil, we print a rather brief report and recur. It is hoped
5233
; the user will abort the computation if it seems not to be making progress!
5239
(let ((step-cnt (car data))
5240
(continuation-cnt (cadr data))
5241
(nesting-depth (caddr data))
5242
(splitters (cadddr data)))
5244
(fms "SNORKEL REPORT: pc: ~x0; steps ~x1~%number of continuations: = ~
5245
~x2~%nesting depth: ~x3~%splitter pcs: ~X46~%partial-path-tree = ~
5247
(list (cons #\0 pc0)
5249
(cons #\2 continuation-cnt)
5250
(cons #\3 nesting-depth)
5251
(cons #\4 (merge-sort-lexorder splitters))
5252
(cons #\5 (abstract-snorkeled-path-tree path-tree))
5257
(simplify-codewalker-wrapper-under-hyps-with-snorkeling
5259
(replace-codewalker-wrapper-snorkelers path-tree)
5260
pc0 ; beginning of path
5264
(defun path-tree-tuple-from-cutpoint (cutpoint known-cutpoints halting-pcs api state)
5266
; A path-tree-tuple is a 3-tuple (list start-pc (terminal-pc1 ...) path-tree),
5267
; where path-tree is a path-tree from initial pc start-pc, the list of terminal
5268
; pcs includes every non-halting terminal pc in the path-tree.
5270
(let* ((hyps (access model-api api :hyps))
5271
(s (access model-api api :svar))
5272
(put-pc (access model-api api :put-pc)))
5275
(simplify-codewalker-wrapper-under-hyps-with-snorkeling
5277
`(CODEWALKER-WRAPPER '0 'NIL ',known-cutpoints 'NIL '0
5278
,(make-fn-application put-pc
5279
(list (kwote cutpoint) s)))
5280
cutpoint nil state))) ; starting pc, last-data, ACL2 STATE
5283
(collect-terminal-cutpoints path-tree halting-pcs) path-tree)))))
5285
(defun path-tree-tuples-from-cutpoint-lst
5286
(cutpoint-lst known-cutpoints halting-pcs api state)
5288
; This is a simple ``workhorse'' that iterates over cutpoints and collects a
5289
; path tree tuple for each one.
5292
((endp cutpoint-lst) (value nil))
5293
(t (er-let* ((tuple (path-tree-tuple-from-cutpoint
5295
known-cutpoints halting-pcs api state))
5296
(rest (path-tree-tuples-from-cutpoint-lst
5298
known-cutpoints halting-pcs api state)))
5299
(value (cons tuple rest))))))
5302
; (A.4) compute reflexive-transitive closure of cutpoint-to-cutpoint relations
5303
; to construct a call graph, inducing an order the clock and semantic
5306
; However, the code for call-graph-ordering is not in this book. It is in the
5307
; Terminatricks book.
5309
; (A.5) define clock and semantic functions from the path-tree expressions;
5310
; this would be straightforward except for two important additions:
5311
; (A.5.1) identifying certain trivial invariants that may be crucial to
5313
; (A.5.2) removing mutual recursion.
5315
; From each path-tree-tuple we generate a clock function defun, pairing the
5316
; defun with its start-pc:
5318
(defun pair-fns-with-level-nos (fns wrld)
5319
(cond ((endp fns) nil)
5320
(t (cons (cons (get-level-no (car fns) wrld)
5322
(pair-fns-with-level-nos (cdr fns) wrld)))))
5324
(defun fn-symb-with-max-level-no (fn wrld)
5325
(cond ((symbolp fn) fn)
5329
(pair-fns-with-level-nos
5330
(all-fnnames (lambda-body fn)) wrld)))))))
5332
(defun generate-def-semantics-name (str1 pc-lst str2 dsem-alist api)
5333
; Note: The :root-name in the api is always a string ending in #\-.
5334
(let ((root-name (cdr (assoc-eq :root-name dsem-alist)))
5335
(base (access model-api api :name-print-base)))
5336
(intern-in-package-of-symbol
5338
(fmt1-to-string "~s1~sr~*p~s2"
5339
(list (cons #\1 str1)
5340
(cons #\r root-name)
5347
(cons #\p `("" "~sb~x*" "~sb~x*-" "~sb~x*-" ,pc-lst))
5351
(list (cons 'print-base base)))
5352
(declare (ignore col))
5354
(access model-api api :package-witness))))
5356
(defun fnsymbol-name-prefix (kind)
5358
; Kind is either :CLOCK or :SEMANTIC and this function returns the prefix
5359
; string we use when forming fnnames of that kind. Warning: If you change the
5360
; prefix strings used, be sure to to change get-kind-from-fnsymbol-name!
5362
(if (eq kind :CLOCK) "CLK-" "SEM-"))
5364
(defun get-kind-from-fnsymbol-name (str)
5366
; Str is the symbol name, i.e., a string, of either a :CLOCK or :SEMANTIC
5367
; function. We return the kind. It is convenient that both CLK- and SEM- are
5368
; four characters long! We cause a hard error if str is not of one of the two
5371
(let ((msg "This function is supposed to be applied to a string whose ~
5372
initial prefix is either \"CLK-\" or \"SEM-\" and ~x0 is ~
5374
(cond ((and (stringp str)
5375
(<= 3 (length str)))
5376
(cond ((and (eql (char str 0) #\C)
5377
(eql (char str 1) #\L)
5378
(eql (char str 2) #\K)
5379
(eql (char str 3) #\-))
5381
((and (eql (char str 0) #\S)
5382
(eql (char str 1) #\E)
5383
(eql (char str 2) #\M)
5384
(eql (char str 3) #\-))
5386
(t (er hard 'get-kind-from-fnsymbol-name msg str))))
5387
(t (er hard 'get-kind-from-fnsymbol-name msg str)))))
5389
(defun snorkel-clock-expr (fn k clk)
5391
; Fn is the clk+ function from the API, k is a nat, and clk is either NIL or a
5392
; clock expression term. We form an untranslated clock expression term that
5393
; represents k or (clk+ k clk), depending on clk, except k is snorkeled.
5396
((<= k *snorkel-depth*)
5398
((null clk) (kwote k))
5399
(t (make-fn-application fn (list (kwote k) clk)))))
5400
(t (make-fn-application
5402
(list (kwote *snorkel-depth*)
5403
(snorkel-clock-expr fn (- k *snorkel-depth*) clk))))))
5405
(defun generate-clock-function-body (path-tree halting-pcs dsem-alist api)
5406
(cond ((variablep path-tree) 0)
5407
((fquotep path-tree) 0)
5408
((eq (ffn-symb path-tree) 'CODEWALKER-TIP)
5409
; (CODEWALKER-TIP k path splitters s), k, path, and splitters quoted consts
5410
(let* ((k (cadr (fargn path-tree 1))) ; (fargn path-tree 1) is QUOTEd
5412
(path (fargn path-tree 2))
5413
; (splitters (fargn path-three 3))
5414
(s1 (fargn path-tree 4))
5415
(pck (car (last (cadr path)))))
5416
(cond ((member-equal pck halting-pcs)
5417
(snorkel-clock-expr (access model-api api :clk+)
5421
(equal (nth (- k 1) ; next to last element
5422
(cadr path)) ; of path
5424
; Path terminated in a stutter, pc0 --> pc1 --> ... --> pck --> pck.
5425
(snorkel-clock-expr (access model-api api :clk+)
5428
(t (snorkel-clock-expr
5429
(access model-api api :clk+)
5431
(make-fn-application
5432
(generate-def-semantics-name (fnsymbol-name-prefix :clock)
5437
((EQ (ffn-symb path-tree) 'IF)
5440
(generate-clock-function-body (fargn path-tree 2)
5443
(generate-clock-function-body (fargn path-tree 3)
5446
(t (er hard 'generate-clock-function-body
5447
"Unexpected tip in path-tree, ~x0."
5450
(defun generate-semantic-function-body (path-tree halting-pcs dsem-alist api)
5451
(cond ((variablep path-tree) (access model-api api :svar))
5452
((fquotep path-tree) (access model-api api :svar))
5453
((eq (ffn-symb path-tree) 'CODEWALKER-TIP)
5454
; (CODEWALKER-TIP k path splitters s), k, path, and splitters quoted consts
5455
(let* ((k (fargn path-tree 1))
5456
(path (fargn path-tree 2))
5457
; (splitters (fargn path-three 3))
5458
(s1 (fargn path-tree 4))
5459
(pck (car (last (cadr path)))))
5460
(cond ((member-equal pck halting-pcs)
5462
((and (>= (cadr k) 1)
5463
(equal (nth (- (cadr k) 1)
5466
; Path terminated in a stutter, pc0 --> pc1 --> ... --> pck --> pck.
5468
(t `(,(generate-def-semantics-name
5469
(fnsymbol-name-prefix :semantic)
5474
((EQ (ffn-symb path-tree) 'IF)
5477
(generate-semantic-function-body (fargn path-tree 2)
5480
(generate-semantic-function-body (fargn path-tree 3)
5483
(t (er hard 'generate-semantic-function-body
5484
"Unexpected tip in path-tree, ~x0."
5487
; But we don't need a logic-mode version of undistribute-if. But we were
5488
; concerned about its correctness so we admitted it in :logic mode and proved
5489
; the theorem we cared most about. We have commented out those events but left
5490
; them for posterity.
5492
; (defun tip-cnt (term)
5493
; (declare (xargs :mode :logic))
5494
; (cond ((variablep term) 1)
5495
; ((fquotep term) 1)
5496
; ((eq (ffn-symb term) 'IF)
5497
; (+ (tip-cnt (fargn term 2))
5498
; (tip-cnt (fargn term 3))))
5501
; The following will be admited in :program mode in this file but could be
5502
; admitted in :logic mode after the definition of tip-cnt above.
5504
(defun undistribute-ifs (term)
5505
(declare (xargs :measure (tip-cnt term)))
5507
((variablep term) term)
5508
((fquotep term) term)
5509
((eq (ffn-symb term) 'IF)
5510
(let ((a (fargn term 1))
5511
(b (undistribute-ifs (fargn term 2)))
5512
(c (undistribute-ifs (fargn term 3))))
5515
; Because this function is doubly recursive (``reflexive'') we have to test the
5516
; measure on the nested recursions. When operating in :logic mode I'd leave
5517
; these tests in and then prove that they are always true after the function is
5518
; admitted. But for :program mode purposes we don't need these tests.
5519
; ((or (not (<= (tip-cnt b) (tip-cnt (fargn term 2))))
5520
; (not (<= (tip-cnt c) (tip-cnt (fargn term 3)))))
5523
((and (or (variablep b)
5525
(not (eq (ffn-symb b) 'IF)))
5528
(eq (ffn-symb c) 'IF))
5529
(let ((c1 (fargn c 1))
5533
; The term is of the form (if a b (if c1 c2 c3)). We are here enforcing two
5536
; (if a xxx (if c1 xxx c3)) = (if (or a c1) xxx c3) b and c2 the same
5537
; (if a xxx (if c1 c2 xxx)) = (if (or a (not c1)) xxx c2) b and c3 the same
5542
`(if (if ,a 't ,c1) ,b ,c3)))
5545
`(if (if ,a 't (NOT ,c1)) ,b ,c2)))
5546
(t `(if ,a ,b ,c)))))
5547
((and (or (variablep c)
5549
(not (eq (ffn-symb c) 'IF)))
5552
(eq (ffn-symb b) 'IF))
5553
(let ((b1 (fargn b 1))
5557
; The term is of the form (if a (if b1 b2 b3) c). We are here enforcing two
5560
; (if a (if b1 xxx b3) xxx) = (if (or (not a) b1) xxx b3) b2 and c the same
5561
; (if a (if b1 b2 xxx) xxx) = (if (or (not a) (not b1)) xxx b2) b3 and c the same
5566
`(if (if (NOT ,a) 't ,b1) ,c ,b3)))
5569
`(if (if (NOT ,a) 't (NOT ,b1)) ,c ,b2)))
5570
(t `(if ,a ,b ,c)))))
5571
(t `(if ,a ,b ,c)))))
5574
; Here we prove that the tests for the nested recursions both succeed.
5575
; (defthm tip-cnt-undistribute-ifs
5576
; (<= (tip-cnt (undistribute-ifs x)) (tip-cnt x))
5577
; :rule-classes :linear)
5579
; Now we define an evaluator for IF- and NOT-expressions.
5581
; (defevaluator if-evaluator if-evaluator-lst ((IF a b c) (not a)))
5583
; And here is the theorem that undistribute-if preserves the meaning of
5586
; (thm (equal (if-evaluator (undistribute-ifs x) a)
5587
; (if-evaluator x a)))
5589
; The clock and semantic functions we generate from the path-tree-tuples are
5590
; actually non-executable functions, i.e., we generate DEFUN-NX events, not
5591
; DEFUN events. The reason is that the bodies are created by rewriting and
5592
; hence all available simplifying rules have been applied to them. There is no
5593
; guarantee that the stobj state is still used in a single-threaded way. We
5594
; could generate DEFUNs if the :stobjp field of api is nil, but we don't.
5596
(defun generate-clock-function-defun-pair
5597
(path-tree-tuple halting-pcs dsem-alist api)
5599
; We generate a pair of the form (pc . (event1 event2 ...)). Except, in the
5600
; present case, the only event in the list is a DEFUN-NX or DEFUNM-NX of the
5601
; clock function that starts at the beginning of the path tree tuple. The same
5602
; holds true of generate-semantic-function-defun-pair.
5604
; Another hidden constraint on this function and on its twin,
5605
; generate-semantic-function-defun-pair, is that the body of the generated
5606
; function is ALWAYS of a translated term of the form
5608
; (IF <conjoined-hyps-from-api>
5609
; <codewalk-results>
5612
; Thus, we know (fargn <body> 1) is just the :hyps from the api and (fargn
5613
; <body> 2) is the term produced by the codewalk. (<base> will be '0 for clock
5614
; functions and svar for semantic functions.) This is important because we
5615
; will explore these un-admitted but translated bodies to detect simple
5616
; invariants and then will insert those invariants into the test of the IF
5619
; Later we'll use the pc keys of all such pairs to put the events into call
5620
; graph order. But there is a major wrinkle. If the call graph requires
5621
; functions f and g to be defined mutually recursively, we will not define f
5622
; and g in a MUTUAL-RECURSION but instead make up a new name, fg, and define a
5623
; flagged version of a combined f and g. But that will mean also changing all
5624
; the events that call and/or disable f and g so as to use the new name and
5625
; appropriate flag value. Similarly, if we have to put two correctness
5626
; theorems together we generate the more general flagged theorem and
5627
; appropriately handle the subsequent disabling of the clock.
5629
; To be precise: This function and generate-semantic-function-defun-pair
5632
; (pc . ((def clk/sem-fn (svar) ...dcls... body))),
5634
; where def is either DEFUN-NX or DEFUNM-NX, depending on whether the dcls
5635
; include any provided by the user.
5637
; Note in particular the extra level of parens after the dot! The cdr of the
5638
; pair is a list of events. But in the case of defun-pairs (as generated for
5639
; both clock and semantic functions) it is always a singleton list of events!
5641
; Warning: If this form is violated, reconsider the handling of mutually
5642
; recursive functions as described in the Essay on Mutually Recursive
5645
(let* ((pc0 (car path-tree-tuple))
5646
(path-tree (caddr path-tree-tuple))
5647
(s (access model-api api :svar))
5648
(clk-fn (generate-def-semantics-name (fnsymbol-name-prefix :clock)
5654
(cdr (assoc-eq :annotations dsem-alist))))
5656
; user-supplied-dcls must be one of two forms: (clk-fn (DECLARE ...)) or
5657
; (clk-fn :keyword ...). If the former, the user is taking over; if
5658
; the latter, we just extend the XARGS. See the Essay on Annotations.
5660
(body (generate-clock-function-body path-tree halting-pcs
5662
(body1 `(IF ,(conjoin (access model-api api :hyps))
5665
(defcmd (if (and user-supplied-pair
5666
(consp (cadr user-supplied-pair)))
5669
(dcls (if (and user-supplied-pair
5670
(consp (cadr user-supplied-pair)))
5671
(cdr user-supplied-pair)
5672
(if (eq (access model-api api :stobjp) t)
5675
,@(cdr user-supplied-pair)
5676
:STOBJS (,(access model-api api :svar)))))
5679
,@(cdr user-supplied-pair))))))))
5680
; Recall important invariants: cdr is a singleton list with some flavor of
5681
; defunm whose body is an (IF <hyps-of-api> <body> '0).
5683
`((,defcmd ,clk-fn (,s)
5687
(defun generate-clock-function-defun-pairs
5688
(path-tree-pairs halting-pcs dsem-alist api)
5690
((endp path-tree-pairs) nil)
5691
(t (cons (generate-clock-function-defun-pair
5692
(car path-tree-pairs)
5693
halting-pcs dsem-alist api)
5694
(generate-clock-function-defun-pairs
5695
(cdr path-tree-pairs)
5696
halting-pcs dsem-alist api)))))
5698
(defun generate-semantic-function-defun-pair
5699
(path-tree-tuple halting-pcs dsem-alist api)
5701
; See the comment in generate-clock-function-defun-pair.
5703
; Warning: See the warning in the above function too!
5705
(let* ((pc0 (car path-tree-tuple))
5706
(path-tree (caddr path-tree-tuple))
5707
(s (access model-api api :svar))
5708
(sem-fn (generate-def-semantics-name (fnsymbol-name-prefix :semantic)
5714
(cdr (assoc-eq :annotations dsem-alist))))
5715
(body (generate-semantic-function-body path-tree halting-pcs
5717
(body1 `(IF ,(conjoin (access model-api api :hyps))
5719
,(access model-api api :svar)))
5720
(defcmd (if (and user-supplied-pair
5721
(consp (cadr user-supplied-pair)))
5724
(dcls (if (and user-supplied-pair
5725
(consp (cadr user-supplied-pair)))
5726
(cdr user-supplied-pair)
5727
(if (eq (access model-api api :stobjp) t)
5730
,@(cdr user-supplied-pair)
5731
:STOBJS (,(access model-api api :svar)))))
5734
,@(cdr user-supplied-pair))))))))
5736
`((,defcmd ,sem-fn (,s)
5740
(defun generate-semantic-function-defun-pairs
5741
(path-tree-pairs halting-pcs dsem-alist api)
5742
(cond ((endp path-tree-pairs) nil)
5743
(t (cons (generate-semantic-function-defun-pair
5744
(car path-tree-pairs)
5745
halting-pcs dsem-alist api)
5746
(generate-semantic-function-defun-pairs
5747
(cdr path-tree-pairs)
5748
halting-pcs dsem-alist api)))))
5750
; Note: the following pairs of functions are clones of each other.
5753
; generate-clock-function-body generate-semantic-function-body
5754
; generate-clock-function-defun-pair generate-semantic-function-defun-pair
5756
; For each starting pc, we generate a CLK-root-name-pc and SEM-root-name-pc.
5759
; (A.5.1) identifying certain trivial invariants that may be crucial to
5762
; Essay on the Design of a Simple Invariant Detector: Disguised Constants
5764
; Note: This essay recapitulates the sketch of (A.5.1) but with still more
5765
; implementation-level detail. It was written prior to the Guide and the
5766
; example developed therein. Thus, the example is different and the imagined
5767
; machine model is different. Translating from the essay's model to the
5768
; Guide's, this essay's ``(rd (:loc 1) s)'' is the Guide's ``(nth 1 (rd :locals
5771
; Suppose a piece of code loads -1 into local 2 then iterates, counting local 1
5772
; down by successively adding local 2 to it. The recursive calls of the loop
5773
; clock and semantics functions will be on some state expression like this:
5775
; (wr (:LOC 1) (+ (rd (:LOC 1) s) (rd (:LOC 2) s)) s)
5777
; or, if we think of r1 and r2 as the two virtual formals:
5780
; r2 <-- r2; [implicit, by virtue of being absent]
5782
; which has an obvious expression as a vcall with :slot expressions.
5784
; Of course there's no way to admit this function since we have not recorded
5785
; the fact that r2, i.e., (:LOC 2), is constantly -1. We call r2, i.e., (rd
5786
; '(:LOC 2) s), a ``disguised constant'' in this function. The purpose of this
5787
; next section is to detect such simple invariants and modify the definition of
5788
; the loop function (and its correctness theorem) appropriately. To do this we
5789
; must inspect the entire system of proposed definitions.
5791
; This discussion focuses first on simple loops, i.e., singly recursive
5792
; functions. Then we discuss modifications for multiple loops, i.e., flagged
5793
; mutual recursions.
5795
; For example, let CLK-0 and SEM-0 be the respective top-level clock and
5796
; semantic functions (which load (:LOC 2) with -1) and let CLK-2 and SEM-2 be
5797
; the loop functions. Then in a case like that described above we will see:
5799
; (defunm clk-0 (s) ; Top-level entry initializes
5800
; (c+ '2 (clk-2 (wr '(:LOC 2) '-1 s)))) ; disguised constant
5802
; (defunm clk-2 (s) ; Loop function uses it but
5803
; (if <hyps-from-api> ; does not alter it.
5804
; (if (equal (rd '(:LOC 1) s) '0)
5806
; ...(clk-2 (wr '(:LOC 1)
5807
; (+ (rd '(:LOC 1) s) (rd '(:LOC 2) s))
5811
; and a similar arrangement for sem-0 and sem-2. The key property, in this
5812
; simple case, is that every function that calls clk-2 (except clk-2 itself)
5813
; sets '(:LOC 2) to '-1 and clk-2 does not change '(:LOC 2).
5815
; Things get more complicated for nested loops. Consider a program with a
5816
; top-level entry that calls an outer loop which calls an inner loop. Given
5817
; the way we actually translate this, the top-level calls the outer loop, which
5818
; calls the inner loop, which calls itself and the outer loop. Suppose both
5819
; loops use distinct disguised constants. There are two possibilities, (a) the
5820
; top-level initializes both disguised constants and the loops just use them,
5821
; or (b) the top-level initializes the outer loop's constant and the outer loop
5822
; initializes the inner loop's constant. In either case, we see something
5823
; different than the simple case described above: it's possible for a loop
5824
; function that uses a disguised constant to be called without that constant
5825
; being explicitly set by the caller. Instead, that constant's value is
5826
; ``passed through.'' This is easy to to see in case (a): the top level set
5827
; the constant for the inner loop and the outer loop just calls the inner loop
5828
; on a state that's already been set up. But this also happens in case (b)
5829
; because the inner loop calls the outer loop without setting the outer loop's
5832
; So the key to discovering disguised constants is to propagage assignments of
5833
; constants through the entire system of definitions.
5835
; To make the discovery of disguised constants a little simpler, we introduce
5836
; the notion of a call of a function on virtual formals, or a so-called
5837
; ``vcall.'' Given a call of a clk or sem function, gn, on a modified state,
5838
; the corresponding vcall is of the form (gn ...(:SLOT v_i a_i)...), where the
5839
; :SLOT expressions are as in Terminatricks. We thus transform calls like:
5841
; (clk-2 (wr '(:LOC 1) (+ (rd '(:LOC 1) s) (rd '(:LOC 2) s))
5845
; into the ``vcall''
5847
; (clk-2 (:SLOT ':PC '2)
5848
; (:SLOT '(:LOC 1) (+ (rd '(:LOC 1) s) (rd '(:LOC 2) s)))
5849
; (:SLOT '(:LOC 4) '17))
5851
; A vcall is a pair consisting of a function symbol consed onto a list of :SLOT
5852
; expressions in arbitary order.
5854
; We convert the entire system of preliminary definitions into an alist of
5855
; pairs of the form (fn pc . vcalls), where vcalls is the list of all vcalls
5856
; appearing in the body of the preliminary defun of fn. The resulting alist is
5857
; named fn-to-pc-and-vcalls-alist.
5859
; We now turn to the discovery of disguised constants. This is done by
5860
; building another data structure recording what we know about the vformals
5861
; upon entry to each function in the system. One pass over the entire system
5862
; definition, is called a ``step.'' We iterate steps until the recorded facts
5863
; no longer change. So the key is what we do in one such step.
5865
; One step of constant propagation sweeps through the entire system of
5866
; definitions and propagates knowledge of constants much like the Java Byte
5867
; Code Verifier propagates type signatures. We record our discovered knowledge
5868
; in an alist that pairs function names with alists that record what we know
5869
; about the virtual formals upon every entry (visited so far) to the associated
5870
; function. A typical entry in ans is:
5872
; (fn . (...(v_i . u_i)...))
5874
; where the v_i are virtual formals and the u_i record what we know about the
5875
; value of v_i on every call of fn. We call (...(v_i . u_i)...) the ``vformal
5876
; alist for fn.'' U_i is either :changing, meaning that the value of v_i has
5877
; been seen to change in some ``arbitrary'' way, or u_i is a non-empty
5878
; true-list of evgs, meaning that v_i takes on one of those explicit values on
5879
; each call. If a vformal is not mentioned in the vformal alist for fn it
5880
; means that we haven't (yet) seen any assignment to it, which makes it an
5881
; unchanging vformal (so far).
5883
; Now imagine that we are in function g. The vformal alist for g will tell us
5884
; what we know about some vformals. Imagine that g calls f after setting some
5885
; vformal, v_i to some actual a_i. We will have a vformal alist for f. How do
5886
; we modify it in light of this call and its current context?
5888
; First, every (v_i . u_i) pair in the vformal alist for g that is not
5889
; overridden by a slot in the call of f, should be ``merged'' into the vformal
5892
; Second, we merge (v_i . u) -- and we do mean ``u'' not ``u_i'' -- into the
5893
; vformal alist for fn, where u is derived from a_i as follows: if a_i is a
5894
; quoted constant, u is the singleton list containing the evg of that constant
5895
; (so we can just union it into other such lists); else u is :changing.
5897
; To merge (v_i . u_i) into an alist with no v_i entry is just to add (v_i
5898
; . u_i) to it. To merge (v_i . u_i) into an alist containing (v_i . w_i) we
5899
; take the weaker of the u_i and w_i: if either is :changing we use :changing,
5900
; if both are constants/lists of constants, we combine them into a longer list.
5901
; (Remember that the basic meaning of a u_i is a disjunction, so if v_i is 1 or
5902
; 2 or v_i is 3 or 4, then v_i is 1 or 2 or 3 or 4.)
5904
; Eventually this iterated step process will stabilize. When it does, we will
5905
; have identified some supposed invariants about certain v_i in certain fn,
5906
; namely, for every (v_i . u_i) in fn's vformal-alist (except those where u_i
5907
; is :changing) we know that every entry to fn has v_i set to a member of u_i.
5908
; Those v_i are the ``disguised constants'' of fn and u_i is the ``range.''
5910
; If v is a disguised constant with range r in fn, then we can modify the hyps
5911
; in fn governing the recursive calls of fn with the additional conjunct
5912
; (member v 'r). This can be optimized in the case that r is a singleton list.
5914
; We need not perform this modification on the correctness theorem. This was a
5915
; surprising discovery (forced by repeatedly trying to figure out the right hyp
5916
; to add). How could it be that (m1 s (clk s)) = (sem s), if sem uses a
5917
; disguised constant, v_i, and we haven't stipulated in the correctness theorem
5918
; that v_i is in the range u_i?
5920
; The reason is that (clk s) on the left-hand side of the conclusion contains
5921
; the test that v_i is in u_i and if that condition is violated, clk returns 0
5922
; so the left-hand side is S. The exact same test is in (sem s) and it also
5923
; produces S. So this is a ``convenient weakness.'' Convenient because we
5924
; needn't modify correctness theorems, and a weakness because it means our
5925
; correctness theorems have some ``hidden'' hypotheses, namely the v_i in u_i
5926
; conditions. But the only way to eliminate these hidden hypotheses would be
5927
; to replace the disguised constants with actual constants and redefine clk and
5928
; sem to be terminating without the range conditions and then insert the range
5929
; conditions into the correctness theorem hyps.
5931
; The culmination of all our processing of disguised constants is the
5932
; disguised-constant-4-tuple-lst, which is a list of 4-tuples of the form: (fn
5933
; pc v_i u'_i), where u'_i is the lexordered range of the disguised constant
5934
; v_i in fn (which was derived starting at pc).
5936
; We will check that the disguised constant 4-tuple for a clock function at a
5937
; given pc is identical (in v_i and u'_i) to that for the semantic function at
5938
; pc. This can be done by computing the 4-tuples for all the clock functions
5939
; and for all the semantic functions, stripping off the cars (the idiosyncratic
5940
; clock or semantic function symbols) and comparing the two lists of triples
5943
; Once this check has been performed, we may use either list of 4-tuples as
5944
; long as we key on the pc. It is from this list of 4-tuples that we generate
5945
; the (member v 'r) hyps to insert into the definitions, based on the pc
5948
; Now we discuss how all this fits into the basic flow of def-semantics. The key
5949
; function is def-semantics-post-events, where we use
5951
; generate-clock-function-defun-pairs
5952
; generate-semantic-function-defun-pairs
5954
; to produce lists of pcs paired with singleton lists of events. At this point
5955
; in the flow, even multiple loops are coded as separate recursive functions
5956
; (that will be combined into a flagged singly recursive function later in the
5959
; Note that we cannot identify disguised constants until we have made the first
5960
; cut at generating the clock and semantic function definitions. We call these
5961
; the ``preliminary'' definitions, since our intent is possibly to modify them.
5963
; So we first generate the preliminary clock and semantic function defun pairs,
5964
; from each we generate a fn-to-pc-and-vcalls-alist, and from that we generate
5965
; the two disguised-constants-4-tuple-lsts. Then we compare the two 4-tuple
5966
; lists to make sure the corresponding clock and semantic functions call for
5967
; the same modifications. Then we use the 4-tuple lists to modify the hyps in
5968
; the two sets of definitions.
5970
; End of the Design of a Simple Invariant Detector: Disguised Constants
5972
; This code converts preliminary function bodies into a list of the ``virtual
5973
; calls'' contained therein, where a ``virtual call'' or vcall is (fn ...(:SLOT
5978
(defun collect-calls-to-slots-alist (formals term fns-in-system wrld ans)
5980
; We accumulate into ans pairs of the form (fn . slots), for every call in term
5981
; of a function name listed in fns-in-system. The slots is a list
5982
; of (:SLOT vformal actual) specifying the virtual formals modified in the
5983
; call and the new value.
5986
((variablep term) ans)
5987
((fquotep term) ans)
5988
((member-eq (ffn-symb term) fns-in-system)
5990
(cons (ffn-symb term)
5994
(cdr (assoc-eq :list
5995
(table-alist 'generalized-updater-drivers wrld)))
5996
(cdr (assoc-eq :list
5997
(table-alist 'generalized-updater-drivers wrld)))))
5999
(t (collect-calls-to-slots-alist-lst formals
6001
fns-in-system wrld ans))))
6003
(defun collect-calls-to-slots-alist-lst (formals term-lst fns-in-system wrld ans)
6005
((endp term-lst) ans)
6006
(t (collect-calls-to-slots-alist-lst
6011
(collect-calls-to-slots-alist formals
6013
fns-in-system wrld ans))))))
6015
(defun generate-fn-to-pc-and-vcalls-alist (defun-pairs fns-in-system wrld)
6017
; We convert a list of preliminary definition pairs, (pc . defn), into an alist
6018
; with elements of the form (fn pc . vcalls), where vcalls are the virtual
6019
; calls contained within the body of fn.
6022
((endp defun-pairs) nil)
6023
(t (let* ((pair (car defun-pairs))
6025
(defn (car (cdr pair)))
6027
(formals (caddr defn))
6028
(body (car (last defn))))
6030
; The check below is for sanity only. We don't expect it to fail unless we
6031
; change the format generated by generate-clock-function-defun-pairs, etc.
6035
(true-listp (cdr pair))
6036
(equal (len (cdr pair)) 1)
6038
(true-listp formals)
6039
(equal (len formals) 1)
6040
(not (variablep body))
6041
(not (fquotep body))
6042
(eq (ffn-symb body) 'IF)
6043
(or (equal (fargn body 3) *0*)
6044
(equal (fargn body 3) (car formals))))
6048
(collect-calls-to-slots-alist formals
6053
(generate-fn-to-pc-and-vcalls-alist (cdr defun-pairs)
6056
(t (er hard 'generate-fn-to-pc-and-vcalls-alist
6057
"This function was supposed to be applied to a list of pairs ~
6058
of the form (pc . ((def fn (svar) ...dcls... body))) where ~
6059
def is some flavor of DEFUNM, fn is a function symbol, and ~
6060
body is an IF-expression whose 3rd argument is either 0 or ~
6061
svar. This was understood to be the shape of the outputs of ~
6062
the functions generate-clock-function-defun-pairs and ~
6063
generate-semantic-function-defun-pairs. But we've just seen ~
6064
the entry ~X01 which is not of this form."
6068
(defun map-actual-to-u (term)
6070
(cdr term) ; (QUOTE a) ==> (a)
6073
(defun merge-u1-and-u2 (u1 u2)
6074
(cond ((or (eq u1 :changing)
6077
(t (union-equal u1 u2))))
6079
(defun merge-v-u-into-vformal-alist (v u alist)
6080
(let ((temp (assoc-equal v alist)))
6081
(cond ((null temp) (cons (cons v u) alist))
6082
(t (put-assoc-equal v (merge-u1-and-u2 u (cdr temp)) alist)))))
6084
(defun merge-vformal-alists (alist1 alist2)
6086
((endp alist1) alist2)
6087
(t (merge-vformal-alists
6089
(merge-v-u-into-vformal-alist (car (car alist1))
6093
(defun merge-slots-into-caller-vformal-alist (slots vformal-alist)
6095
; Suppose some function G calls F with the (:SLOT v_i a_i) expressions in
6096
; slots. Let vformal-alist be the vformal alist for the caller G. We create a
6097
; vformal alist to merge into that of F. Note that a slot in which v_i is
6098
; assigned a constant overrides a :changing u in the caller!
6100
(cond ((endp slots) vformal-alist)
6101
(t (let ((v (cadr (car slots)))
6102
(a (caddr (car slots))))
6103
(merge-slots-into-caller-vformal-alist
6106
(put-assoc-equal v (cdr a) vformal-alist))
6107
(t (put-assoc-equal v :changing vformal-alist))))))))
6109
(defun one-pass-constant-propagation-vcalls (vformal-alist-g vcalls ans)
6112
(t (one-pass-constant-propagation-vcalls
6115
(let* ((f (car (car vcalls)))
6116
(slots (cdr (car vcalls)))
6117
(vformal-alist-f (cdr (assoc-eq f ans))))
6119
(merge-vformal-alists
6120
(merge-slots-into-caller-vformal-alist
6126
(defun one-pass-constant-propagation (lst ans)
6129
(t (one-pass-constant-propagation
6131
(let* ((g (car (car lst)))
6132
(vcalls (cddr (car lst))))
6133
(one-pass-constant-propagation-vcalls
6134
(cdr (assoc-eq g ans))
6139
(defun constant-propagation (fn-to-pc-and-vcalls-alist ans trace)
6142
(er hard 'constant-propagation
6143
"Oops! Constant-propagation seems to loop. The trace -- earliest to ~
6145
(revappend (cons ans trace) nil)))
6147
(let ((ans1 (one-pass-constant-propagation fn-to-pc-and-vcalls-alist ans)))
6151
(t (constant-propagation fn-to-pc-and-vcalls-alist
6153
(cons ans trace))))))))
6155
; Given the alist mapping functions in the system to their vformal alists, we
6156
; now identify the disguised constants.
6158
(defun disguised-constant-4-tuple-lst2 (pc-term fn pc vformals-alist)
6160
((endp vformals-alist) nil)
6161
((consp (cdr (car vformals-alist)))
6163
((equal pc-term (car (car vformals-alist)))
6164
(disguised-constant-4-tuple-lst2 pc-term fn pc (cdr vformals-alist)))
6167
(list fn pc (car (car vformals-alist))
6168
(merge-sort-lexorder (cdr (car vformals-alist))))
6169
(disguised-constant-4-tuple-lst2 pc-term fn pc (cdr vformals-alist))))))
6170
(t (disguised-constant-4-tuple-lst2 pc-term fn pc (cdr vformals-alist)))))
6172
(defun disguised-constant-4-tuple-lst1
6173
(pc-term fn-to-vformal-alist-alist fn-to-pc-and-vcalls-alist)
6175
; Here, pc-term is the term from the machine model that accesses the pc from
6176
; the state variable, e.g., (get-pc st). It is used to identify which of the
6177
; vformals is the pc, the settings of which we wish to ignore in this
6178
; computation. Each element of fn-to-vformal-alist-alist is of the form (fn
6179
; . (...(v_i . u_i)...)) where u_i is either :changing or a non-empty true-list
6180
; of evgs. For each entry such that v_i maps to a list, we create a 4-tuple
6181
; (fn pc v_i u'_i), where pc is the pc from which fn was derived and u'_i is
6182
; the lexordered version of u_i, otherwise known as the ``range'' of v_i in fn.
6183
; Finally, fn-to-pc-and-vcalls-alist is an alist with elements of the form (fn
6184
; pc . vcalls), where vcalls are the virtual calls contained within the body of
6188
((endp fn-to-vformal-alist-alist) nil)
6189
(t (append (disguised-constant-4-tuple-lst2
6191
(car (car fn-to-vformal-alist-alist))
6192
(cadr (assoc-eq (car (car fn-to-vformal-alist-alist))
6193
fn-to-pc-and-vcalls-alist))
6194
(cdr (car fn-to-vformal-alist-alist)))
6195
(disguised-constant-4-tuple-lst1 pc-term
6196
(cdr fn-to-vformal-alist-alist)
6197
fn-to-pc-and-vcalls-alist)))))
6199
(defun collect-all-known-vformals1 (vcalls vformals)
6200
(cond ((endp vcalls) vformals)
6201
(t (collect-all-known-vformals1
6204
(strip-cadrs (cdr (car vcalls)))
6207
(defun collect-all-known-vformals (fn-to-pc-and-vcalls-alist vformals)
6209
((endp fn-to-pc-and-vcalls-alist)
6211
(t (collect-all-known-vformals
6212
(cdr fn-to-pc-and-vcalls-alist)
6213
(collect-all-known-vformals1
6214
(cddr (car fn-to-pc-and-vcalls-alist))
6217
(defun initial-fn-to-vformal-alist-alist (fn-to-pc-and-vcalls-alist)
6219
; The first function in the fn-to-pc-and-vcalls-alist is always the entry
6220
; point, corresponding to the :init-pc of the api, thanks to the reordering of
6221
; cutpoints in def-semantics-post-events. We actually know that the pc of the
6222
; entry function is the (cadr (car fn-to-pc-and-vcalls-alist)), but we just
6223
; assume it can be anything because we handle the pc specially in forming the
6224
; defun pairs. So this function assumes that upon entry to the entry, every
6225
; vformal is :changing. Note that we don't make assignments here to vformals that
6226
; are read but never written. E.g., (nth 2 (rd :locals s)) might be involved in
6227
; calculations but never assigned by any routine, in which case we don't even consider
6228
; it as a possible disguised constant.
6230
(list (cons (car (car fn-to-pc-and-vcalls-alist))
6232
(collect-all-known-vformals fn-to-pc-and-vcalls-alist nil)
6235
(defun disguised-constant-4-tuple-lst (pc-term fn-to-pc-and-vcalls-alist)
6237
; Identify disguised constants by creating a list of 4-tuples, each of the form
6238
; (fn pc v_i u'_i), where u'_i is the lexordered range of the disguised
6239
; constant v_i in fn (which was derived starting at pc).
6241
(let ((fn-to-vformal-alist-alist
6242
(constant-propagation fn-to-pc-and-vcalls-alist
6243
(initial-fn-to-vformal-alist-alist
6244
fn-to-pc-and-vcalls-alist)
6246
(disguised-constant-4-tuple-lst1 pc-term fn-to-vformal-alist-alist
6247
fn-to-pc-and-vcalls-alist)))
6249
; Now we compute the conjunct to add to the hypotheses for the definition of
6250
; the (clock or semantic) function derived from pc, given the disguised
6251
; constant 4-tuples. (Note that the 4-tuples provided are always those for the
6252
; clock functions only because we will have confirmed that the semantic
6253
; functions have the same 4-tuples except for the names of the functions.)
6255
(defun disguised-constant-hyp1 (pc disguised-constant-4-tuple-lst body)
6257
((endp disguised-constant-4-tuple-lst) nil)
6258
((equal pc (cadr (car disguised-constant-4-tuple-lst)))
6259
(let ((v (caddr (car disguised-constant-4-tuple-lst)))
6260
(r (cadddr (car disguised-constant-4-tuple-lst))))
6265
`(equal ,v ,(kwote (car r)))
6266
`(member-equal ,v ,(kwote r)))
6267
(disguised-constant-hyp1 pc (cdr disguised-constant-4-tuple-lst) body)))
6268
(t (disguised-constant-hyp1 pc (cdr disguised-constant-4-tuple-lst) body)))))
6269
(t (disguised-constant-hyp1 pc (cdr disguised-constant-4-tuple-lst) body))))
6271
(defun disguised-constant-hyp (pc disguised-constant-4-tuple-lst body)
6272
(conjoin (disguised-constant-hyp1 pc disguised-constant-4-tuple-lst body)))
6274
; And now we map over a list of defun-pairs and insert the disguised-constant hyp
6276
(defun modify-hyps-in-defun-pair (disguised-constant-4-tuple-lst defun-pair)
6278
; Defun-pair is (pc . ((def fn (svar) ...dcls... (IF hyp code base)))).
6279
; We generate the disguised constant hyp for pc and conjoin it with hyp to produce
6282
(let* ((pc (car defun-pair))
6283
(event (car (cdr defun-pair)))
6286
(formals (caddr event))
6287
(dcls (all-but-last (cdddr event)))
6288
(body (car (last event))) ; (IF hyps code base)
6289
(hyps (fargn body 1))
6290
(code (fargn body 2))
6291
(base (fargn body 3))
6292
(dc-hyp (disguised-constant-hyp pc disguised-constant-4-tuple-lst body)))
6294
((equal dc-hyp *t*) defun-pair)
6295
(t `(,pc . ((,def ,fn ,formals
6297
(IF ,(conjoin2 hyps dc-hyp) ,code ,base))))))))
6299
(defun modify-hyps-in-defun-pairs (disguised-constant-4-tuple-lst defun-pairs)
6301
; Each pair in defun-pairs is (pc . ((def fn (svar) ...dcls... body))), where
6302
; body is (IF <conjoined-hyps-from-api> <body> <base>) and we add
6303
; the conjunct(s) for the derived constant(s) of pc to
6304
; <conjoined-hyps-from-api>.
6307
((endp defun-pairs) nil)
6308
(t (cons (modify-hyps-in-defun-pair disguised-constant-4-tuple-lst
6310
(modify-hyps-in-defun-pairs disguised-constant-4-tuple-lst
6311
(cdr defun-pairs))))))
6313
; This completes the identification of disguised constants. We stitch all this together in
6314
; def-semantics-post-events below.
6316
; Preview of coming attractions:
6318
; We will create the call graph of the clock and semantic functions from the
6319
; start/terminal pc components of the path-tree-tuples. Then we'll close it
6320
; under reflexivity and transitivity and sort it to obtain a list like that
6321
; above. Then we strip out the terminal pcs and keep just the buckets of
6322
; starting pcs. The singleton elements in the final ordering correspond to
6323
; singly-recursive functions and the other elements correspond to mutually
6324
; recursive functions. The functions should be introduced in the order listed,
6325
; e.g., ((4) (1 2 3) (5)) means introduce the singly recursive function for pc
6326
; 4, then the mutually recursive clique of fns for pcs 1, 2, and 3, and finally
6327
; the singly-recursive function for 5.
6329
(defun create-call-graph (path-tree-tuples)
6330
(cond ((endp path-tree-tuples) nil)
6331
(t (let* ((tuple (car path-tree-tuples))
6332
(start-pc (car tuple))
6333
(terminal-pcs (cadr tuple)))
6334
(cons (cons start-pc terminal-pcs)
6335
(create-call-graph (cdr path-tree-tuples)))))))
6338
; (A.5.2) removing mutual recursion.
6340
; Essay on Transforming Mutually Recursive Functions to Singly-Recursion Ones
6342
; Note: This elaborates a bit on (A.5.2).
6344
; The result of the above function is an ``ordering'' such as (10 (20 30 40)
6345
; 50) meaning the function for pc 10 should be defined first, then functions
6346
; for pcs 20, 30, and 40 should be defined simultaneously
6347
; (mutually-recursively), and then that for pc 50 should be defined.
6349
; We will use this ordering to generate and order a set of ``defun pairs.''
6350
; Initially, each such pair is (pc . ((def fn (s) ...))), where pc is a pc, def
6351
; is either DEFUN-NX or DEFUNM-NX. fn is the new function name -- typically it
6352
; will be either CLK-pc or SEM-pc -- and s is the state variable. The
6353
; definition of fn assumes that the pc of the initial s is pc, i.e., the
6354
; function is a derived function for the code starting at pc.
6356
; However, the process of ``applying'' this ordering to the defun pairs (see
6357
; apply-call-graph-ordering-to-defun-pairs) will actually transform the
6358
; implicit mutual recursion into a singly recursive definition! We refer to
6359
; this as the ``transformation to singly-recursive form'' and it is done by the
6360
; function transform-to-singly-recursive. In particular, it will collect all
6361
; the defuns of those fns in an implicitly mutually recursive clique, say
6362
; fn-20, fn-30, and fn-40, and form a new definition of a singly-recursive
6363
; function from them, named fn-20-30-40. This has global ramifications: all
6364
; subsequent calls of fn-20, fn-30, and fn-40 must be replaced by calls of the
6367
; If the bodies of fn-20, fn-30, and fn-40 are body-20, body-30, and body-40,
6368
; then the body of fn-20-30-40 is:
6370
; (if (equal (pc s) 20)
6372
; (if (equal (pc s) 30)
6376
; where the primed bodies are the original ones with all calls of the fns in
6377
; the clique replaced by calls of fn-20-30-40.
6379
; Note that this assumes that when one of the original bodies calls one of its
6380
; peers recursively, (fn-pc new-s), the appropriate original function, fn-20,
6381
; fn-30, or fn-40, can be determined by the pc of new-s. We believe this is
6382
; always the case, given the way clock and semantic functions are generated.
6384
; Note that this method of transforming a mutually-recursive clique into a
6385
; singly-recursive definition is not generally applicable! In particular, the
6386
; transformation does NOT introduce a flag standing for the name of the
6387
; function being computed by the singly-recursive function. All necessary
6388
; information is encoded in the state argument because it only ``makes sense''
6389
; to apply a clock or semantic function to a state with the pc stipulated when
6390
; the function was dervied. Being untyped, mutually-recursive ACL2 functions
6391
; can be applied universally. E.g., '(A (B X) (C Y)) is both a (pseudo-) term
6392
; and a list of (pseudo-) terms and so it would make sense to use it as the
6393
; second argument to either sublis-var or sublis-var-lst; one can't tell by
6394
; looking at the data what type of thing something is and thus one can't know
6395
; for sure which of the mutually-recursive functions in the clique is
6396
; appropriate for it. But with clock and semantic functions as derived here,
6397
; it only ``makes sense'' to apply the functions to states with the appropriate
6398
; pc. We quote ``makes sense'' because one can apply it to states with other
6399
; pcs and ACL2 will return an answer, but that answer will not be as predicted
6400
; by the correctness theorem because the correctness theorem stipulates the
6401
; initial pc. Thus ``makes sense'' here means ``is correct as per the
6402
; correctness theorem.''
6404
; However, after the transformation to singly-recursive form, it is difficult
6405
; to determine which function is being called! To do so, one would have to
6406
; recover the pc of the new state in the call, probably by symbolic rewriting,
6407
; and possibly even considering the governing hypotheses of the call.
6409
; Because we will also have to rename the occurrences of the original functions
6410
; in the theorems about them, the process of applying the ordering to the defun
6411
; pairs will also produce a renaming-alist, mapping the original names to the
6412
; new name, e.g., ((fn-20 . fn-20-30-40) (fn-30 . fn-20-30-40) (fn-40
6415
(defun collect-cadr-assoc-equal (keys alist)
6416
; Alist is assumed to map each key to a list of items and this function
6417
; collects the first item in each list of the given keys. The returned
6418
; list is in the order the keys are listed.
6419
(cond ((endp keys) nil)
6420
(t (cons (cadr (assoc-equal (car keys) alist))
6421
(collect-cadr-assoc-equal (cdr keys) alist)))))
6423
(defun apply-renaming-alist-to-def (renaming-alist defun-event)
6425
; Renaming-alist is a functional substitution and defun event is a defun-like
6426
; event (DEFUN-NX ...) or (DEFUNM-NX ...). We replace the body of the def with
6427
; the result of renaming the functions in it. We don't change the name of the
6428
; event or any declarations that might be in it. We return the renamed
6431
(cond ((and (consp defun-event)
6432
(member-eq (car defun-event) '(defun-nx defunm-nx)))
6433
(append (all-but-last defun-event)
6434
(list (sublis-fn-simple renaming-alist (car (last defun-event))))))
6435
(t (er hard 'apply-renaming-alist-to-body
6436
"This function is supposed to be applied to an event of the ~
6437
form (DEFUN-NX ...) or (DEFUNM-NX ...) and ~X01 is neither!"
6441
(defun apply-renaming-alist-to-def-lst (renaming-alist defun-events)
6443
; Renaming-alist is a fn to fn renaming and defun-events is a list of
6444
; defun-like events, (def fn (s) ... body). We apply renaming-alist to each
6445
; body and return a list of renamed defun-events in the same order. Only the
6446
; bodies of the defuns have been renamed! We did not change the function names
6447
; being defined nor did we hit the declarations.
6449
(cond ((endp defun-events) nil)
6450
(t (cons (apply-renaming-alist-to-def renaming-alist
6452
(apply-renaming-alist-to-def-lst renaming-alist
6453
(cdr defun-events))))))
6456
(defun peers-called (peer-fns term ans)
6457
(cond ((variablep term) ans)
6458
((fquotep term) ans)
6459
((flambdap (ffn-symb term))
6460
(peers-called-lst peer-fns
6462
(peers-called peer-fns
6463
(lambda-body (ffn-symb term))
6465
(t (peers-called-lst peer-fns
6467
(if (member-eq (ffn-symb term) peer-fns)
6468
(add-to-set-eq (ffn-symb term) ans)
6471
(defun peers-called-lst (peer-fns terms ans)
6472
(cond ((endp terms) ans)
6473
(t (peers-called-lst peer-fns
6475
(peers-called peer-fns (car terms) ans)))))
6478
(defun count-peers-called-lst (peer-fns defs)
6480
; Given a list of mutually-recursive function names, peer-fns, and a list of
6481
; their defun-like events, we return a list in 1:1 correspondence with the
6482
; latter listing the number of peers called by each function. E.g., given
6483
; peers-lst (f g h) and defs in the same order, and assuming that f calls only
6484
; one of the peers, g calls all three, and h calls only two, we return (1 3 2).
6486
; Note that the returned counts are in the order of defs.
6488
(cond ((endp defs) nil)
6489
(t (cons (length (peers-called peer-fns (car (last (car defs))) nil))
6490
(count-peers-called-lst peer-fns (cdr defs))))))
6492
(defun generate-case-expression (key pcs terms)
6494
; Key is a term, pcs is a list of k>0 evgs, and terms is a list of k terms.
6495
; We return the translated form of
6501
; (otherwise term_k)
6504
((endp (cdr pcs)) (car terms))
6505
(t (let ((pc (car pcs))
6507
`(if (equal ,key ',pc)
6509
,(generate-case-expression key (cdr pcs) (cdr terms)))))))
6511
(defun monotonousp (lst)
6512
; A list is `monotonous' iff every element is the same as every other.
6513
(cond ((endp lst) t)
6514
((endp (cdr lst)) t)
6515
(t (and (equal (car lst) (cadr lst))
6516
(monotonousp (cdr lst))))))
6518
(defun strip-bodies (defun-events)
6519
(cond ((endp defun-events) nil)
6520
(t (cons (car (last (car defun-events)))
6521
(strip-bodies (cdr defun-events))))))
6523
(defun transform-to-singly-recursive (pcs pairs renaming-alist dsem-alist api)
6525
; We assume pcs has at least two elements and that all the elements in pcs are
6526
; bound in pairs to defun-like singleton event lists. We generate a defun-like
6527
; event combining all of the definitions into one singly-recursive definition.
6528
; We generate a DEFUN-NX form if the user has provided an annotation for this
6529
; new function symbol. Otherwise we generate a DEFUNM-NX form.
6531
(let* ((defs0 (collect-cadr-assoc-equal pcs pairs))
6532
(fns (strip-cadrs defs0))
6533
(bodies (strip-bodies
6534
(apply-renaming-alist-to-def-lst renaming-alist defs0)))
6535
(new-fn (generate-def-semantics-name
6536
(fnsymbol-name-prefix
6537
(get-kind-from-fnsymbol-name ; :CLOCK or :SEMANTIC
6538
(symbol-name (car fns))))
6542
(svar (access model-api api :svar))
6543
(key (make-fn-application (access model-api api :get-pc)
6547
(cdr (assoc-eq :annotations dsem-alist))))
6548
(defcmd (if (and user-supplied-pair
6549
(consp (cadr user-supplied-pair)))
6552
(dcls (if (and user-supplied-pair
6553
(consp (cadr user-supplied-pair)))
6554
(cdr user-supplied-pair)
6555
(if (eq (access model-api api :stobjp) t)
6558
,@(cdr user-supplied-pair)
6559
:STOBJS (,(access model-api api :svar)))))
6562
,@(cdr user-supplied-pair))))))))
6564
; Note that pcs, defs0, fns, counts, and bodies are in the same order because
6565
; defs0 is in the order listed in pcs and all the others are in the order
6566
; listed by defs0. Thus:
6568
; lst (nth i lst) meaning
6570
; fns fn_i original name of some CLK- or SEM- fn
6571
; pcs pc_i starting pc from which fn_i dervied
6572
; defs0 def0_i defun-like event for fn_i
6573
; bodies body_i body of fn_i with all peers replaced
6574
; as per the renaming alist.
6576
`(,defcmd ,new-fn (,svar)
6578
,(generate-case-expression key pcs bodies))))
6580
(defun apply-call-graph-ordering-to-defun-pairs
6581
(ordering pairs events renaming-alist dsem-alist api)
6583
; Ordering is a list containing lists of pcs. Singleton elements denote pcs
6584
; whose corresponding derived functions are singly recursive and non-singleton
6585
; elements denote pcs whose corresponding derived functions are mutually
6586
; recursive. Pairs is a list of pairs, each with a pc in the car and a
6587
; singleton list containing a defun-like event, e.g., DEFUN-NX and DEFUNM-NX,
6590
; ((10 . ((defun-nx fn-10 (s) ...))) (20 . ((defunm-nx fn-20 (s) ...))) ...)
6592
; The bodies of the defun-like events are in translated form. We order the
6593
; events as specified by the ordering and transform all mutually recursive
6594
; functions into singly recursive ones, possibly including
6595
; terminatricks-hints.
6597
; The renaming-alist maps original mutually-recursive function names to their
6598
; singly recursive counterparts, e.g., ((fn-20 . fn-20-30-40) (fn-30
6599
; . fn-20-30-40) ...) and these renamings are applied to subsequent defun-like
6600
; events. The final reordered list of defun-like events is returned along with
6601
; the final renaming alist, (mv events renaming-alist).
6603
(cond ((endp ordering)
6604
(mv (revappend events nil) renaming-alist))
6605
((cdr (car ordering)) ; mutually recursive nest
6606
(let* ((pcs (car ordering))
6607
(old-fns (strip-cadrs (collect-cadr-assoc-equal pcs pairs)))
6608
(new-fn (generate-def-semantics-name
6609
(fnsymbol-name-prefix
6610
(get-kind-from-fnsymbol-name ; :CLOCK or :SEMANTIC
6611
(symbol-name (car old-fns))))
6615
(new-renaming-alist (append (pairlis-x2 old-fns new-fn) renaming-alist))
6616
(new-def (transform-to-singly-recursive
6620
(apply-call-graph-ordering-to-defun-pairs
6623
(cons new-def events)
6627
(apply-call-graph-ordering-to-defun-pairs
6630
(cons (apply-renaming-alist-to-def
6632
(cadr (assoc-equal (car (car ordering)) pairs)))
6637
; (A.6) generate the correctness theorem relating the clock and semantic
6640
(defun generate-equal-key-evg-lst (key evg-lst)
6641
(cond ((endp evg-lst) nil)
6642
(t (cons `(EQUAL ,key ',(car evg-lst))
6643
(generate-equal-key-evg-lst key (cdr evg-lst))))))
6645
(defun pretty-or (lst)
6646
(cond ((null lst) nil)
6647
((null (cdr lst)) (car lst))
6648
(t (cons 'or lst))))
6650
(defun pretty-and (conjuncts)
6651
(cond ((null conjuncts) t)
6652
((null (cdr conjuncts)) (car conjuncts))
6653
(t (cons 'and conjuncts))))
6655
(defun generate-correctness-theorem (pc-lst dsem-alist api wrld)
6657
; Pc-Lst is a list pcs and is an element of some call-graph ordering. If
6658
; pc-lst is a singleton list then the pc in it corresponds to a
6659
; singly-recursive (or possibly non-recursive) function. If it is not a
6660
; singleton, then the pc-lst in it gave rise to mutually recursive definitions
6661
; which have been transformed into a singly-recursive function with a name
6662
; derived from all the pc-lst. Both semantic and clock functions for the
6663
; pc-lst have already been defined. We generate a list of events thought
6664
; suitable for proving that the corresponding functions are correct. The list
6665
; contains just two events: a defthm and a subsequent in-theory disabling the
6668
(let* ((run (access model-api api :run))
6669
(s (access model-api api :svar))
6670
(hyp (conjoin (access model-api api :hyps)))
6671
(get-pc (access model-api api :get-pc))
6672
(clk-fn (generate-def-semantics-name (fnsymbol-name-prefix :clock)
6673
pc-lst "" dsem-alist api))
6674
(sem-fn (generate-def-semantics-name (fnsymbol-name-prefix :semantic)
6675
pc-lst "" dsem-alist api))
6676
(thm-name (generate-def-semantics-name (fnsymbol-name-prefix :semantic)
6681
(cdr (assoc-eq :annotations dsem-alist)))))
6687
(flatten-ands-in-lit hyp)
6689
(generate-equal-key-evg-lst (make-fn-application get-pc (list s))
6693
(equal ,(make-fn-application
6695
(list s (make-fn-application clk-fn (list s))))
6696
,(make-fn-application
6699
,@(cdr user-supplied-pair))
6700
(in-theory (disable ,clk-fn)))))
6702
(defun generate-call-graph-ordered-correctness-theorems
6703
(ordering dsem-alist api wrld)
6705
((endp ordering) nil)
6706
(t (append (generate-correctness-theorem
6708
dsem-alist api wrld)
6709
(generate-call-graph-ordered-correctness-theorems
6711
dsem-alist api wrld)))))
6713
; We now begin putting it all together.
6715
(defun untranslate-defuns (lst wrld)
6718
((and (consp (car lst))
6719
(member-eq (car (car lst)) '(defun defun-nx defunm defunm-nx)))
6721
(all-but-last (car lst))
6722
(list (untranslate (undistribute-ifs (car (last (car lst)))) nil wrld)))
6723
(untranslate-defuns (cdr lst) wrld)))
6725
(untranslate-defuns (cdr lst) wrld)))))
6727
(defun def-semantics-pre-events (dsem-alist api)
6728
(let ((api+ (change model-api
6730
:hyps (append (access model-api api :hyps)
6731
(cdr (assoc-eq :hyps+ dsem-alist))))))
6732
(wrapper-events api+)))
6734
(defun def-semantics-post-events (dsem-alist api state)
6735
(let ((api+ (change model-api
6737
:hyps (append (access model-api api :hyps)
6738
(cdr (assoc-eq :hyps+ dsem-alist))))))
6740
(unknowns-alist flink-graph blink-graph)
6741
(link-graphs dsem-alist api+ state)
6743
((null unknowns-alist)
6745
(loop-pcs branching-pcs halting-pcs cutpoint-pcs)
6746
(categorize-pcs flink-graph blink-graph)
6747
(declare (ignore loop-pcs branching-pcs))
6748
(let* ((svar (access model-api api+ :svar))
6749
(pc-term (make-fn-application (access model-api api+ :get-pc)
6753
; To insure that the function for the :init-pc is the first one in the list, we
6754
; make sure the :init-pc is the first cutpoint!
6756
(cons (cdr (assoc-eq :init-pc dsem-alist))
6757
(remove1-equal (cdr (assoc-eq :init-pc dsem-alist))
6761
(path-tree-tuples-from-cutpoint-lst
6762
(set-difference-equal known-cutpoints halting-pcs)
6767
(call-graph-ordering (create-call-graph path-tree-tuples)))
6768
(prelim-clock-function-defun-pairs
6769
(generate-clock-function-defun-pairs
6774
(clock-disguised-constant-4-tuple-lst
6775
(disguised-constant-4-tuple-lst
6777
(generate-fn-to-pc-and-vcalls-alist
6778
prelim-clock-function-defun-pairs
6779
(strip-cadrs ; list of all clock fn names
6781
(strip-cdrs prelim-clock-function-defun-pairs)))
6783
(prelim-semantic-function-defun-pairs
6784
(generate-semantic-function-defun-pairs
6789
(semantic-disguised-constant-4-tuple-lst
6790
(disguised-constant-4-tuple-lst
6792
(generate-fn-to-pc-and-vcalls-alist
6793
prelim-semantic-function-defun-pairs
6794
(strip-cadrs ; list of all semantic fn names
6796
(strip-cdrs prelim-semantic-function-defun-pairs)))
6799
((not (equal (strip-cdrs clock-disguised-constant-4-tuple-lst)
6800
(strip-cdrs semantic-disguised-constant-4-tuple-lst)))
6801
(er soft 'def-semantics
6802
"The disguised constants in the system of clock functions are ~
6803
different from those in the system of semantic functions. ~
6804
Below we show two lists, one for clock functions and one for ~
6805
semantic functions. Except for the names of the functions, ~
6806
the two lists are supposed to be identical but are not. ~
6807
Each element of each list is of the form (fn pc vformal ~
6808
range) meaning that in function fn, derived from the given ~
6809
pc, vformal is a disguised constant with the given range of ~
6810
possible values.~%~%~X02~%~%~X12"
6811
clock-disguised-constant-4-tuple-lst
6812
semantic-disguised-constant-4-tuple-lst))
6814
(let* ((clock-function-defun-pairs
6815
(modify-hyps-in-defun-pairs
6816
clock-disguised-constant-4-tuple-lst
6817
prelim-clock-function-defun-pairs))
6818
(semantic-function-defun-pairs
6819
(modify-hyps-in-defun-pairs
6820
semantic-disguised-constant-4-tuple-lst
6821
prelim-semantic-function-defun-pairs)))
6823
(clk-defuns clk-renaming-alist)
6824
(apply-call-graph-ordering-to-defun-pairs
6826
clock-function-defun-pairs
6830
(declare (ignore clk-renaming-alist))
6832
(sem-defuns sem-renaming-alist)
6833
(apply-call-graph-ordering-to-defun-pairs
6835
semantic-function-defun-pairs
6839
(declare (ignore sem-renaming-alist))
6842
(set-verify-guards-eagerness 0)
6843
,@(untranslate-defuns clk-defuns (w state))
6844
,@(untranslate-defuns sem-defuns (w state))
6845
,@(generate-call-graph-ordered-correctness-theorems
6851
(fms "~%~%~s0 Def-semantics Analysis ~s0~%We will attempt to admit ~
6852
the following events. If this fails, consider attaching ~
6853
:annotations to your def-semantics to provide adequate ~
6854
guidance. In the worst case, you could grab these events ~
6855
and edit them as appropriate to lead ACL2 to admit ~
6856
them.~%~%~x1~s0-~s0~s0~%"
6857
(list (cons #\0 "--------------------")
6862
(value events)))))))))))))
6863
(t (er soft 'def-semantics
6864
"This code cannot be explored with the current rewrite-rule ~
6865
configuration. Below is an alist pairing pcs to lists of ~
6866
terms, as in (pc . (term1 term2 ...)). The termi are the ~
6867
possible, non-constant next pc values obtained by executing the ~
6868
instruction at pc. Since their concrete values cannot be ~
6869
determined, we cannot trace the control structure of the code. ~
6870
There are two possible explanations. One is that the ~
6871
instruction at pc is some kind of computed jump that transfers ~
6872
control to a context- or data-sensitive location or to a ~
6873
location outside the bounds of the current program. The other ~
6874
is that the rewrite rules available in this world are ~
6875
insufficient to allow us to resolve the symbolic terms to ~
6876
concrete values.~%~X01"
6880
; If you set this variable, make-event will print some extra output showing you what is
6881
; being evaluated and what events are produced.
6883
; (assign make-event-debug t)
6885
(defun correctness-theorem-namep (sym)
6886
; We return t iff the name of symbol sym ends in -CORRECT.
6887
(let* ((str (symbol-name sym))
6891
(t (and (eql (char str (- n 8)) #\-)
6892
(eql (char str (- n 7)) #\C)
6893
(eql (char str (- n 6)) #\O)
6894
(eql (char str (- n 5)) #\R)
6895
(eql (char str (- n 4)) #\R)
6896
(eql (char str (- n 3)) #\E)
6897
(eql (char str (- n 2)) #\C)
6898
(eql (char str (- n 1)) #\T))))))
6900
; Now we develop the code to translate the arguments of def-semantics.
6902
(defun cheap-declare-formsp (lst)
6903
(cond ((atom lst) (eq lst nil))
6904
((and (true-listp (car lst))
6905
(eq (car (car lst)) 'DECLARE))
6906
(cheap-declare-formsp (cdr lst)))
6909
(defun chk-def-semantics-annotations (x state)
6912
(cond ((equal x nil) (value nil))
6913
(t (er soft 'def-semantics
6914
"The :ANNOTATIONS argument of a def-semantics expression is ~
6915
supposed be a true list and yours is not, it ends in ~x0."
6917
((and (consp (car x))
6918
(true-listp (car x))
6919
(symbolp (car (car x))))
6921
((correctness-theorem-namep (car (car x)))
6923
((member-eq (cadr (car x))
6924
'(:RULE-CLASSES :HINTS :INSTRUCTIONS :OTF-FLG :DOC))
6925
(chk-def-semantics-annotations (cdr x) state))
6926
(t (er soft 'def-semantics
6927
"When a def-semantics annotation begins with a name like ~x0, the ~
6928
associated entry must list the keyword arguments for the ~
6929
DEFTHM event of that name that def-semantics will generate. ~
6930
Thus, we expect to see one of the DEFTHM keyword arguments ~
6931
after the name, e.g., :RULE-CLASSES, :HINTS, :INSTRUCTIONS, ~
6932
:OTF-FLG, or :DOC. But you wrote ~x1."
6936
((and (consp (cdr (car x)))
6937
(cheap-declare-formsp (cdr (car x))))
6938
(chk-def-semantics-annotations (cdr x) state))
6939
((and (consp (cdr (car x)))
6940
(keyword-value-listp (cdr (car x)))
6941
(subsetp-equal (evens (cdr (car x)))
6943
(chk-def-semantics-annotations (cdr x) state))
6944
(t (er soft 'def-semantics
6945
"When a def-semantics annotation begins with a name like ~x0, the ~
6946
associated entry must either be a list of DECLARE forms for the ~
6947
named clock or semantic function def-semantics will try to ~
6948
introduce or else must be a keyword/value list as provided to in ~
6949
XARGS. The former means that you wish to take over the ~
6950
admission of the ~x0 after def-semantics has generated the body; ~
6951
the latter means you wish to provide some additional hints ~
6952
during def-semantics' attempt to find a suitable measure. But the ~
6953
pair you supplied, ~x1, matches neither form."
6956
(t (er soft 'def-semantics
6957
"Every def-semantics annotation should be of the form ~
6958
(<symbol> ...), i.e., should be true-list starting with a symbol,
6959
but you wrote the annotation ~x0"
6962
(defun maybe-tack-hyphen-at-end (str)
6965
((eql (char str (- (length str) 1)) #\-)
6967
(t (string-append str "-"))))
6969
(defun translate-def-semantics-args (alist api state)
6971
; This function takes an alist that contains pairs of the form (:key . val) and
6972
; returns an equivalent alist containing (:key . val'), where the :keys are the
6973
; keyword args to the def-semantics macro, val is the user supplied values, and
6974
; val' is the translated form. If some argument fails to translate, an error
6975
; is signaled. We will pass the resulting alist around as the
6978
(let ((root-name (cdr (assoc-eq :root-name alist)))
6979
(focus-regionp (cdr (assoc-eq :focus-regionp alist)))
6980
(init-pc (cdr (assoc-eq :init-pc alist)))
6981
(hyps+ (cdr (assoc-eq :hyps+ alist)))
6982
(annotations (cdr (assoc-eq :annotations alist)))
6983
(svar (access model-api api :svar)))
6986
; Root-name is always translated to either the empty string or
6987
; a string ending with hyphen.
6989
((null root-name) (value ""))
6990
((symbolp root-name)
6991
(value (maybe-tack-hyphen-at-end (symbol-name root-name))))
6992
((stringp root-name)
6993
(value (maybe-tack-hyphen-at-end root-name)))
6994
(t (er soft 'def-semantics
6995
"The :ROOT-NAME, when supplied, must be a symbol or string ~
7000
((or (eq focus-regionp t)
7001
(eq focus-regionp nil))
7002
(value '(lambda (pc) 't)))
7003
(t (translate-fn-field
7011
(chk-true-listp hyps+
7013
"The :HYPS+ argument"
7015
(translate-list-of-terms hyps+ state))))
7017
(focus-regionp-approvesp
7024
(er soft 'def-semantics
7025
"The initial pc, ~x0, falls outside the focus region."
7029
(chk-def-semantics-annotations annotations state)
7030
; Here are the full-translated def-semantics arguments in alist form, aka
7033
`((:root-name . ,root-name)
7034
(:focus-regionp . ,focus-regionp)
7035
(:init-pc . ,init-pc)
7037
(:annotations . ,annotations))))))))))
7039
; See Guide: Overview of How Def-semantics Works
7041
(defmacro def-semantics (&key init-pc focus-regionp root-name hyps+ annotations)
7043
; Matt Kaufmann taught us how to do this. We find it very hard to think about
7044
; make-event! Thanks Matt!
7049
(translate-def-semantics-args
7050
'((:init-pc . ,init-pc)
7051
(:focus-regionp . ,focus-regionp)
7052
(:root-name . ,root-name)
7054
(:annotations . ,annotations))
7055
(cdr (assoc-eq :record (table-alist 'model-api (w state))))
7062
(def-semantics-pre-events
7064
(cdr (assoc-eq :record (table-alist 'model-api (w state)))))
7065
`((def-semantics-post-events ',dsem-alist
7066
(cdr (assoc-eq :record (table-alist 'model-api (w state))))
7069
; Now we move on to the development of projections.
7072
; (B.1) given a projector term (specifying the state component of interest) and a
7073
; semantic function, create the term (projector (semantic st)), expand
7074
; the semantic function call and simplify
7076
(defun apply-projector-to-term (hyps proj-term svar term state)
7078
; To apply a projector to a term we merely substitute the term for svar in the
7079
; projection term and simplify it under the hyps. Then we strip out the part
7080
; of the result governed by hyps. We return a simplified term.
7082
(simplify-under-hyps hyps
7083
(subst-var term svar proj-term)
7087
; (B.2) find every state component referenced outside the projected recursive
7088
; calls and collect the state component and its type; these are the
7089
; initially relevant components
7091
; Recall from Appendix A our discussion of the three sources of constraints on
7092
; a new formal parameter introduced into projections by generalizing a state
7093
; component: (a) tests on the state component made by the semantic function
7094
; being projected, (b) tests on the state component derived from the API's
7095
; :hyps, and (c) the type test associated with the state component in
7096
; state-comps-and-types. We refer to these ``sources'' in our comments below.
7098
(defun state-componentp (term svar state-comps-and-types)
7100
; A term is a state component iff it is an instance of the comp part of one of
7101
; the state-comps-and-types doublets, (comp type), such that the
7102
; variable svar is bound to itself and any other variables in comp are bound to
7103
; quoted constants. If term is a state component wrt svar then we return the
7104
; type of that component, as given by the instance of the type part of the
7108
((endp state-comps-and-types) nil)
7111
(one-way-unify1 (car (car state-comps-and-types))
7113
(list (cons svar svar)))
7116
(all-quoteps (remove1-eq svar (strip-cdrs alist))))
7117
(sublis-var alist (cadr (car state-comps-and-types))))
7118
(t (state-componentp term svar (cdr state-comps-and-types))))))))
7120
(defun every-term-with-svar-matches-some-pattern (term-lst svar patterns)
7123
((not (occur svar (car term-lst)))
7124
(every-term-with-svar-matches-some-pattern (cdr term-lst)
7128
(member-instance (car term-lst) 0 patterns nil)
7129
(declare (ignore alist i))
7131
(every-term-with-svar-matches-some-pattern (cdr term-lst)
7134
(defun other-semantic-fn-callp (term sem-fn svar state-expression-patterns)
7136
; We return t if term is of the form (some-other-semantic-fn a1 ... ak) where
7137
; some-other-semantic-fn is not sem-fn, svar occurs in at least one ai, and
7138
; every ai in which svar occurs is a ``next-state expression,'' where by that
7139
; we mean matches one of the patterns in state-expression-patterns. Those
7140
; patterns are typically just the updater and constructor pseudo-terms from the
7141
; generalized-updater-drivers or constructor-drivers.
7143
(and (not (variablep term))
7144
(not (fquotep term))
7145
(symbolp (ffn-symb term))
7146
(not (eq (ffn-symb term) sem-fn))
7148
(every-term-with-svar-matches-some-pattern
7149
(fargs term) svar state-expression-patterns)))
7151
(defun projector-and-other-fnsymb (term sem-fn svar
7152
state-component-patterns-and-types
7153
state-expression-patterns)
7155
; We determine whether term is a ``projected other call'' (a projection of a
7156
; call of a semantic function other than the one we're trying to project). If
7157
; so we return (mv projector fn), where projector is the projector from
7158
; state-component-patterns-and-types (a list of (comp type) doublets)
7159
; instantiated with the appropriate constants and fn is some semantic function
7160
; other than sem-fn. State-expression-patterns is used to determine if the
7161
; arguments to the fn call look like state expressions; the elements of this
7162
; list are typically the updater patterns and constructor patterns from
7163
; generalized-updater-drivers and constructor-drivers.
7166
((endp state-component-patterns-and-types)
7170
(one-way-unify (car (car state-component-patterns-and-types))
7175
(strip-cdrs (remove1-equal (assoc-eq svar alist) alist)))
7176
(other-semantic-fn-callp
7177
(cdr (assoc-eq svar alist))
7180
state-expression-patterns))
7181
(mv (sublis-var (remove1-equal (assoc-eq svar alist) alist)
7182
(car (car state-component-patterns-and-types)))
7183
(ffn-symb (cdr (assoc-eq svar alist)))))
7184
(t (projector-and-other-fnsymb term sem-fn svar
7185
(cdr state-component-patterns-and-types)
7186
state-expression-patterns)))))))
7189
(defun all-projector-and-other-fnsymb (term sem-fn svar
7190
state-component-patterns-and-types
7191
state-expression-patterns)
7193
; We sweep term and collect (projector . some-other-semantic-fn) for every
7194
; subterm classified as a projected other call. See projector-and-other-fnsymb
7195
; for the details of each pair collected.
7198
((variablep term) nil)
7199
((fquotep term) nil)
7200
(t (mv-let (projector other-fn)
7201
(projector-and-other-fnsymb term sem-fn svar
7202
state-component-patterns-and-types
7203
state-expression-patterns)
7206
(all-projector-and-other-fnsymb-lst
7207
(fargs term) sem-fn svar
7208
state-component-patterns-and-types
7209
state-expression-patterns))
7210
(t (list (cons projector other-fn))))))))
7212
(defun all-projector-and-other-fnsymb-lst
7213
(term-lst sem-fn svar
7214
state-component-patterns-and-types
7215
state-expression-patterns)
7217
((endp term-lst) nil)
7219
(all-projector-and-other-fnsymb (car term-lst) sem-fn svar
7220
state-component-patterns-and-types
7221
state-expression-patterns)
7222
(all-projector-and-other-fnsymb-lst (cdr term-lst) sem-fn svar
7223
state-component-patterns-and-types
7224
state-expression-patterns))))))
7227
(defun find-all-state-components-and-types-outside
7228
(term sem-fn svar state-comps-and-types)
7230
; Collect all state components outside the projected recursive calls of sem-fn
7231
; and return a list of doublets, (comp' type') which are the state components,
7232
; comp', and their respective types, type'.
7235
((variablep term) nil)
7236
((fquotep term) nil)
7237
((eq (ffn-symb term) sem-fn) nil)
7239
(state-componentp term svar state-comps-and-types)))
7241
(type (list (list term type)))
7242
(t (find-all-state-components-and-types-outside-lst
7243
(fargs term) sem-fn svar state-comps-and-types)))))))
7245
(defun find-all-state-components-and-types-outside-lst
7246
(terms sem-fn svar state-comps-and-types)
7250
(find-all-state-components-and-types-outside
7251
(car terms) sem-fn svar state-comps-and-types)
7252
(find-all-state-components-and-types-outside-lst
7253
(cdr terms) sem-fn svar state-comps-and-types))))))
7257
; (B.3) replace all projected recursive calls of the semantic function by
7258
; unquoted naturals and build an alist mapping those naturals to the new
7259
; states inside those calls
7263
(defun enumerated-projected-body (term proj-term svar sem-fn alist)
7265
; We copy term, replacing projected recursive calls of sem-fn by integers (not
7266
; quoted evgs!) and build an alist pairing those integers with the next states
7267
; found within the ``projected recursive calls.'' The projected recursive
7268
; calls are calls of sem-fn surrounded by the projector, e.g., (NTH '1 (LOCALS
7269
; (sem-fn svar'))). We return (mv term' alist').
7271
; For example, given the term
7275
; (NTH '1 (LOCALS (sem-fn svar')))
7276
; (NTH '1 (LOCALS (sem-fn svar''))))
7279
; where the projector term is (NTH '1 (LOCALS svar)) and the svar' and svar''
7280
; are the next states, then we'd return:
7287
; '((1 . svar'') (0 . svar')))
7289
; Note that if the returned alist is nil there are NO calls of sem-fn term.
7290
; This could happen in several ways but we suspect the two most common are
7291
; because the code concerned is straight-line or because the code enters an
7292
; already analyzed loop after some preamble. By the way, it is possible for
7293
; term (and hence the returned term') to be constant: e.g., the code enters an
7294
; already-analyzed loop on known values and the simplifier just computes it
7297
(cond ((variablep term) (mv term alist))
7298
((fquotep term) (mv term alist))
7301
(one-way-unify proj-term term)
7302
(let ((sem-fn-call (and flg (cdr (assoc svar subst)))))
7305
(not (variablep sem-fn-call))
7306
(not (fquotep sem-fn-call))
7307
(eq (ffn-symb sem-fn-call) sem-fn))
7308
(let ((next-state (fargn sem-fn-call 1)))
7310
(cons (cons (len alist) next-state)
7313
(enumerated-args new-alist)
7314
(enumerated-projected-body-lst (fargs term) proj-term svar sem-fn alist)
7315
(mv (fcons-term (ffn-symb term) enumerated-args)
7318
(defun enumerated-projected-body-lst (terms proj-term svar sem-fn alist)
7322
(enumerated-arg alist)
7323
(enumerated-projected-body (car terms) proj-term svar sem-fn alist)
7325
(enumerated-args alist)
7326
(enumerated-projected-body-lst (cdr terms) proj-term svar sem-fn alist)
7327
(mv (cons enumerated-arg enumerated-args) alist)))))))
7330
; (B.4) for each site, determine the new value of each of the relevant state
7331
; components in the new state at that site; close the set of relevant
7332
; components by iteration
7334
(defun actual-expressions-by-call (hyps component svar call-number-to-next-state-alist state)
7336
((endp call-number-to-next-state-alist) nil)
7337
(t (cons (cons (caar call-number-to-next-state-alist)
7338
(apply-projector-to-term hyps component svar
7339
(cdar call-number-to-next-state-alist)
7341
(actual-expressions-by-call hyps component svar
7342
(cdr call-number-to-next-state-alist)
7345
(defun components-and-types-to-actual-expressions-by-call
7346
(hyps components-and-types svar call-number-to-next-state-alist state)
7348
; We map over the so-far-identified-as-relevant state components (in doublets
7349
; with their respective types) and make an alist where the keys are the
7350
; individual (component type) doublets and the values are alists that map call
7351
; numbers to the actual expression for the given component in that call.
7353
; (((component1 type1) . ((0 . actual-expr0)
7354
; (1 . actual-expr1)
7356
; ((component2 type2) . ...)
7359
; For example, if component1 is (nth '7 (locals s)) and in some recursive call,
7360
; say call 1, that component is changed to (+ (nth '7 (locals s)) (nth '8
7361
; (locals s))), then actual-expr1 above would be (+ (nth '7 (locals s)) (nth '8
7362
; (locals s))), e.g., in call 1 the new state is
7364
; (update-nth '7 (+ (nth '7 (locals s)) (nth '8 (locals s))) (locals s))
7367
(cond ((endp components-and-types) nil)
7368
(t (cons (cons (car components-and-types)
7369
(actual-expressions-by-call hyps (car (car components-and-types))
7371
call-number-to-next-state-alist
7373
(components-and-types-to-actual-expressions-by-call
7375
(cdr components-and-types)
7376
svar call-number-to-next-state-alist state)))))
7378
(defun collect-new-components-and-types
7379
(sem-fn svar alist seen state-comps-and-types)
7381
; The alist argument maps component expressions and type doublets, (componenti
7382
; typei), to alists mapping call numbers, j, to the new values, actual-exprj,
7383
; of the component in each call,
7385
; (((component1 type1) . ((0 . actual-expr0)
7386
; (1 . actual-expr1)
7388
; ((component2 type2) . ...)
7391
; See the comment in components-and-types-to-actual-expressions-by-call for an
7392
; illustration of ``actual expressions''.
7394
; The seen argument lists all so-far identified (component type) doublets.
7396
; We identify all the state components mentioned in any actual expression of
7397
; alist and return the list of those not occurring in seen, each in a doublet
7398
; with its type, (comp' type').
7404
(set-difference-equal
7405
(find-all-state-components-and-types-outside-lst
7406
(strip-cdrs (cdr (car alist)))
7409
state-comps-and-types)
7411
(collect-new-components-and-types
7412
sem-fn svar (cdr alist) seen state-comps-and-types)))))
7414
(defun components-and-types-to-actual-expressions-by-call*
7415
(hyps new-components-and-types sem-fn svar call-number-to-next-state-alist ans-alist
7416
state-comps-and-types
7418
(let* ((new-ans-alist
7419
(components-and-types-to-actual-expressions-by-call
7420
hyps new-components-and-types svar
7421
call-number-to-next-state-alist state))
7422
(ans-alist (append ans-alist new-ans-alist))
7423
(new-components-and-types
7424
(collect-new-components-and-types
7425
sem-fn svar new-ans-alist
7426
(strip-cars ans-alist)
7427
state-comps-and-types)))
7429
((null new-components-and-types) ans-alist)
7430
(t (components-and-types-to-actual-expressions-by-call*
7431
hyps new-components-and-types sem-fn svar
7432
call-number-to-next-state-alist ans-alist
7433
state-comps-and-types
7437
; (B.5) introduce calls of the new function at each site, generalizing the
7438
; relevant state components and their occurrences in the actuals
7440
; First we deal with generating variable names for vformals.
7442
; Essay on :var-names -- Two Ways for the User to Control the Generation of
7445
; We now develop the code to generate variable names for vformals. We want the
7446
; user to have some convenient control over the names generated. For example,
7447
; the vformal (IPC S) might generalize to the variable PC while the vformal
7448
; (NTH 7 (REGS S)) might generalize to R7 or perhaps R07.
7450
; All of the variable names generated will be in the symbol package of the svar
7451
; of the API. Furthermore, all of the names must be unique -- which is hard
7452
; for the user to guarantee while generating one name at a time and so will be
7453
; guaranteed by the system suffixing each name with an index as necessary.
7454
; Finally, we offer no assurance that any name will actually be a legal ACL2
7455
; variable name except by watching the generated DEFUN fail when we try to
7456
; admit it with an illegal formal parameter name.
7458
; So the issue boils down to how can the user suggest the STRING to be used as
7459
; the initial (or ``root'') symbol-name of the variable generated for a given
7462
; We actually implement two ways to provide such control: a relatively simple
7463
; way to have some limited control and very general powerful way. The powerful
7464
; is for the user to specify a function that maps from terms to fmt msgs (or
7465
; simply to a string).rg (Note that a fmt msg m corresponds to the string
7466
; printed by ~@m). This function is stored in the :var-names slot of the
7469
; But writing functions on terms is hard for some users so we provide a
7470
; simpler, more limited, way to suggest strings. The simple way is implemented
7471
; in terms of the powerful way. Instead of providing a function for
7472
; :var-names, the user can provide def-model-api with an alist that
7473
; associates terms (patterns) with msgs (actually, with the terms that when
7474
; evaluated will produce the msgs). When def-model-api detects that an alist
7475
; has been provided where a function was expected, it translates the alist into
7476
; a suitable lambda expression and stores that as :var-names.
7478
; This allows the simple way to generate names that involve constants mentioned
7479
; in the term, e.g., to map the term (NTH 123 (MEM S)) into "M123" and even to
7480
; transform those constants with simple calculations. For example, since 123 =
7481
; 15*8 + 3, one might wish for (NTH 123 (MEM S)) to be named WORD-15-BYTE-3.
7482
; The latter would be achieved by including this tuple in the alist:
7484
; ((NTH I (MEM S)) "WORD-~x0-BYTE-~x1" (floor I 8) (mod i 8))
7486
; So from the implementation perspective, there is only the powerful way: one
7487
; way or another the user specifies a :var-names function to def-model-api
7488
; and that function maps terms to msgs. But most users will probably employ
7489
; the simple way and not realize they're using the powerful way under the hood.
7491
; Note that to match (NTH '123 (MEM S)) with the (NTH I (MEM S)) term above and
7492
; generate a msg from the rest of the tuple the system must use one-way-unify
7493
; to do the pattern matching -- insisting that the svar be bound to itself and
7494
; all other variables be bound to constants, then it must strip out the quotes
7495
; from around the evgs in the unifying substition -- the variable I will be
7496
; bound to (QUOTE 123) in that substitution, and translate and evaluate the
7497
; remaining terms, (floor I 8) and (mod I 8) under that alist binding variables
7498
; to evgs. If we didn't provide this feature of converting an alist to a
7499
; :var-names, the user would have to use many of these same relatively
7500
; sophisticated ACL2 primitives inside each user-defined :var-names.
7502
; So a typical entry in the alist is (term fmt-string . term-lst). Such
7503
; entries are called ``var name rules'' (or vnrule'').
7505
; We say a term ``triggers'' a vnrule (wrt to a given svar name) if the pattern
7506
; of the vnrule one-way-unifies with the term under two restrictions: (a) svar
7507
; is bound to itself in the unifying substitution and (b) every other variable
7508
; in the pattern is bound to a quoted constant.
7510
; Ideally, searching a list of vnrules for the first one that is triggered by a
7511
; given term would produce a msg. That msg would be obtained by evaluating the
7512
; term-lst of the vnrule under an alist mapping variables to the evgs to which
7513
; they were bound by one-way-unify. But we want the function that does this
7514
; search to be the workhorse in the translation of an alist to a :var-names
7515
; lambda expression and that lambda expression cannot (or, at least, does not)
7516
; take STATE. So we secretly allow :var-names to return not just a msg
7517
; (which is a cons with a stringp car) but a ``meta-msg'' which is
7519
; ((fmt-string . term-lst) . evg-alist)
7521
; and if it returns a meta-msg we evaluate the terms in term-lst under the
7522
; evg-alist and we then create the message, as with (msg fmt-string . values).
7524
; The evaluation of a user-defined :var-namess can just create the intended
7525
; msg directly. So we do not expect user-defined :var-namess to traffic in
7526
; meta-msgs although if one did it would work perfectly well.
7528
; Before proceeding, we exhibit an example. Let's imagine that the svar state
7529
; contains two fields, a pc and a memory and that the memory is accessed with
7530
; nth. So there are two shapes of state components, (PC S) and (NTH ma (MEM
7531
; S)), where ma is some (quoted) constant. Let's suppose we want (PC S) to
7532
; generalize to PC and we want something like (NTH '7 (MEM S)) to generalize to
7535
; The user could define the following
7537
; (defun MY-VAR-NAMES (term)
7540
; (('NTH ('QUOTE ma) '(MEM S))
7546
; (def-model-api ...
7547
; :var-names MY-VAR-NAMES
7550
; Alternatively, the user could write:
7552
; (def-model-api ...
7553
; :var-names (((PC S) "PC")
7554
; ((NTH MA (MEM S)) "M~x0" MA))
7557
; This would translate into:
7559
; (def-model-api ...
7560
; :var-names (lambda (term)
7561
; (trigger-var-name-rule term
7564
; ((NTH MA (MEM S)) "M~x0" MA))))
7567
; where trigger-var-name-rule is a function defined below that searches
7568
; the alist for the first pattern that unifies with term and returns
7569
; a meta-msg. For the term (NTH '7 (MEM S)) it would return
7570
; (("M~x0" MA) . ((MA . 7))). It can't produce the msg we want because
7571
; it doesn't have STATE. But we can produce the msg from that meta-msg
7572
; by evaluating MA under ((MA . 7)) and binding the #\0 to the value.
7574
; By using evaluation we can allow the alist to use any function that
7575
; simple-translate-and-eval can handle, e.g., we allow the alist:
7577
; :var-names (((PC S) "PC")
7578
; ((NTH MA (MEM S)) "WORD-~x0-BYTE-~x1"
7582
; Because of the flexibility of fmt, we can actually do quite a lot with these
7583
; tables. For example, suppose that the first 16 memory locations were to be
7584
; named R00, R01, ..., R15, and then locations above 15 were named M16, M17,
7585
; etc. Here is a table entry that would do that:
7588
; "~#0~[R0~x1~/R~x1~/M~x1~]"
7589
; (if (< ma 10) 0 (if (< ma 16) 1 2))
7592
; Of course, at some point it is probably easier for the user to define a
7593
; special-purpose var-names than to mess around with tilde-directives.
7595
(defun trigger-var-name-rule (term svar vnrules)
7597
; We find the first vnrule in vnrules that is triggered by term and return the
7598
; resulting meta-msg or nil if there is no triggered vnrule.
7600
; If the user provides list a of vnrules in place of the :var-names in the
7601
; def-model-api, then at translate time we set the :var-names to
7604
; (trigger-var-name-rule term ',svar ',vnrules)).
7609
(t (let ((pattern (car (car vnrules)))
7610
(fmt-string-and-term-lst (cdr (car vnrules))))
7612
((eq pattern :otherwise)
7613
; Term-lst is empty when pattern is :otherwise.
7614
fmt-string-and-term-lst)
7615
(t (mv-let (flg subst-alist)
7616
(one-way-unify1 pattern term
7617
(list (cons svar svar)))
7620
(let* ((const-subst (all-but-last subst-alist))
7621
(values (strip-cdrs const-subst)))
7623
; Note: We know the binding of svar is the last element of subst-alist.
7624
; So const-subst is the subst-alist except for the binding of svar.
7627
((all-quoteps values) ; all vars (except svar) are
7628
(let ((evg-alist ; bound to quotes
7629
(pairlis$ (strip-cars const-subst)
7630
(strip-cadrs values))))
7631
(cons fmt-string-and-term-lst ; meta-msg
7633
(t (trigger-var-name-rule term svar (cdr vnrules))))))
7634
(t (trigger-var-name-rule term svar (cdr vnrules)))))))))))
7636
(defun simple-translate-and-eval-term-lst
7637
(term-lst evg-alist ok-stobjs-names msg ctx wrld state aok)
7639
; Unlike its namesake, this function just returns the list of the values of the
7640
; elements of term-lst under evg-alist, not the list of translations and value
7641
; pairs. We cause an error if any ``term'' in term-lst fails to translate or
7642
; causes an error in evaluation. Msg must be a cons of the form (string
7643
; . char-alist), where #\x is not bound in char-alist.
7645
(cond ((endp term-lst)
7648
((pair (simple-translate-and-eval
7653
(cons (cons #\x (car term-lst))
7655
ctx wrld state aok))
7656
(rest (simple-translate-and-eval-term-lst
7661
ctx wrld state aok)))
7662
(value (cons (cdr pair) rest))))))
7664
(defun generalized-meta-msg-to-string (term gmm state)
7666
; Term is only used for error reporting. We convert generalized meta-msg, gmm,
7667
; to a string. First we must consider what sort of object gmm is. The common
7668
; case is that it is a meta-msg produced by a user-supplied vnrules alist for
7669
; :var-names. In that case gmm is of the form ((fmt-string . term-lst)
7670
; . evg-alist) and we fmt-to-string the fmt-string under the alist obtained by
7671
; evaluating the term-lst under evg-alist and binding the resulting vars to
7672
; successive character objects from #\0, ..., #\9. (We do not bother to
7673
; convert a meta-msg to a msg but go directly to the string.) The other
7674
; interesting case is that gmm is a msg (determined by being a cons with
7675
; stringp car). The pathological cases are that gmm is nil, a string, a
7676
; symbol, or anything else.
7680
(cond ((consp (car gmm))
7681
(let ((fmt-string (car (car gmm)))
7682
(term-lst (cdr (car gmm)))
7683
(evg-alist (cdr gmm)))
7684
(er-let* ((args (simple-translate-and-eval-term-lst
7687
nil ; ok-stobjs-names -- none
7688
; Note that the msg below cannot be printed until #\x is bound, which happens
7689
; in simple-translate-and-eval-term-lst, where #\x is bound to each successive
7690
; term being eval'd.
7691
(msg "The expression ~xx, which must be ~
7692
evaluated to generate a binding for the ~
7693
fmt string ~x0, triggered by the state ~
7694
component term ~x1,"
7703
(fmt1-to-string fmt-string
7705
'(#\0 #\1 #\2 #\3 #\4
7706
#\5 #\6 #\7 #\8 #\9)
7709
(declare (ignore col))
7714
(fmt1-to-string (car gmm) (cdr gmm) 0)
7715
(declare (ignore col))
7717
((stringp gmm) (value gmm))
7718
((and gmm (symbolp gmm)) (value (symbol-name gmm)))
7719
(t (value "NO-VAR-NAME-STRING"))))
7722
(defun vformal-to-variable-name-string (var-names term state)
7724
; var-names, as provided for in the API, is a function that takes a term and
7725
; returns a generalized meta-msg. We apply var-names to term to get a
7726
; generalized meta-msg and then convert the meta-msg to a string to use as the
7727
; root of the variable name for term.
7730
((pair (simple-translate-and-eval
7731
(list var-names (list 'quote term))
7732
nil ; alist -- but there are no vars above
7733
nil ; ok-stobjs-names -- none
7734
(msg "The expression ~x0, which must be evaluated to generate a ~
7735
variable name for the quoted term,"
7736
(list var-names (list 'quote term)))
7741
(generalized-meta-msg-to-string term (cdr pair) state)))
7743
(defun ensure-uniqueness-of-variable-name (root-str var i avoid-lst api)
7745
((member-eq var avoid-lst)
7747
(fmt1-to-string "~s0-~x1"
7748
(list (cons #\0 root-str)
7751
(declare (ignore col))
7752
(ensure-uniqueness-of-variable-name
7754
(intern-in-package-of-symbol
7756
(access model-api api :package-witness))
7762
(defun simple-generate-variable-lst (var-names terms avoid-lst api state)
7764
; We generate a distinct variable for each term in terms, all in the package of
7765
; svar and none of which occur in avoid-lst. We return the list of those
7766
; variables. Note: there is no guarantee the results are legal variable names!
7767
; That depends on how var-names is defined. If it returned "*FOO*" the
7768
; result will not be a legal variable.
7771
((endp terms) (value nil))
7774
(vformal-to-variable-name-string var-names (car terms) state))
7777
(ensure-uniqueness-of-variable-name
7779
(intern-in-package-of-symbol
7781
(access model-api api :package-witness))
7786
(simple-generate-variable-lst var-names
7788
(cons var avoid-lst)
7791
(value (cons var rest))))))
7793
(defun get-actuals-for-call-no (k alist)
7795
; Alist maps successive relevant state components to alists that map call
7796
; numbers actual expressions for the given state component. Given a call
7797
; number k, we construct the list of successive actual expressions. E.g., if k
7800
;(((comp1 type1) . ((0 . new-comp1_0) (1 . new-comp1_1) (2 . new-comp1_2)))
7801
; ((comp2 type2) . ((0 . new-comp2_0) (1 . new-comp2_1) (2 . new-comp2_2)))
7802
; ((comp3 type3) . ((0 . new-comp3_0) (1 . new-comp3_1) (2 . new-comp3_2))))
7804
; we return (new-comp1_2 new-comp2_2 new-comp3_2). Thus, if you cons fn onto
7805
; this and generalize away comp1, comp2, and comp3 to the corresponding new
7806
; formal variables you get the kth call of fn.
7808
(cond ((endp alist) nil)
7809
(t (cons (cdr (assoc-equal k (cdr (car alist))))
7810
(get-actuals-for-call-no k (cdr alist))))))
7812
(defun make-fn-call-for-call-no (fn k alist generalizing-alist)
7814
; We create the kth call of fn, expressed in terms of the new variables.
7817
(sublis-expr-lst generalizing-alist
7818
(get-actuals-for-call-no k alist))))
7820
; Suppose term is an enumerated body, i.e., result of simplifying the
7821
; application of the projector function to the body of the semantic function
7822
; with the `recursive calls' replaced by successive integers. Suppose fn is
7823
; the name of the new fn, alist maps successive state components and types to
7824
; alists mapping call numbers to new values of the component, and
7825
; generalizing-alist is an expr-to-var alist generalizing the state components.
7826
; Then we copy term, generalizing all the state components and replacing the
7827
; call numbers by appropriate calls.
7829
; Note: we do not handle the type restrictions on the components/new variables
7830
; here. Recalling the comment above in the Essay On Identifying State
7831
; Components, restrictions on the new variables are of three kinds (a) tests
7832
; made by the code, (b) tests derived from the invariant hyps, and (c)
7833
; intrinsic types of components. Term (and hence the result produced below)
7834
; contain only the tests from (a).
7838
(defun re-introduce-recursions-and-generalize
7840
; See comment above.
7842
(fn alist generalizing-alist term)
7843
(cond ((integerp term)
7844
(make-fn-call-for-call-no fn term alist generalizing-alist))
7845
((assoc-equal term generalizing-alist)
7846
(cdr (assoc-equal term generalizing-alist)))
7847
((variablep term) term)
7848
((fquotep term) term)
7849
(t (cons (ffn-symb term)
7850
(re-introduce-recursions-and-generalize-lst
7851
fn alist generalizing-alist (fargs term))))))
7853
(defun re-introduce-recursions-and-generalize-lst
7854
(fn alist generalizing-alist term-lst)
7856
((endp term-lst) nil)
7858
(re-introduce-recursions-and-generalize
7859
fn alist generalizing-alist (car term-lst))
7860
(re-introduce-recursions-and-generalize-lst
7861
fn alist generalizing-alist (cdr term-lst)))))))
7864
; (B.6) determine the restrictions imposed by the invariant on the relevant state
7867
(defun invariant-on-vformals (vformal-replacement-pairs base hyps state)
7869
(assignments uninvertables)
7870
(invert-vformals vformal-replacement-pairs
7872
(cdr (assoc-eq :list (table-alist 'generalized-updater-drivers (w state))))
7873
(cdr (assoc-eq :list (table-alist 'constructor-drivers (w state))))
7877
(er soft 'invariant-on-vformals
7878
"We were unable to invert ~&0. This means you probably need to ~
7879
extend the driver tables in your DEF-MODEL-API command. To see the ~
7880
current tables evaluate (TABLE ACL2::MODEL-API)."
7882
((not (subsetp-equal (all-vars1-lst (strip-cdrs assignments) nil)
7883
(cons base (strip-cdrs vformal-replacement-pairs))))
7884
(er soft 'invariant-on-vformals
7885
"It was thought impossible that the inversion of virtual formals ~
7886
into their corresponding single assignment expressions would ~
7887
produce terms involving variables other than the base variable, ~
7888
~x0, and the new value variables, ~x1. But the inversions below ~
7889
contain the variables ~x2. The inversions are shown below as (var ~
7890
assignment) doublets:~%~X34."
7892
(strip-cdrs vformal-replacement-pairs)
7893
(all-vars1-lst (strip-cdrs assignments) nil)
7894
(pairlis$ (strip-cars assignments)
7895
(pairlis-x2 (strip-cdrs assignments)
7900
(flatten-ands-in-lit
7901
(simplify-under-hyps
7903
`((lambda (,base) ,(conjoin hyps))
7904
,(compose-vformal-assignments assignments base nil))
7908
((not (subsetp-equal (all-vars1-lst conjuncts nil)
7909
(strip-cdrs vformal-replacement-pairs)))
7910
(er soft 'invariant-on-vformals
7911
"The attempt to isolate the constraints imposed by the ~
7912
invariant terms, ~X01, on the state components of interest, ~
7913
~X21, has failed. The isolated invariants must mention only ~
7914
the variables ~x3, but they in fact mention ~x4.~%~%This can ~
7915
occur if some rewrite rules are missing or unable to fire. ~
7916
In the latter case, it may be that your specified invariant ~
7917
on the initial state is too weak to imply the hypotheses of ~
7918
some rewrite rule. Other causes of this symptom are that ~
7919
state components are not independent -- e.g., writing to one ~
7920
affects reading from another -- or it is impossible to write ~
7921
to a relevant component.~%~%The `isolated' invariants are ~
7922
shown below and might give you a clue about the cause of this ~
7923
problem. These terms should simplify, under your invariant, ~
7924
to terms that mention no free variables other than the ~
7925
projected formals of the new function, ~X31. Try to prove ~
7926
rewrite rules and/or strengthen your invariant to allow the ~
7927
offending terms to simplify into terms that mention no free ~
7928
variables other than ~X31. `Isolated' contraints:~%~%~X51."
7931
(strip-cars vformal-replacement-pairs)
7932
(strip-cdrs vformal-replacement-pairs)
7933
(all-vars1-lst conjuncts nil)
7936
(value (conjoin conjuncts)))))))))
7938
; (B.7) rearrange all the definitions' formals and calls so that formals are
7939
; in alphabetical order
7941
(defun permutation-map1 (lst i lst1)
7942
(cond ((endp lst) nil)
7943
(t (cons (cons i (- (len lst1)
7944
(len (member-equal (car lst) lst1))))
7945
(permutation-map1 (cdr lst) (+ 1 i) lst1)))))
7947
(defun permutation-map-for-non-duplicates (lst)
7949
; A ``permutation map'' (or ``pmap'') is a list of (i . j) pairs meaning the
7950
; that ith component of a list is to become the jth component in the reordered
7953
(permutation-map1 lst 0 (merge-sort-lexorder lst)))
7955
(defun apply-permutation-map-to-list1 (pmap lst ans)
7956
(cond ((endp pmap) ans)
7957
(t (apply-permutation-map-to-list1
7960
(update-nth (cdr (car pmap))
7961
(nth (car (car pmap)) lst)
7964
(defun apply-permutation-map-to-list (pmap lst)
7965
(apply-permutation-map-to-list1 pmap lst nil))
7968
(defun apply-permutation-map-to-term (pmap fn term)
7970
((variablep term) term)
7971
((fquotep term) term)
7972
((eq fn (ffn-symb term))
7975
(apply-permutation-map-to-list pmap (fargs term))))
7978
(apply-permutation-map-to-term-lst pmap fn
7981
(defun apply-permutation-map-to-term-lst (pmap fn term-lst)
7983
((endp term-lst) nil)
7984
(t (cons (apply-permutation-map-to-term pmap fn (car term-lst))
7985
(apply-permutation-map-to-term-lst pmap fn
7986
(cdr term-lst)))))))
7989
; (B.8) determine whether there are other projected state components that
7990
; still occur in the body and if so cause an error
7992
(defun make-sub-def-projections (fn i required-sub-projections dpro-alist api)
7994
((endp required-sub-projections)
7997
(intern-in-package-of-symbol
8002
(coerce (packn1 (list i)) 'string)))
8003
(access model-api api :package-witness))))
8004
(cons `(def-projection
8006
:projector ,(car (car required-sub-projections))
8007
:old-fn ,(cdr (car required-sub-projections))
8008
:hyps+ ,(cdr (assoc-eq :hyps+ dpro-alist)))
8009
(make-sub-def-projections fn (+ i 1)
8010
(cdr required-sub-projections)
8011
dpro-alist api))))))
8013
; Now we begin putting it all together.
8015
; See Guide. Overview of How the Def-Projection Command Works
8017
(defun translate-def-projection-args (alist api state)
8019
; We take the alist of keyword arguments provided to def-projection and translate
8020
; each value, producing either an error or an alist mapping each keyword to its
8021
; translated value. The result is called ``dpro-alist'' in parallel with
8024
(let ((new-fn (cdr (assoc-eq :new-fn alist)))
8025
(projector (cdr (assoc-eq :projector alist)))
8026
(old-fn (cdr (assoc-eq :old-fn alist)))
8027
(hyps+ (cdr (assoc-eq :hyps+ alist)))
8028
(svar (access model-api api :svar)))
8030
((not (symbolp new-fn))
8031
(er soft 'def-projection
8032
"The first argument of DEF-PROJECTION must be a symbol and ~x0 isn't."
8034
((not (and (symbolp old-fn)
8035
(equal (arity old-fn (w state)) 1)))
8036
(er soft 'def-projection
8037
"The third argument of DEF-PROJECTION must be a function symbol of ~
8038
arity 1 naming the target semantic function; ~x0 isn't."
8040
((not (eq (legal-variable-or-constant-namep svar) 'variable))
8041
(er soft 'def-projection
8042
"The fourth argument of DEF-PROJECTION must be a symbol naming the ~
8043
state variable and ~x0 isn't."
8047
(translate projector t t nil 'def-projection (w state) state))
8050
(chk-true-listp hyps+
8052
"The :HYPS+ argument"
8054
(translate-list-of-terms hyps+ state))))
8056
; Here are the full-translated def-projection arguments in alist form, aka
8060
`((:new-fn . ,new-fn)
8061
(:projector . ,projector)
8063
(:hyps+ . ,hyps+))))))))
8065
(defun project-fn-to-fn (dpro-alist api state)
8066
(let* ((new-fn (cdr (assoc-eq :new-fn dpro-alist)))
8067
(projector (cdr (assoc-eq :projector dpro-alist)))
8068
(old-fn (cdr (assoc-eq :old-fn dpro-alist)))
8069
(hyps+ (cdr (assoc-eq :hyps+ dpro-alist)))
8070
(api+ (change model-api
8072
:hyps (append (access model-api api :hyps)
8074
(svar (access model-api api+ :svar))
8075
(hyps (access model-api api+ :hyps))
8076
(state-comps-and-types
8077
(access model-api api+ :state-comps-and-types))
8079
(access model-api api+ :var-names))
8081
(apply-projector-to-term hyps projector svar
8082
(body old-fn t (w state)) state))
8083
(init-components-and-types
8084
(find-all-state-components-and-types-outside
8085
init-body old-fn svar state-comps-and-types))
8086
(state-expression-patterns
8092
(table-alist 'generalized-updater-drivers (w state))))
8096
(table-alist 'constructor-drivers (w state))))))))
8098
(ebody call-number-alist)
8099
(enumerated-projected-body init-body projector svar old-fn nil)
8101
; Ebody is init-body with all the projected recursions replaced by integers and
8102
; call-number-alist is the map from those integers to the next state
8103
; expressions in the corresponding recursions.
8105
(let* ((components-and-types-alist
8106
(components-and-types-to-actual-expressions-by-call*
8108
init-components-and-types
8113
state-comps-and-types
8115
(vformals (strip-cars (strip-cars components-and-types-alist))))
8117
(simple-generate-variable-lst var-names vformals
8121
; The next three bindings need not be in this er-let*, but we'd just have to
8122
; shift out to a let and then get back into an er-let* so we did it this way.
8124
(pmap (value (permutation-map-for-non-duplicates formals)))
8125
(generalizing-alist (value (pairlis$ vformals formals)))
8127
; Body, below, contains the tests made by the code itself, expressed in terms
8128
; of the new formals. These tests are from source (a) of the discussion On
8129
; Identifying State Components.
8131
(value (re-introduce-recursions-and-generalize
8132
new-fn components-and-types-alist generalizing-alist ebody)))
8135
(invariant-on-vformals generalizing-alist svar hyps state)))
8137
; Body1 contains the tests derived from the invariant, i.e., from source (b)
8140
(let* ((body1 (if (eq generalized-hyp *t*)
8142
`(IF ,generalized-hyp
8146
; Body2, below, contains the hyps (generalized to the new formals) derived from
8147
; inherent properties of the virtual formals, i.e., from source (c).
8154
(strip-cars components-and-types-alist)))))
8155
(body2 (if (equal inherent-hyp *t*)
8161
; Formals3 and body3 are the formals and body that we'll actually use. They
8162
; have been reordered to put the formals into lexorder. Note: there is no
8163
; formals1 or formals2, it's just that we want formals3 and body3 to be used
8166
(formals3 (apply-permutation-map-to-list pmap formals))
8167
(body3 (apply-permutation-map-to-term pmap new-fn body2))
8169
(required-sub-projections
8170
(all-projector-and-other-fnsymb
8172
state-comps-and-types
8173
state-expression-patterns)))
8175
(required-sub-projections
8176
(er soft 'def-projection
8177
"The following additional projections should be performed ~
8178
before this one has a chance of succeeding. We don't do ~
8179
this automatically because you may want to change the names ~
8180
given to the various new functions or otherwise change the ~
8181
commands. We thought it best for you to be in charge. ~
8182
Resubmit the current projection when you've successfully done ~
8183
those below.~%~%By the way, because new projections can ~
8184
introduce new state components to be tracked, you may have ~
8185
to iterate this process several times before all the ~
8186
relevant state components are identified. Here are the ~
8187
projections we currently require:~%~%~*0~%~%These ~
8188
projections are based on this partially simplified ~
8189
``definition'' for the function you requested. This ~
8190
``definition'' does not satisfy even the ~
8191
most rudimentary syntactic rules for definitions because we ~
8192
failed to simplify certain subexpressions. Perhaps these ~
8193
will suggest additional rules to prove or additional ~
8194
hypotheses to add to this projection so that existing rules ~
8195
will fire.~%~%~X12~%~%If all else fails, you might try ~
8196
(trace$ acl2::simplify-under-hyps) and look at the returned ~
8197
terms and see if any strike you as susceptible to further ~
8199
(list* "~X*1~%~%" "~X*1~%~%" "~X*1~%~%" "~X*1~%~%"
8200
(make-sub-def-projections new-fn 0
8201
required-sub-projections
8203
(list (cons #\1 nil)))
8204
`(DEFUNM ,new-fn ,formals3 ,body3)
8207
(er soft 'def-projection
8208
"We were unable to eliminate all occurrences of the state ~
8209
variable, ~x0, from the projected body of ~x1. How might ~
8210
you make it possible to eliminate the state ~
8211
variable?~%~%One possibility is to add conjuncts to the ~
8212
governing :hyps invariant in your DEF-MODEL-API command, so ~
8213
that the offending occurrences are eliminated because they ~
8214
appear on now-impossible paths. This approach may not be ~
8215
available to you, since the strengthened hypothesis must be ~
8216
invariant as ~x1 recurs.~%~%Another possibility is to add ~
8217
entries to the :STATE-COMPS-AND-TYPES of your DEF-MODEL-API ~
8218
so that the expressions containing the offending ~
8219
occurrences are generalized to new formal parameters. This ~
8220
approach may not be available because all the listed ~
8221
patterns must be mutually ``orthogonal,'' changing the ~
8222
value of one such state component must not affect the value ~
8223
of any other. Thus, for example, it is impossible for both ~
8224
the 8 byte word starting at address m to be a component ~
8225
while the 4 byte word starting at that same address m is ~
8226
too: they are not orthogonal.~%~%A third possibility is ~
8227
that the offending occurrence of ~x0 appears in an argument ~
8228
to a subfunction of ~x4. If this is the case -- and some ~
8229
component of the subfunction's value is being used in the ~
8230
projection we're trying to develop here -- then it would be ~
8231
helpful to first do that projection, i.e., create a ~
8232
DEF-PROJECTION command of the relevant component of the ~
8233
subfunction. Then return to the def-projection you're ~
8234
trying to do now. Normally we detect this need for another ~
8235
def-projection and warn you about it explicitly, but we ~
8236
cannot do so here because the un-projected expression is ~
8237
holding an un-eliminated occurrence of state.~%~%A fourth ~
8238
alternative is to take the sketch of the derived projection ~
8239
below as your starting point and edit it to your ~
8240
satisfaction! Below is an approximation of what ~
8241
DEF-PROJECTION has generated. Unfortunately, we can't even ~
8242
generate the final version because we can't make it satisfy ~
8243
even the basic syntactic rules of a ~
8244
definition.~%~%~X23~%~%Perhaps the ``definition'' above ~
8245
will suggest additional rules to prove or additional ~
8246
hypotheses to add to your model API. If all else fails, ~
8247
you might try (trace$ acl2::simplify-under-hyps) and look ~
8248
at the returned terms and see if any strike you as ~
8249
susceptible to further simplification!"
8252
`(DEFUNM ,new-fn ,formals3 ,body3)
8260
(er-progn (defunm ,new-fn ,formals3 ,body3)
8261
(assign def-projection-body4
8262
(simplify-under-hyps nil ',body3 state))))
8265
(DEFUNM ,',new-fn ,',formals3
8266
:OPTIONS (:NON-REC-FLAG-LEMMAS)
8269
(@ def-projection-body4))
8272
(DEFTHM ,',(intern-in-package-of-symbol
8273
(coerce (append (coerce (symbol-name new-fn) 'list)
8274
(coerce "-CORRECT" 'list))
8276
(access model-api api+ :package-witness))
8278
,',(pretty-and hyps)
8280
,',(subst-var (list old-fn svar) svar projector)
8281
(,',new-fn ,@',(apply-permutation-map-to-list
8283
(strip-cars generalizing-alist)))))))))))))))))))
8285
(defmacro def-projection (&key new-fn projector old-fn hyps+)
8289
(translate-def-projection-args
8290
'((:new-fn . ,new-fn)
8291
(:projector . ,projector)
8294
(cdr (assoc-eq :record (table-alist 'model-api (w state))))
8298
(project-fn-to-fn ',dpro-alist
8299
(cdr (assoc-eq :record (table-alist 'model-api (w state))))
8302
; =============================================================================
8303
; How to Certify Codewalker
8305
; The files you'll need (on some directory) to run Codewalker and a
8306
; demonstration of it are:
8309
; simplify-under-hyps.lisp
8310
; terminatricks.lisp
8315
; To certify all these books (except the last, which is not a book) execute the
8316
; following in ACL2 or ACL2(h):
8318
; (certify-book "if-tracker") ; used by Terminatricks and Codewalker via
8320
; (certify-book "simplify-under-hyps") ; used by Terminatricks and Codewalker
8322
; (certify-book "terminatricks")
8324
; (certify-book "codewalker")
8327
; (set-difference-eq (union-eq *acl2-exports*
8328
; *common-lisp-symbols-from-main-lisp-package*)
8329
; '(push pop pc program step)))
8330
; (certify-book "m1-version-3" 1)
8334
; If you want to use Emacs tags tables to jump around in the code, run etags in a shell and
8335
; visit the tags table on this directory:
8337
; % etags if-tracker.lisp simplify-under-hyps.lisp terminatricks.lisp codewalker.lisp m1-version-3.lisp
8339
; To run the demo do
8341
; (ld "basic-demo.lsp" :ld-pre-eval-print t)
8343
; [the end -- search backwards twice for the barrier to get to the top of Code]
8344
; =============================================================================
added
removed
books/projects/codewalker/codewalker.lisp
