Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/ssl/ssl-runtime.lisp

KindCoveredAll%
expression30414 7.2
branch038 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 "run-time implementation for the SSL machine."
6
  "This implements the internal state functions and the primitive word functions which operator on the code and
7
   stack state to effect script execution.
8
 
9
   The run-time state comprises three objects
10
   - sslr:*stack* :
11
     the stack of evaluated values staged for combination as function arguments
12
     repreented as a list
13
   - sslr:*code*
14
     the sequence of expressions and words (functions) to be executed
15
     represented as a list of (possibly nested) values
16
   - sslr:*environment*
17
     the current evaluation environment binds symbols to functions an values
18
     represented as an association list
19
 
20
   each evaluation rebinds selected state components dynamically and repeats operations from
21
   the code sequence until the sequence is exhausted, at which point the evaluation is complete and control
22
   returns to the caller. the stack then retains any any result(s). the modes execution interfaces exist
23
     sslr:call : contrains the argument to be a function; calls the function without rebinding
24
     sslr:evaluate : constrains the argument to be a list; rebinds just the code sequence
25
     sslr:run : accepts and rebinds all state components; given a code designator, retrieve and/or compile
26
       it as required.
27
 
28
   in general, any object is treated as first-class, that is, permitted in code, on the stack - and as such,
29
   passed and returned, as well as bound in the environment.
30
   at the same time, particular object classes involve special handling
31
   boolean : logical truth distinguishes not only t and nil, but 0, "", unbound variable markers and
32
     empty solution fields as false (see sslr:true)
33
   word : a specialized generic function type captures the intended result arity from the definition in
34
     order to transfer the results to the run-time stack (in the ame order as if appearing in code)
35
   solution-field : handled as the argument to boolean tests and to iteration control operators
36
 
37
   the implementation resides on three levels
38
   %%- operators accept values and return them
39
   %- operators work the the %%- level operators to manipulate the three state objects
40
   word operators again accept and returns values. the arguments are staged by the %- operators from
41
     run-time state and results are placed back into the run-time state by the invoking %- opeator uon return
42
    ")
