Coverage report: /home/runner/work/geb/geb/src/seqn/trans.lisp

KindCoveredAll%
expression108610 17.7
branch256 3.6
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.seqn.trans)
2
 
3
 (defun remove0-dom (morphism)
4
   (remove 0 (dom morphism)))
5
 
6
 ;; Add range-n function
7
 
8
 (defun range-constraints-dom (domain)
9
   (cond ((null domain) nil)
10
         ((not (cdr domain))
11
          (list (geb.vampir:range-n
12
                 (vamp:make-constant :const (car domain))
13
                 (vamp:make-wire :var
14
                                 (intern (format nil "X~a" 1))))))
15
         (t
16
          (cons (geb.vampir:range-n
17
                 (vamp:make-constant :const (car (last domain)))
18
                 (vamp:make-wire :var (intern (format nil "X~a" (length domain)))))
19
           (range-constraints-dom (butlast domain))))))
20
 
21
 (defmethod to-circuit ((morphism <seqn>) name)
22
   "Turns a SeqN term into a Vamp-IR Gate with the given name
23
 Note that what is happening is that we look at the domain of the morphism
24
 and skip 0es, making non-zero entries into wires"
25
   (let* ((wire-count (length (dom morphism)))
26
          (wires (loop for i from 1 to wire-count
27
                       collect (vamp:make-wire :var (intern (format nil "X~a" i)
28
                                                            :keyword)))))
29
     (list
30
      (vamp:make-alias
31
       :name name
32
       :inputs wires
33
       :body
34
       (list
35
        (vamp:make-tuples
36
         :wires
37
         (mapcar #'to-vampir-opt
38
                 (remove nil
39
                         (filter-map (lambda (x)
40
                                       (unless (zerop (car x))
41
                                         (cadr x)))
42
                                     (prod-list (cod morphism)
43
                                                (to-vampir morphism wires nil)))))))))))
44
 
45
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46
 ;; SeqN to Vamp-IR Compilation
47
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48
 
49
 (defmethod to-vampir ((obj <seqn>) values constraints)
50
   "The method takes a list of values, i.e. a list of wires with
51
 0-wide entries removed and spits out a list of wires to be later
52
 made into a tuple or a single entry if the codomain is isomorphic
53
 to (n) for some n"
54
   (declare (ignore constraints))
55
   (declare (ignore values))
56
   (geb.utils:subclass-responsibility obj))
57
 
