-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy paths79-micro-macros.lisp
189 lines (159 loc) · 8.93 KB
/
s79-micro-macros.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
(in-package :scheme-mach)
;; for now we put this into :scheme-mach but due to collision with CL we may want a more restricted package in the
;; future (so not all :scheme-mach packages have to reference "cl:cond" for instance)
(scheme-79:scheme-79-version-reporter "Scheme Microcode Macros" 0 4 0
"Time-stamp: <2022-03-18 15:30:45 gorbag>"
"use intentional upla fns")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 0.4.0 3/18/22 snapping a line: 0.4 release of scheme-79 supports test-0 thru test-3. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 0.3.2 2/ 2/22 use intentional upla fns
;; 0.3.1 1/31/22 use :suppress-logging instead of :constituent on defufn if
;; that's what we mean
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 0.3.0 1/11/22 snapping a line: 0.3 release of scheme-79 supports test-0 and test-1. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 0.1.10 1/ 4/22 make generate-cond-test a method rather than a defun. This allows us to invoke
;; the generic function inside validation code defined under support!
;; 0.1.9 12/14/21 use defumac for macro defufns.
;; 0.1.8 12/ 3/21 update scheme-79-mcr-i -> "" (if from microlisp-int or fpga-pla-build-tools)
;; update scheme-79-mcr -> microlisp
;; 0.1.7 10/ 8/21 fix validation of cond, if
;; 0.1.6 9/27/21 scheme-79-mcr:progn, if, cond
;; 0.1.5 09/20/21 fix call to generate-cond-test in NOT processing
;; 0.1.4 09/18/21 look up inverted predicate for NOT
;; 0.1.3 09/14/21 add (COND): to upla-comment so it shows up on console
;; 0.1.2 08/30/21 use compare-to-type-const (a defufn) to make code generation consistant.
;; 0.1.1 added "if"
;; 0.1.0 Moved to own file form sim-machine-internal.lisp
;; *special-ucode-operations-alist*
;; cond
(defun generate-cond-test-boolean (test-clause success-tag fail-tag)
;; not just a simple test, so we have to break down into multiple tests
(case (car test-clause)
(and
(generate-cond-test-and (cdr test-clause) success-tag fail-tag))
(or
(generate-cond-test-or (cdr test-clause) success-tag fail-tag))
(not
;; just invert tags (ok, that won't work because tags are in a special position)
;;(generate-cond-test (cadr test-clause) fail-tag success-tag)
;; instead we have to look up the inverse predicate 9/18/21 BWM
(generate-cond-test `(,(invert-predicate (caadr test-clause)) ,(cadadr test-clause)) success-tag fail-tag))))
(defun generate-cond-test-and (and-clauses success-tag fail-tag)
(let* ((current-expression (car and-clauses))
(ce-success-tag (gensym "$BOOL-SUCCEED"))
(ce-fail-tag (gensym "$BOOL-FAIL")))
(cl:cond
((cdr and-clauses) ; will have more clauses
`(,@(generate-cond-test current-expression ce-success-tag ce-fail-tag)
(tag ,ce-fail-tag)
(go-to ,fail-tag) ;done
(tag ,ce-success-tag)
;;next AND test
,@(generate-cond-test-and (cdr and-clauses) success-tag fail-tag)))
(t
(generate-cond-test current-expression success-tag fail-tag)))))
(defun generate-cond-test-or (or-clauses success-tag fail-tag)
(let* ((current-expression (car or-clauses))
(ce-success-tag (gensym "$BOOL-SUCCEED"))
(ce-fail-tag-1 (gensym "$BOOL-FAIL"))
(ce-fail-tag-2 (gensym "$BOOL-FAIL2")))
(cl:cond
((cdr or-clauses) ; will have more clauses
`(,@(generate-cond-test current-expression ce-success-tag ce-fail-tag-1)
(tag ,ce-fail-tag-1)
(go-to ,ce-fail-tag-2) ; have to skip over success address
(tag ,ce-success-tag)
(go-to ,success-tag) ; done
(tag ,ce-fail-tag-2)
;;next OR test
,@(generate-cond-test-or (cdr or-clauses) success-tag fail-tag)))
(t
(generate-cond-test current-expression success-tag fail-tag)))))
;; make this a method so we can define the generic function in support (used by the validator) 1/4/22 BWM
(defmethod generate-cond-test (test-clause success-tag fail-tag)
;; return a LIST of microcode statements
(cl:cond
((member (car test-clause) *boolean-terms*) ; complex?
(generate-cond-test-boolean test-clause success-tag fail-tag))
((endp (cdr test-clause)) ; simple test
`((simple-branch ,(car test-clause) ,fail-tag ,success-tag)))
((and (consp (cadr test-clause))
(endp (cddr test-clause)) ; one argument
(eql (caadr test-clause) 'fetch)) ; typical case
`((fetch-and-test-for-success ,(cadadr test-clause) ,(car test-clause) ,fail-tag ,success-tag)))
((and (consp (cadr test-clause))
(eql (caadr test-clause) 'fetch)
(consp (caddr test-clause))
(eql (caaddr test-clause) 'fetch) ; some kind of comparison between two registers
(endp (cdddr test-clause))) ; two arguments
`((compare-registers ,(car test-clause) ,(cadadr test-clause) ,(cadaddr test-clause) ,fail-tag ,success-tag)))
((eql (car test-clause) '&=type?) ; have to handle special for now, presuming next arg is a register then a constant
`((compare-to-type-const ,(cadadr test-clause) ,(caddr test-clause) ,fail-tag ,success-tag)))
(t
(error "generate-cond-test: unhandled case ~s" test-clause))))
;; note that this code may generate some wasted GO-TO instructions and
;; tags (particularly if the COND will never "fall through"), but we
;; can clean that up in an intermediate pass before PASS-5 if needed
;; (do some basic block code analysis)
(defumac microlisp:cond (&rest cond-expressions :args-last t :suppress-logging t)
(let ((remaining-expressions cond-expressions)
(proposed-code nil)
(end-cond-tag (gensym "$COND-DONE")))
;; set up a list of tests and progns
(while remaining-expressions
(let* ((current-expression (pop remaining-expressions))
(fail-tag (gensym "$COND-FAIL"))
(success-tag (gensym "$COND-SUCCEED"))
(end-clause-tag (gensym "$COND-NEXT-CLAUSE"))
(test-clause (car current-expression))
(progn-clause (cadr current-expression)) ; should have the progn inserted by the validator
(proposed-clause (cl:if (eql test-clause 't)
`(,progn-clause
(tag ,(cl:if remaining-expressions
end-clause-tag ; strange construct, probably should warn
end-cond-tag)))
`(,@(generate-cond-test test-clause success-tag fail-tag)
(tag ,fail-tag)
(go-to ,(cl:if remaining-expressions
end-clause-tag
end-cond-tag))
(tag ,success-tag)
,progn-clause
(go-to ,end-cond-tag)
(tag ,(cl:if remaining-expressions
end-clause-tag
end-cond-tag))))))
(setq proposed-code (append proposed-code proposed-clause))))
;; something for the log
(when *upla-stream*
(upla-write-code-annotation '(microlisp:COND)) ; so something shows up on the console
(upla-write-local-comment `(microlisp:cond ,@cond-expressions)))
(compile-embedded-expression `(microlisp:progn ,@proposed-code))))
;; if
(defumac microlisp:if (predicate-clause success-clause &optional failure-clause :args-last t :suppress-logging t)
(let ((fail-tag (gensym "$IF-FAIL"))
(fail-clause-tag (gensym "$IF-FAIL-CLAUSE"))
(success-tag (gensym "$IF-SUCCEED"))
(done-tag (gensym "$END-IF"))
(fail-clauses (cl:if failure-clause (list failure-clause)))) ; force list for splice
(compile-embedded-expression
`(microlisp:progn
,@(generate-cond-test predicate-clause success-tag fail-tag)
(tag ,fail-tag)
(go-to ,fail-clause-tag)
(tag ,success-tag)
,success-clause
(go-to ,done-tag)
(tag ,fail-clause-tag)
,@fail-clauses ; have to splice in case it's empty
(tag ,done-tag)))))
;; progn
(defumac microlisp:progn (&rest ucode-expressions :args-last t :suppress-logging t)
;; just collect the results of compiling the expressions
(let ((*upla-suppress-annotation* nil)) ;; allow annotations for the broken-apart progn instructions
(mapcan #'(lambda (expression)
(let ((compiled-expression (compile-embedded-expression expression))) ; suppress check
(copy-list compiled-expression))) ;avoid corruption
ucode-expressions))) ; do the copy to prevent munging constants