Coverage report: /development/source/library/org/datagraph/spocq-shard/src/algebra/operators/diff.lisp

KindCoveredAll%
expression0318 0.0
branch020 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-
2
 
3
 (in-package :org.datagraph.spocq.implementation)
4
 
5
 (:documentation "This file defines the DIFF operator for the 'org.datagraph.spocq' RDF engine."
6
 
7
  (copyright
8
   "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved."))
9
 
10
 
11
 (defmacro spocq.a:|diff| (solution-field1 solution-field2 &rest args &key count end offset start test)
12
   "( ( solutionField solutionField ) solutionField )
13
 A DIFF form combines two solution fields with an optional predicate to be
14
 applied to each compatible, merged solution.
15
 The result is those solutions from the first field which are either incompatible with all
16
 solutions in the second field, or fail the predicate when combined with compatible solutions."
17
 
18
   (declare (ignore count end offset start test))
19
   (apply #'macroexpand-diff solution-field1 solution-field2 args))
20
 
21
 
22
 (defun macroexpand-diff (field1 field2 &rest args &key count end offset start test)
23
   "Compute the combination of the two solution fields with a predicate to be
24
  applied to each compatible, merged solution. Both field forms are evaluated.
25
  The result is those solutions from the first field which are either incompatible with all
26
  solutions in the second field, or fail the predicate when combined with compatible solutions."
27
   (declare (ignore count end offset start))
28
   (setf args (apply #'canonicalize-algebra-arguments args))
29
   (when test
30
     (setf (getf args :test) `(quote ,test)))
31
   `(spocq.e:diff ,field1 ,field2 ,@args))
32
 
33
 
34
 (defgeneric spocq.e:diff (solution-field1 solution-field2 &key end start test)
35
   (:documentation "The DIFF is the combination of those solutions which are either incompatible
36
     or for which the merged solution passes the given test.")
37
 
38
   (:method :before ((base-field t) (offset-field t) &key end start test)
39
     (assert-argument-types spocq.e:diff
40
       (start (or null (integer 0)))
41
       (end (or null (integer 0))))
42
     (incf-stat *algebra-operations*)
43
     (trace-algebra spocq.e:diff base-field offset-field
44
                    :start start :end end :test test))
45
     
46
   (:method ((field1 solution-generator) (field2 solution-generator) &rest args)
47
     (declare (dynamic-extent args))
48
     (apply 'diff-generator field1 field2
49
            args)))
50
 
51
 
52
 (defun diff-generator (base-field-generator offset-field-generator &rest args &key end start test)
53
   (declare (ignore test))
54
   (let* ((base-dimensions (solution-generator-dimensions base-field-generator))
55
          (result-channel (make-channel :name (list 'spocq.a:|diff| (task-id *query*))
56
                                        :dimensions base-dimensions
57
                                        :size (effective-channel-size :start start :end end)
58
                                        :page-length (effective-page-length :start start :end end))))
59
     ;; return the binding function to the combination operator
60
     (make-solution-generator :operator 'spocq.a:|diff|
61
                              :dimensions base-dimensions
62
                              :expression (list #'run-diff-thread result-channel base-field-generator offset-field-generator
63
                                                args)
64
                              :channel result-channel
65
                              :constituents (list base-field-generator offset-field-generator))))
66
 
67
 (defun run-diff-thread (result-channel base-field-generator offset-field-generator args)
68
   (let* ((base-dimensions (solution-generator-dimensions base-field-generator))
69
         (base-channel (solution-generator-channel base-field-generator))
70
         (offset-channel (solution-generator-channel offset-field-generator))
71
         (offset-dimensions (solution-generator-dimensions offset-field-generator))
72
         (base-expression (solution-generator-expression base-field-generator))
73
         (offset-expression (solution-generator-expression offset-field-generator))
74
         (*thread-operations* (cons (list* 'spocq.a:|diff| base-dimensions offset-dimensions
75
                                           args)
76
                                    *thread-operations*)))
77
     (push 'spocq.a:|diff| (channel-name base-channel))
78
     (query-run-in-thread *query* base-expression)
79
     (query-run-in-thread *query* offset-expression)
80
     (setf (channel-size result-channel) (channel-size base-channel)
81
           (channel-page-length result-channel) (channel-page-length base-channel))
82
     (apply #'process-diff result-channel base-channel offset-channel
83
            base-dimensions
84
            offset-dimensions
85
            args)
86
     'spocq.a:|diff|))
87
 
88
 
89
 (defmethod process-diff ((destination array-page-channel)
90
                          (base-source array-page-channel)
91
                          (offset-source array-page-channel)
92
                          base-dimensions offset-dimensions
93
                          &key test (start 0) end)
94
   (declare (list base-dimensions offset-dimensions))
95
   (assert-argument-types process-diff
96
     (base-dimensions list)
97
     (offset-dimensions list))
98
 
99
   (multiple-value-bind (type diff-dimensions base-cache-operator offset-cache-operator predicate collector)
100
                        (compute-diff-operators base-dimensions offset-dimensions test)
101
     (declare (ignore diff-dimensions)
102
              (type (function (array fixnum hash-table) t) base-cache-operator offset-cache-operator)
103
              (type (function (array fixnum array fixnum) boolean) predicate)
104
              (type (function (array fixnum array fixnum) t) collector))
105
     (let* ((result-page-width (channel-page-width destination))
106
            (result-page-length (channel-page-length destination))
107
            (result-page nil)
108
            (result-index result-page-length)
109
            (offset-cache (ecase type
110
                            (:natural (make-term-id-cache :single-thread t))
111
                            (:cross (make-array 32 :fill-pointer 0 :adjustable t))))
112
            (result-count 0))
113
       (assert (= (length base-dimensions) result-page-width) ()
114
               "Channel and operation dimensions do not match: ~a: ~a." destination base-dimensions)
115
       (labels ((base-natural-processor (base-page)
116
                  (dotimes (base-index (array-dimension base-page 0))
117
                    (loop for (offset-page . offset-index) in (funcall base-cache-operator base-page base-index offset-cache)
118
                          if (and predicate (funcall predicate base-page base-index offset-page offset-index))
119
                          do (return)
120
                          finally (collect-solution base-page base-index))))
121
                (offset-natural-processor (offset-page)
122
                  (dotimes (offset-index (array-dimension offset-page 0))
123
                    (funcall offset-cache-operator offset-page offset-index offset-cache)))
124
                (base-cross-processor (base-page)
125
                  (dotimes (base-index (array-dimension base-page 0))
126
                    (loop for offset-page across offset-cache
127
                          unless (dotimes (offset-index (array-dimension offset-page 0) t)
128
                                   (when (and predicate (funcall predicate base-page base-index offset-page offset-index))
129
                                     (return nil)))
130
                          do (return)
131
                          finally (collect-solution base-page base-index))))
132
                (offset-cross-processor (offset-page)
133
                  (vector-push-extend offset-page offset-cache))
134
                (collect-solution (base-page base-index)
135
                  (when (> (incf result-count) start)
136
                    (next-solution-location)
137
                    (funcall collector result-page result-index base-page base-index)
138
                    (when (and end (>= result-count end)) (complete-solutions))))
139
                (next-solution-location ()
140
                  ;; return a page (possible newly created) and the next free location in that page
141
                  (when (>= (incf result-index) result-page-length)
142
                    (when result-page (put-page result-page))
143
                    (setf result-page (new-field-page destination result-page-length result-page-width)
144
                          result-index 0)))
145
                (complete-solutions ()
146
                  (when result-page
147
                    (let ((page-result-count (1+ result-index)))
148
                      (when (< page-result-count result-page-length)
149
                        (setf result-page
150
                              (adjust-page result-page (list page-result-count result-page-width)))))
151
                    (put-field-page destination result-page))
152
                  (put-field-page destination nil)
153
                  (incf-stat *solutions-constructed* result-count)
154
                  (return-from process-diff))
155
                (put-page (page)
156
                  (trace-data process-diff destination base-dimensions (term-value-field page))
157
                  (if page
158
                    (put-field-page destination page)
159
                    (complete-field destination))))
160
         (unless (and (plusp result-page-length) (or (null end) (> end start))) (complete-solutions))
161
         (do-pages (solutions offset-source)
162
           (check-query-status *query*)
163
           (incf-stat *solutions-processed* (array-dimension solutions 0))
164
           (let ((cache-page (copy-page solutions)))
165
             (ecase type
166
               (:natural (offset-natural-processor cache-page))
167
               (:cross (offset-cross-processor cache-page)))))
168
         (do-pages (solutions base-source)
169
           (check-query-status *query*)
170
           (incf-stat *solutions-processed* (array-dimension solutions 0))
171
           (ecase type
172
             (:natural (base-natural-processor solutions))
173
             (:cross (base-cross-processor solutions))))
174
         (complete-solutions)))))
175
       
176
 
177
 (defun compute-diff-operators (base-dimensions offset-dimensions test)
178
   (let ((result-dimensions (union-dimensions base-dimensions offset-dimensions)))
179
     (if (intersection base-dimensions offset-dimensions)
180
       (values :natural result-dimensions
181
               (compute-read-cache-op base-dimensions offset-dimensions)
182
               (compute-write-cache-op offset-dimensions base-dimensions)
183
               (compute-binary-predicate test base-dimensions offset-dimensions)
184
               (compute-unary-collector base-dimensions base-dimensions))
185
       (values :cross result-dimensions nil nil
186
               (compute-binary-predicate test base-dimensions offset-dimensions)
187
               (compute-unary-collector base-dimensions base-dimensions)))))