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

KindCoveredAll%
expression136251 54.2
branch22100.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.poly.trans)
2
 
3
 (defmethod to-circuit ((morphism <poly>) name)
4
   "Turns a POLY term into a Vamp-IR Gate with the given name"
5
   (circuit-gen morphism name))
6
 
7
 (defmethod to-circuit ((morphism integer) name)
8
   "Turns a POLY term into a Vamp-IR Gate with the given name, by just
9
 returning the value"
10
   (circuit-gen morphism name))
11
 
12
 (defun circuit-gen (morphism name)
13
   "Turns a POLY term into a Vamp-IR Gate with the given name"
14
   (labels ((make-alias (name morphism)
15
              (let ((wire (vamp:make-wire :var :x)))
16
                (multiple-value-bind (results lets) (to-vampir morphism wire nil)
17
                  (vamp:make-alias :name name
18
                                   :inputs (list wire)
19
                                   :body (reverse (cons results lets)))))))
20
     (multiple-value-bind (morphism map) (ext:common-sub-expressions morphism)
21
       (append (mapcar
22
                (lambda (x)
23
                  (let ((term (car x))
24
                        (name (cdr x)))
25
                    (make-alias name term)))
26
                (fset:convert 'list map))
27
               (list (make-alias name morphism))))))
28
 
29
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30
 ;; Poly to Vampir Implementation
31
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32
 
33
 ;; we could get exhaustion here over poly, with
34
 ;; subclass-responsibility implemented for any value that does not
35
 ;; match.
36
 ;;
37
 ;; See geb:to-poly
38
 ;;
39
 ;; to see what that style of code is like as apposed to this.
40
 (defmethod to-vampir ((obj <poly>) value let-vars)
41
   (declare (ignore value let-vars))
42
   (subclass-responsibility obj))
43
 
44
 (-> direct-fields-to-list-vampir (geb.mixins:direct-pointwise-mixin) list)
45
 (defun direct-fields-to-list (obj)
46
   (mapcar #'cdr (geb.mixins:to-pointwise-list obj)))
47
 
48
 ;; all of this is likely wrong, as we are taking morph-isms which
49
 ;; evaluate to themselves but I'm unsure of how this works on an input
50
 ;; level
51
 
52
 (defmethod to-vampir ((obj integer) value let-vars)
53
   "Numbers act like a constant function, ignoring input"
54
   (declare (ignore value))
55
   (values
56
    (vamp:make-constant :const obj)
57
    let-vars))
58
 
59
 (defmethod to-vampir ((obj ident) value let-vars)
60
   "Identity acts as the identity function"
61
   (values value let-vars))
62
 
63
 (defun infix-creation (symbol obj value let-vars)
64
   (mvlet* ((lhs let-vars (to-vampir (mcar obj)  value let-vars))
65
            (rhs let-vars (to-vampir (mcadr obj) value let-vars)))
66
     (values (vamp:make-infix :op symbol :lhs lhs :rhs rhs)
67
             let-vars)))
68
 
69
 (defun infix (op lhs rhs)
70
   (vamp:make-infix :op op :lhs lhs :rhs rhs))
71
 
72
 (defmethod to-vampir ((obj +) value let-vars)
73
   "Propagates the value and adds them"
74
   (infix-creation :+ obj value let-vars))
75
 
76
 (defmethod to-vampir ((obj *) value let-vars)
77
   "Propagates the value and times them"
78
   (infix-creation :* obj value let-vars))
79
 
80
 (defmethod to-vampir ((obj -) value let-vars)
81
   "Propagates the value and subtracts them"
82
   (infix-creation :- obj value let-vars))
83
 
84
 (defmethod to-vampir ((obj /) value let-vars)
85
   ;; this should error
86
   (infix-creation :/ obj value let-vars))
87
 
88
 (defmethod to-vampir ((obj compose) value let-vars)
89
   (mvlet* ((fst let-vars (to-vampir (mcadr obj) value let-vars))
90
            (fst-wire (vamp:make-wire :var (gensym "C")))
91
            (fst-var  (vamp:make-bind :names (list fst-wire) :value fst)))
92
     (to-vampir (mcar obj) fst-wire (cons fst-var let-vars))))
93
 
94
 (defmethod to-vampir ((obj if-zero) value let-vars)
95
   "The PREDICATE that comes in must be 1 or 0 for the formula to work out."
96
   ;; need to optimize this, we are computing predicate twice which is
97
   ;; very bad
98
   (multiple-value-bind (predicate then else) obj
99
     (mvlet* ((predicate let-vars (to-vampir predicate value let-vars))
100
              (then      let-vars (to-vampir then value let-vars))
101
              (else      let-vars (to-vampir else value let-vars)))
102
       ;; bool × then + (1 - bool) × else
103
       (let* ((pred      (vamp:make-wire :var (gensym "ZP")))
104
              (pred-bind (vamp:make-bind :names (list pred)
105
                                         :value predicate)))
106
         (values
107
          (infix :+
108
                 (infix :* pred then)
109
                 (infix :*
110
                        (infix :- (vamp:make-constant :const 1) pred)
111
                        else))
112
          (cons pred-bind let-vars))))))
113
 
114
 (defmethod to-vampir ((obj mod) value let-vars)
115
   (mvlet* ((car  let-vars (to-vampir (mcar obj)  value let-vars))
116
            (cadr let-vars (to-vampir (mcadr obj) value let-vars)))
117
     (values (geb.vampir:mod32 car cadr)
118
             let-vars)))
119
 
120
 (defmethod to-vampir ((obj if-lt) value let-vars)
121
   (mvlet* ((car  let-vars (to-vampir (mcar obj)  value let-vars))
122
            (cadr let-vars (to-vampir (mcadr obj) value let-vars))
123
            (then let-vars (to-vampir (then obj)  value let-vars))
124
            (else let-vars (to-vampir (else obj)  value let-vars)))
125
     (values (geb.vampir:pwless32 car cadr then else)
126
             let-vars)))
127
 
128
 (defmethod to-vampir ((obj geb.extension.spec:common-sub-expression) value let-vars)
129
   (if (typep (obj obj) 'ident)
130
       (to-vampir (obj obj) value let-vars)
131
       ;; functions are only 1 argument big ☹
132
       (values (vamp:make-application :func (name obj)
133
                                      :arguments (list value))
134
               let-vars)))
135
 ����