58
 (defun const-check (obj1 obj2)
59
   (and (typep obj1 'vamp:constant)
60
        (typep obj2 'vamp:constant)))
61
 
62
 (defmethod to-vampir-opt ((obj vamp:application))
63
   (let* ((zero (vamp:make-constant :const 0))
64
          (one (vamp:make-constant :const 1))
65
          (car (car (vamp:arguments obj)))
66
          (cadr (cadr (vamp:arguments obj)))
67
          (opcar (to-vampir-opt car))
68
          (opcadr (to-vampir-opt cadr))
69
          (const-check (const-check opcar opcadr)))
70
     (cond  ((obj-equalp (vamp:func obj) :isZero)
71
             (if const-check
72
                 (if (= (vamp:const opcar)
73
                        (vamp:const opcadr))
74
                     zero
75
                     one)))
76
            ((obj-equalp (vamp:func obj) :negative)
77
             (if const-check
78
                 (if (< (vamp:const opcar)
79
                        (vamp:const opcadr))
80
                     zero
81
                     one)))
82
            (t (mapcar 'to-vampir-opt (vamp:arguments obj))))))
83
 
84
 (defmethod to-vampir-opt ((obj vamp:constant))
85
   obj)
86
 
87
 (defmethod to-vampir-opt ((obj vamp:wire))
88
   obj)
89
 
90
 (defmethod to-vampir-opt ((obj geb.vampir.spec:infix))
91
   (let*  ((lhs (vamp:lhs obj))
92
           (rhs (vamp:rhs obj))
93
           (oplhs (to-vampir-opt lhs))
94
           (oprhs (to-vampir-opt rhs))
95
           (ob+ (obj-equalp (vamp:op obj) :+))
96
           (ob- (obj-equalp (vamp:op obj) :-))
97
           (ob/ (obj-equalp (vamp:op obj) :/))
98
           (ob* (obj-equalp (vamp:op obj) :*)))
99
     (if (const-check oplhs
100
                      oprhs)
101
         (let ((constl (vamp:const oplhs))
102
               (constr (vamp:const oprhs)))
103
           (cond (ob+  (vamp:make-constant
104
                        :const (+ constl constr)))
105
                 (ob- (vamp:make-constant
106
                       :const (- constl constr)))
107
                 (ob* (vamp:make-constant
108
                       :const (* constl constr)))
109
                 (ob/ (vamp:make-constant
110
                       :const
111
                       (multiple-value-bind (q)
112
                           (floor constl
113
                                  constr)
114
                         q)))))
115
         (cond (ob+ (make-opt-plus oplhs oprhs))
116
               (ob- (make-opt-minus oplhs oprhs))
117
               (ob/ (make-opt-divide oplhs oprhs))
118
               (ob* (make-opt-times oplhs oprhs))))))
119
 
120
 (defun infix-creation (symbol value1 value2)
121
   (vamp:make-infix :op symbol
122
                    :lhs value1
123
                    :rhs value2))
124
 
125
 ;; Make wire function accessing the wire list
126
 
127
 (defmethod to-vampir ((obj id) inputs constraints)
128
   "Given a tuple (x1,...,xn) does nothing with it"
129
   (declare (ignore constraints))
130
   inputs)
131
 
132
 (defmethod to-vampir ((obj composition) inputs constraints)
133
   "Compile the MCADR after feeding in appropriate
134
 inputs and then feed them as entries to compiled MCAR"
135
   (to-vampir (mcar obj)
136
              (to-vampir (mcadr obj) inputs constraints)
137
              constraints))
138
 
139
 (defmethod to-vampir ((obj parallel-seq) inputs constraints)
140
   "Compile MCAR and MCADR and then apppend the tuples"
141
   (let* ((mcar (mcar obj))
142
          (mcadr (mcadr obj))
143
          (lmcar (length (dom mcar))))
144
     (append (to-vampir mcar
145
                        (subseq inputs 0 lmcar)
146
                        constraints)
147
             (to-vampir mcadr
148
                        (subseq inputs
149
                                lmcar)
150
                        constraints))))
151
 
152
 (defmethod to-vampir ((obj fork-seq) inputs constraints)
153
   "Given a tuple (x1,...,xn) copies it twice"
154
   (declare (ignore constraints))
155
   ;; Since we feed in wires, simply ask for its list of wires and appent
156
   (append inputs inputs))
157
 
158
 (defmethod to-vampir ((obj drop-nil) inputs constraints)
159
   "Drops everything by producing nothing"
160
   (declare (ignore inputs constraints))
161
   (list (vamp:make-constant :const 0)))
162
 
163
 (defmethod to-vampir ((obj remove-right) inputs constraints)
164
   "We do not have nul inputs so does nothing"
165
   (declare (ignore constraints))
166
   (butlast inputs))
167
 
168
 (defmethod to-vampir ((obj remove-left) inputs constraints)
169
   "We do not have nul inputs so does nothing"
170
   (declare (ignore constraints))
171
   (cdr inputs))
172
 
173
 (defmethod to-vampir ((obj drop-width) inputs constraints)
174
   "The compilation does not produce dropping with domain inputs
175
 wider than codomain ones appropriately. Hence we do not require range
176
 checks here and simply project"
177
   (declare (ignore constraints))
178
   inputs)
179
 
180
 (defmethod to-vampir ((obj inj-length-left) inputs constraints)
181
   "Look at the MCAR. Look at non-null wide entries and place
182
 0-es in the outputs otherwise ignore"
183
   (declare (ignore constraints))
184
   (append inputs
185
           (make-list (length  (mcadr obj))
186
                      :initial-element (vamp:make-constant :const 0))))
187
 
188
 (defmethod to-vampir ((obj inj-length-right) inputs constraints)
189
   "Look at the MCADR. Look at non-null wide entries and place
190
 0-es in the outputs "
191
   (declare (ignore constraints))
192
   (append (make-list (length  (mcar obj))
193
                      :initial-element (vamp:make-constant :const 0))
194
           inputs))
195
 
196
 (defmethod to-vampir ((obj inj-size) inputs constraints)
197
   "During th ecompilation procedure the domain will not have larger
198
 width than the codomain so we simply project"
199
   (declare (ignore constraints))
200
   inputs)
201
 
202
 (defmethod to-vampir ((obj branch-seq) inputs constraints)
203
   "With the leftmost input being 1 or 0, pointwise do usual bit
204
 branching. If 0 run the MCAR, if 1 run the MCADR"
205
   (let* ((car   (car inputs))
206
          (left  (to-vampir (mcar obj) (cdr inputs) constraints))
207
          (right (to-vampir (mcadr obj) (cdr inputs) constraints)))
208
     (mapcar (lambda (x)
209
               (infix-creation
210
                :+
211
                (infix-creation :*
212
                                (infix-creation :-
213
                                                (vamp:make-constant :const 1)
214
                                                car)
215
                                (car x))
216
                (infix-creation :* car (cadr x))))
217
             (prod-list left right))))
218
 
219
 (defmethod to-vampir ((obj shift-front) inputs constraints)
220
   "Takes the MCADR entry and moves it upward leaving everything
221
 else fixed. Note that we have to be careful as inputs will have 0es
222
 removed already and hence we cannot count as usual"
223
   (declare (ignore constraints))
224
   (let* ((mcadr (mcadr obj))
225
          (mmcadr (1- mcadr)))
226
     (append (list (nth mmcadr inputs))
227
             (subseq inputs 0 mmcadr)
228
             (subseq inputs mcadr))))
229
 
230
 (defmethod to-vampir ((obj zero-bit) inputs constraints)
231
   (declare (ignore inputs constraints))
232
   (list (vamp:make-constant :const 0)))
233
 
234
 (defmethod to-vampir ((obj one-bit) inputs constraints)
235
   (declare (ignore inputs  constraints))
236
   (list (vamp:make-constant :const 1)))
237
 
238
 (defmethod to-vampir ((obj seqn-add) inputs constraints)
239
   (declare (ignore constraints))
240
   (list (infix-creation :+ (car inputs) (cadr inputs))))
241
 
242
 (defmethod to-vampir ((obj seqn-subtract) inputs constraints)
243
   (declare (ignore constraints))
244
   (list (infix-creation :- (car inputs) (cadr inputs))))
245
 
246
 (defmethod to-vampir ((obj seqn-multiply) inputs constraints)
247
   (declare (ignore constraints))
248
   (list (infix-creation :* (car obj) (cadr obj))))
249
 
250
 (defmethod to-vampir ((obj seqn-divide) inputs constraints)
251
   (declare (ignore constraints))
252
   (list (infix-creation :/ (car inputs) (cadr inputs))))
253
 
254
 (defmethod to-vampir ((obj seqn-nat) inputs constraints)
255
   (declare (ignore constraints))
256
   (list (vamp:make-constant :const (mcadr obj))))
257
 
258
 (defmethod to-vampir ((obj seqn-concat) inputs constraints)
259
   (declare (ignore constraints))
260
   (list (infix-creation :+
261
                         (infix-creation :* (car inputs)
262
                                         (vamp:make-constant
263
                                          :const (expt 2 (mcadr obj))))
264
                         (cadr inputs))))
265
 
266
 (defmethod to-vampir ((obj seqn-decompose) inputs constraints)
267
   (declare (ignore constraints))
268
   (let* ((mcar (mcar obj))
269
          (car (car inputs))
270
          (rng  (vamp:make-application
271
                 :func :range_n
272
                 :arguments (list (vamp:make-constant :const mcar)
273
                                  car)))
274
          (lst  (list (vamp:make-constant :const (1- mcar))
275
                      rng)))
276
     (list (vamp:make-application :func :n_th
277
                                  :arguments lst)
278
           (geb.vampir:combine
279
            (vamp:make-application :func :drop_ith
280
                                   :arguments lst)))))
281
 
282
 (defun range-depth (x)
283
   (let ((cadr (cadr (vamp:arguments x))))
284
     (if (not (typep cadr 'vamp:application))
285
         0
286
         (1+ (range-depth (cadr (vamp:arguments (car (vamp:arguments cadr)))))))))
287
 
288
 (defmethod to-vampir ((obj seqn-eq) inputs constraints)
289
   (declare (ignore constraints))
290
   (list (geb.vampir:isZero (infix-creation :-
291
                                            (car inputs)
292
                                            (cadr inputs)))
293
         (vamp:make-constant :const 0)))
294
 
295
 (defmethod to-vampir ((obj seqn-lt) inputs constraints)
296
   (declare (ignore constraints))
297
   (list (geb.vampir:negative (vamp:make-constant :const (mcar obj))
298
                              (infix-creation :-
299
                                              (car inputs)
300
                                              (cadr inputs)))
301
         (vamp:make-constant :const 0)))
302
 
303
 (defmethod to-vampir ((obj seqn-mod) inputs constraints)
304
   (declare (ignore constraints))
305
   (let ((car (car inputs))
306
         (cadr (cadr inputs)))
307
     (if (const-check car cadr)
308
         (list (vamp:make-constant :const (mod (vamp:const car) (vamp:const cadr))))
309
         (list (geb.vampir:mod-n (vamp:make-constant :const (mcar obj))
310
                                 car cadr)))))
311
 
312
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313
 ;; Helpers
314
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315
 
316
 
317
 ;; happens when the first input is constant
318
 (defun optimize-decompose (obj first-input)
319
   (if (>= (vamp:const first-input) (expt 2 (1- obj)))
320
       (list (vamp:make-constant
321
              :const 1)
322
             (vamp:make-constant
323
              :const (- (vamp:const first-input) (expt 2 (1- obj)))))
324
       (list (vamp:make-constant
325
              :const 0)
326
             first-input)))
327
 
328
 (defun make-opt-plus (value1 value2)
329
   (let ((base (infix-creation :+
330
                               value1
331
                               value2)))
332
     (cond ((typep value1 'vamp:constant)
333
            (if (zerop (vamp:const value1))
334
                value2
335
                base))
336
           ((typep value2 'vamp:constant)
337
            (if (zerop (vamp:const value2))
338
                value1
339
                base))
340
           (t
341
            base))))
342
 
343
 (defun make-opt-minus (value1 value2)
344
   (let ((base (infix-creation :-
345
                               value1
346
                               value2)))
347
     (cond ((typep value2 'vamp:constant)
348
            (if (zerop (vamp:const value2))
349
                value1
350
                base))
351
           (t
352
            base))))
353
 
354
 (defun make-opt-divide (value1 value2)
355
   (let ((base (infix-creation :/
356
                               value1
357
                               value2)))
358
     (cond ((typep value2 'vamp:constant)
359
            (if (= (vamp:const value2) 1)
360
                value1
361
                base))
362
           (t
363
            base))))
364
 
365
 (defun make-opt-times (value1 value2)
366
   (let ((base (infix-creation :*
367
                               value1
368
                               value2))
369
         (zero (vamp:make-constant :const 0)))
370
     (cond ((typep value1 'vamp:constant)
371
            (cond ((zerop (vamp:const value1))
372
                   zero)
373
                  ((= (vamp:const value1) 1)
374
                   value2)
375
                  (t
376
                   base)))
377
           ((typep value2 'vamp:constant)
378
            (cond ((zerop (vamp:const value2))
379
                   zero)
380
                  ((= (vamp:const value2) 1)
381
                   value1)
382
                  (t
383
                   base)))
384
           (t
385
            base))))