43
 ;;; (load (compile-file #p"LIBRARY:org;datagraph;spocq;src;core;ssl;package.lisp"))
44
 ;;; (load (compile-file "LIBRARY:org;datagraph;spocq;src;core;ssl;ssl-runtime.lisp"))
45
 
46
 (defparameter *trace-ssl* nil)
47
 (defmacro trace-ssl (operator &rest arguments)
48
   `(trace-when *trace-ssl* "~&ssl:~a[~a] : ~@{~a: ~s~^ ~}~%"
49
                ',operator (bt:thread-name (bt:current-thread))
50
                ,@(loop for value in arguments
51
                    collect (list 'quote value)
52
                    collect value)))
53
 
54
 
55
 
56
 (eval-when (:compile-toplevel :load-toplevel :execute)
57
   ;; required for word function compilation
58
 
59
   (defparameter sslr:*class.function-signature* 'sslr:function-signature)
60
 
61
   (defclass sslr:function-signature ()
62
     ((required-parameters
63
      :initform nil :initarg :required-parameters
64
      :reader sslr:function-required-parameters)
65
     (required-parameter-count
66
      :initform 0
67
      :reader sslr:function-required-parameter-count
68
      :writer setf-function-required-parameter-count)
69
     (keyword-parameters
70
      :initform nil :initarg :keyword-parameters
71
      :reader sslr:function-keyword-parameters)
72
     (keyword-parameter-count
73
      :initform 0
74
      :reader sslr:function-keyword-parameter-count
75
      :writer setf-function-keyword-parameter-count)
76
     (values
77
      :initform nil :initarg :values
78
      :reader sslr:function-values)
79
     (value-count
80
      :initform 0
81
      :reader sslr:function-value-count
82
      :writer setf-function-value-count)
83
     (code-parameters
84
      :initform nil :initarg :code-parameters
85
      :reader sslr:function-code-parameters)
86
     (code-parameter-count
87
      :initform 0
88
      :reader sslr:function-code-parameter-count
89
      :writer setf-function-code-parameter-count)))
90
 
91
   (defmethod initialize-instance ((instance sslr:function-signature)
92
                                   &key (required-parameters nil rp-s)
93
                                   (keyword-parameters nil kp-s)
94
                                   (values nil v-s)
95
                                   (code-parameters nil cp-s))
96
     (call-next-method)
97
     (when rp-s (setf-function-required-parameter-count (length required-parameters) instance))
98
     (when kp-s (setf-function-keyword-parameter-count (length keyword-parameters) instance))
99
     (when v-s (setf-function-value-count (length values) instance))
100
     (when cp-s (setf-function-code-parameter-count (length code-parameters) instance)))
101
 
102
   (defun sslr:make-function-signature (&rest args)
103
     (declare (dynamic-extent args))
104
     (apply #'make-instance sslr:*class.function-signature* args))
105
 
106
   (defmethod make-load-form ((function-signature sslr:function-signature) &optional environment)
107
     (make-load-form-saving-slots function-signature :environment environment))
108
   )
109
 
110
 (defclass sslr:function (standard-generic-function)
111
   ((signature
112
     :reader sslr:function-signature
113
     :writer sslr::setf-function-signature))
114
   (:metaclass c2mop:funcallable-standard-class))
115
 
116
 (defclass sslr:continuation (c2mop:funcallable-standard-object)
117
   ()
118
   (:metaclass c2mop:funcallable-standard-class))
119
 
120
 (defgeneric sslr:function-designator-p (object)
121
   (:method ((object symbol)) (not (null object)))
122
   (:method ((object t)) nil))
123
 
124
 (deftype sslr:function-designator () '(satisfies sslr:function-designator-p))
125
 
126
 (defun check-task-status (&optional (task ssl:*task*))
127
   (when task
128
     (cond ((eq (task-state task) :terminate)
129
            (error 'spocq.e::abort-error :query task :condition nil :expression nil))
130
           ((task-quota-exceeded-p task)
131
            (error 'spocq.e::timeout-error :query task :condition nil :expression nil))
132
           ((task-active-p task)
133
            (not (eq *run-state* :terminate))))))
134
 
135
 #+(or)
136
 (progn
137
   (defun test-rebinding (&optional (count 1000000))
138
     (dotimes (i count) (call-with-spocq-state #'list :stack sslr:*stack*)))
139
   (time (test-rebinding)))
140
 
141
 
142
 ;;; runtime internal
143
 
144
 (defun sslr:bind (symbol value)
145
   (setq sslr:*environment* (acons symbol value sslr:*environment*))
146
   value)
147
 
148
 (defun sslr:boundp (symbol)
149
   (when (assoc symbol sslr:*environment*)
150
     t))
151
 
152
 (defun sslr:closure (code)
153
   (let ((environment sslr:*environment*)
154
         (stack sslr:*stack*))
155
     (flet ((closure () (sslr::execute stack code environment)))
156
       #'closure)))
157
 
158
 (defun sslr:code ()
159
   sslr:*code*)
160
 
161
 (defun sslr:continuation ()
162
   (let ((stack sslr:*stack*)
163
         (code sslr:*code*)
164
         (environment sslr:*environment*))
165
     (flet ((continuation ()
166
              (setq sslr:*stack* stack)
167
              (setq sslr:*code* code)
168
              (setq sslr:*environment* environment)
169
              (values)))
170
       #'continuation)))
171
 
172
 (defun sslr:environment ()
173
   sslr:*environment*)
174
 
175
 (defun sslr:first ()
176
   (assert sslr:*stack* () (error "empty stack: ~s" (bt:current-thread)))
177
   (first sslr:*stack*))
178
 
179
 (defun (setf sslr:first) (value)
180
   (assert sslr:*stack* () (error "empty stack: ~s" (bt:current-thread)))
181
   (setf (first sslr:*stack*) value))
182
 
183
 (defun sslr:pop ()
184
   (assert sslr:*stack* () (error "empty stack: ~s" (bt:current-thread)))
185
   (pop sslr:*stack*))
186
 
187
 (defun sslr:pop-code ()
188
   (assert sslr:*code* () (error "empty code: ~s" (bt:current-thread)))
189
   (pop sslr:*code*))
190
 
191
 (defun sslr:push (value)
192
   (push value sslr:*stack*)
193
   value)
194
 
195
 (defun sslr:push-code (value)
196
   (push value sslr:*code*)
197
   value)
198
 
199
 (defun sslr:rest ()
200
   (assert sslr:*stack* () (error "empty stack: ~s" (bt:current-thread)))
201
   (rest sslr:*stack*))
202
 
203
 (defun sslr:set (symbol value)
204
   (let* ((binding (assoc symbol sslr:*environment*)))
205
     (if binding
206
       (setf (rest binding) value)
207
       (setq sslr:*environment* (acons symbol value sslr:*environment*)))
208
     value))
209
 
210
 (defun sslr:stack ()
211
   sslr:*stack*)
212
 
213
 (defgeneric sslr:function-code-parameter-count (function)
214
   (:method ((function sslr:function))
215
     (sslr:function-code-parameter-count (sslr:function-signature function))))
216
 
217
 (defgeneric sslr:function-required-parameter-count (function)
218
   (:method ((function sslr:function))
219
     (sslr:function-required-parameter-count (sslr:function-signature function))))
220
 
221
 (defgeneric sslr:function-keyword-parameter-count (function)
222
   (:method ((function sslr:function))
223
     (sslr:function-keyword-parameter-count (sslr:function-signature function))))
224
 
225
 (defgeneric sslr:function-value-count (function)
226
   (:method ((function sslr:function))
227
     (sslr:function-value-count (sslr:function-signature function))))
228
 
229
 (defgeneric sslr:function-keyword-parameter-count (function)
230
   (:method ((function sslr:function))
231
     (sslr:function-keyword-parameter-count (sslr:function-signature function))))
232
 
233
 (defgeneric sslr:function-keyword-parameters (function)
234
   (:method ((function sslr:function))
235
     (sslr:function-keyword-parameters (sslr:function-signature function))))
236
 
237
 
238
 (defun sslr:symbol-value (symbol)
239
   (let ((binding (assoc symbol sslr:*environment*)))
240
     (cond (binding
241
            (rest binding))
242
           ((fboundp symbol)
243
            (symbol-function symbol))
244
           ((boundp symbol)
245
            (symbol-value symbol))
246
           (t
247
            (error 'unbound-variable :name symbol)))))
248
 
249
 (defgeneric sslr:function-definition (object)
250
   (:method ((designator symbol))
251
     (let ((function (sslr:symbol-value designator)))
252
       (assert (typep function 'function) ()
253
               "invalid function binding: ~s: ~s" designator function)
254
       function)))
255
 
256
 (defgeneric sslr:eval (value)
257
   (:method ((value symbol))
258
     ;; dereference the symbols in the current environment.
259
     ;; push an immediate, but execute a function 
260
     (if (fboundp value)
261
         (sslr:call value)
262
         (let ((result (sslr:symbol-value value)))
263
           (if (functionp result)
264
               (sslr:call result)
265
               (sslr:push result))))
266
     (values))
267
   (:method ((value cons))
268
     ;; push a quoted form, run code
269
     (destructuring-bind (op &optional arg . rest) value
270
       (declare (ignore rest))
271
       (case op
272
         (quote
273
          (sslr:push arg))
274
         (function
275
          (sslr:push (sslr:function-definition arg)))
276
         ;; otherwise treat it as a code sequence:
277
         ;; execute and return values
278
         (t
279
          (sslr:run value))))
280
     (values))
281
   (:method ((value function))
282
     (sslr:call value)
283
     (values))
284
   (:method ((value t))
285
     ;; eveything else is immediate
286
     (sslr:push value)
287
     (values)))
288
 
289
 
290
 (defun sslr:run (sslr:*code*)
291
   "Follow code instructions to operate on the stack"
292
   (loop (unless sslr:*code* (return))
293
         (trace-ssl run sslr:*stack* sslr:*code* sslr:*environment*)
294
         (sslr:eval (sslr:pop-code)))
295
   ;; once the code is complete, return no values, but leave the state intact
296
   (trace-ssl run.complete sslr:*stack* sslr:*code*  sslr:*environment*)
297
   (values ))
298
 
299
 
300
 (defgeneric sslr:call (function)
301
   (:documentation
302
    "given a function, apply it to the arguments on the stack.
303
     marshall its arguments, invoke it, enter its results on the stack and continue.
304
     given a code vector, push the code state and execute it with the current stack and environment, then return
305
     all effects are side-effects on the stack/environment - no value are returned.")
306
 
307
   (:method ((function sslr:function))
308
     "Given a word, determine the argument count, extract _and_ evaluate the arguments
309
      apply the function to the argument list
310
      collect and push the results"
311
     (let* ((argument-count (sslr:function-required-parameter-count function))
312
            (value-count (sslr:function-value-count function))
313
            (code-count (sslr:function-code-parameter-count function))
314
            (keywords-found ())
315
            (keywords (sslr:function-keyword-parameters function))
316
            (argument-list ())
317
            (environment sslr:*environment*))
318
       #+(or)
319
       (loop while sslr:*stack*
320
         for (first . rest) = sslr:*stack*
321
         while (and rest (keywordp (first rest)))
322
         for (keyword . rest-rest) = rest
323
         do (progn (unless (member keyword keywords)
324
                     (error "Invalid keyword argument (~s): ~s not among ~s"
325
                            function keyword keywords))
326
              (setq sslr:*stack* rest-rest)
327
              (unless (member keyword keywords-found)
328
                (setf argument-list (list* keyword first argument-list)))))
329
       (loop while sslr:*stack*
330
         for (first . rest) = sslr:*stack*
331
         while (and rest (keywordp (first rest)))
332
         for (keyword . rest-rest) = rest
333
         do (progn (setq sslr:*stack* rest-rest)
334
              (cond ((member keyword keywords-found) ) ; already bound: do nothing
335
                    ((member keyword keywords) ; bind native call argument
336
                     (setf argument-list (list* keyword first argument-list)))
337
                    (t ; bind dynamic environment argument
338
                     ;; (error "Invalid keyword argument (~s): ~s not among ~s" function keyword keywords))
339
                     (setf environment (acons (symbol-variable keyword) first environment))))))
340
       (setf argument-list (nconc (loop for i below code-count collect (sslr:pop-code)) argument-list))
341
       ;; present the fixed arguments in the order they appear in code --
342
       ;; which is reversed
343
       (loop for i below argument-count do (push (sslr:pop) argument-list))
344
       (trace-ssl call.apply function argument-list
345
                  (ldiff sslr:*environment* environment))
346
       (let* ((sslr:*environment* environment)
347
              (result (multiple-value-list (apply function argument-list))))
348
         (trace-ssl call.return function result)
349
         (unless (or (null value-count) (= (length result) value-count)) ()
350
           (error "Invalid value count (~s): expected ~s != ~s"
351
                  function value-count (length result)))
352
         (loop for i from 0
353
           for value in result
354
           do (sslr:push value))))
355
     (values))
356
 
357
   (:method ((function function))
358
     ;; for continuations and interpreted operators -- without additional side-effects
359
     (let ((result (multiple-value-list (funcall function))))
360
       (loop for i from 0
361
           for value in result
362
           do (sslr:push value)))
363
     (values))
364
 
365
   (:method ((name symbol))
366
     (sslr:call (sslr:function-definition name))))
367
 
368
 
369
 (defun sslr:execute (sslr:*stack* code  sslr:*environment*)
370
   (sslr:run code))
371
 
372
 (defgeneric sslr:true (value)
373
   (:method ((value null)) nil)
374
   (:method ((value (eql t))) t)
375
   (:method ((value number)) (not (zerop value)))
376
   (:method ((value string)) (plusp (length value)))
377
   (:method ((value spocq:boolean))
378
     (spocq:boolean-value value))
379
   (:method ((value spocq:unbound-variable)) nil)
380
   (:method ((value solution-generator))
381
     "Given a solution field, an empty field is false.
382
      Otherwise, test the all values in the first solution."
383
     (let ((dimensions (abstract-field-generator-dimensions value)))
384
       (flet ((test-first-solution ()
385
                (return-from sslr:true
386
                  (loop for dimension in dimensions
387
                        unless (and (sslr:boundp dimension)
388
                                    (sslr:true (sslr:symbol-value dimension)))
389
                        return nil
390
                        finally (return t)))))
391
         (declare (dynamic-extent #'test-first-solution))
392
         (sslr:map-field #'test-first-solution value nil)
393
         nil))))
394
 
395
 (defgeneric sslr:map-field (operator projection code)
396
   (:documentation "Iterate over a solution field. For each solution, extend the
397
    script environment for all _bound_ dimensions and execute the code sequence
398
    in the extended environment. If any execution returns true, terminate the iteration
399
    and return false, otherwise upon completion, true.")
400
   (:argument-precedence-order projection code operator)
401
   
402
   (:method (operator (projection solution-generator) (code list))
403
     (let* ((channel (abstract-field-generator-channel projection))
404
           (dimensions (abstract-field-generator-dimensions projection))
405
           (field-width (length dimensions))
406
           (initial-stack sslr:*stack*)
407
           (initial-environment sslr:*environment*))
408
       (do-pages (page channel)
409
         (let* ((page-length (array-dimension page 0))
410
                (page-width (array-dimension page 1)))
411
           (assert (= field-width page-width) ()
412
                   "Invalid page width for field: ~s: ~s != ~s" dimensions field-width page-width)
413
           (loop for solution-index from 0 below page-length
414
                 do (progn (setq sslr:*stack* initial-stack)
415
                           (setq sslr:*environment* initial-environment)
416
                           (loop for dimension in dimensions
417
                                 for term-index from 0 below page-width
418
                                 for term-number = (aref page solution-index term-index)
419
                                 unless (= +null-term-id+ term-number)
420
                                 do (sslr:bind dimension (rlmdb:term-number-value term-number)))
421
                           (sslr::run code)
422
                           (funcall operator)))))))
423
 
424
   (:method (operator (projection cons) (code list))
425
     (let ((dimensions (first projection))
426
           (field-values (rest projection)))
427
       (loop with initial-stack = sslr:*stack*
428
             with initial-environment = sslr:*environment*
429
             for solution in field-values
430
             do (progn (setq sslr:*stack* initial-stack)
431
                       (setq sslr:*environment* initial-environment)
432
                       (loop for dimension in dimensions
433
                             for term in solution
434
                             unless (spocq:unbound-variable-p term)
435
                             do (sslr:bind dimension term))
436
                       (sslr::run code)
437
                       (funcall operator))))))
438
 
439
 
440
 (defmacro sslr:do-field ((field form) &body body)
441
   (let ((op (gensym "map-field")))
442
     `(block nil
443
        (flet ((,op () ,@body))
444
          (declare (dynamic-extent #',op))
445
          (sslr:map-field #',op ,field ,form)))))
446
 
447
 #+digitool (setf (ccl:assq 'sslr:do-field ccl:*fred-special-indent-alist*) 1)
448
 
449
 #|
450
 (defgeneric sslr:eval (value)
451
   (:method ((value symbol))
452
     ;; symbols dereference in the current environment
453
     (sslr:symbol-value value))
454
   (:method ((value cons))
455
     ;; forms are evaluated
456
     (destructuring-bind (first . rest) value
457
       (case first
458
         (quote (first rest))
459
         ;; otherwise treat it as a code sequence:
460
         ;; execute and return values
461
         (t
462
          (sslr:run value)))))
463
   (:method ((value t))
464
     ;; eveything else is immediate
465
      value))
466
 
467
 (defun sslr:run (sslr:*code*)
468
   "Follow code instructions to operate on the stack"
469
   (loop (unless sslr:*code* (return))
470
         (trace-ssl sslr:run sslr:*stack* sslr:*code*  sslr:*environment*)
471
         (let ((value (sslr:pop-code)))
472
           (typecase value
473
             (cons
474
              (destructuring-bind (first . rest) value
475
                (case first
476
                  (quote (sslr:push rest))
477
                  ;; otherwise treat it as a code sequence:
478
                  ;; execute and return values
479
                  (t
480
                   (sslr:run value)))))
481
             ((symbol (not null))
482
              (typecase (setf value (sslr:symbol-value value))
483
                (function (sslr:call value))
484
                (t (sslr:push value))))
485
             (t
486
              (sslr:push value)))))
487
       
488
   ;; once the code is complete, return no values, but leave the state intact
489
   (values ))
490
 |#