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

KindCoveredAll%
expression125138 90.6
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.bitc.trans)
2
 
3
 (defmethod to-circuit ((morphism <bitc>) name)
4
   "Turns a BITC term into a Vamp-IR Gate with the given name"
5
   (let* ((wire-count (dom morphism))
6
          (wires (loop for i from 1 to wire-count
7
                       collect (vamp:make-wire :var (intern (format nil "x~a" i)
8
                                                            :keyword)))))
9
     (list
10
      (vamp:make-alias :name name
11
                       :inputs wires
12
                       :body (list (vamp:make-tuples :wires (to-vampir morphism wires nil)))))))
13
 
14
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
 ;; Bits to Vampir Implementation
16
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
17
 
18
 (defmethod to-vampir ((obj <bitc>) values constraints)
19
   (declare (ignore constraints))
20
   (declare (ignore values))
21
   (subclass-responsibility obj))
22
 
23
 (defun infix-creation (symbol value1 value2)
24
   (vamp:make-infix :op symbol
25
                    :lhs value1
26
                    :rhs value2))
27
 
28
 (defmethod to-vampir ((obj compose) values constraints)
29
   (to-vampir (mcar obj)
30
              (to-vampir (mcadr obj) values constraints)
31
              constraints))
32
 
33
 (defmethod to-vampir ((obj fork) values constraints)
34
   "Copy input n intput bits into 2*n output bits"
35
   (declare (ignore constraints))
36
   (append values values))
37
 
38
 (defmethod to-vampir ((obj parallel) values constraints)
39
   "Take n + m bits, execute car the n bits and cadr on the m bits and
40
   concat the results from car and cadr"
41
   (let* ((car  (mcar obj))
42
          (cadr (mcadr obj))
43
          (cx   (dom car))
44
          (inp1 (subseq values 0 cx))
45
          (inp2 (subseq values cx)))
46
     (append (to-vampir car inp1 constraints)
47
             (to-vampir cadr inp2 constraints))))
48
 
49
 (defmethod to-vampir ((obj swap) values constraints)
50
   "Turn n + m bits into m + n bits by swapping"
51
   (declare (ignore constraints))
52
   (let ((n (mcar obj)))
53
     (append (subseq values n)
54
             (subseq values 0 n))))
55
 
56
 (defmethod to-vampir ((obj one) values constraints)
57
   "Produce a bitvector of length 1 containing 1"
58
   (declare (ignore values constraints))
59
   (list (vamp:make-constant :const 1)))
60
 
61
 (defmethod to-vampir ((obj zero) values constraints)
62
   "Produce a bitvector of length 1 containing 0"
63
   (declare (ignore values constraints))
64
   (list (vamp:make-constant :const 0)))
65
 
66
 (defmethod to-vampir ((obj ident) values constraints)
67
   (declare (ignore constraints))
68
   "turn n bits into n bits by doing nothing"
69
   values)
70
 
71
 (defmethod to-vampir ((obj drop) values constraints)
72
   "turn n bits into an empty bitvector"
73
   (declare (ignore values constraints))
74
   nil)
75
 
76
 (defmethod to-vampir ((obj branch) values constraints)
77
   "Look at the first bit.
78
 
79
   If its 0, run f on the remaining bits.
80
 
81
   If its 1, run g on the remaining bits."
82
   (let ((x (car values))
83
         (xs (cdr values))
84
         (f (mcar obj))
85
         (g (mcadr obj))
86
         (one (vamp:make-constant :const 1)))
87
     (mapcar (lambda (f-elem g-elem)
88
               (infix-creation :+
89
                               (infix-creation :* (infix-creation :- one x) f-elem)
90
                               (infix-creation :* x g-elem)))
91
             (to-vampir f xs constraints)
92
             (to-vampir g xs constraints))))