File: cx-gc.lisp

package info (click to toggle)
cl-contextl 1%3A20160313.git5894fba-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 332 kB
  • sloc: lisp: 3,146; makefile: 2
file content (78 lines) | stat: -rw-r--r-- 4,247 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
(in-package :contextl)

#-cx-disable-layer-gc
(progn
  (defun all-layer-contexts ()
    (let ((result '()))
      (labels ((collect (layer-context)
                 (declare (type layer-context layer-context))
                 (when (member layer-context result :test #'eq)
                   (return-from collect))
                 (push layer-context result)
                 (loop for (nil child) on (layer-context-children/ensure-active layer-context) by #'cddr do
                       (collect child))
                 (loop for (nil child) on (layer-context-children/ensure-inactive layer-context) by #'cddr do
                       (collect child))))
        (when (boundp '*root-context*)
          (collect (symbol-value '*root-context*))
          result))))

  (defun clear-layer-active-caches (test &optional (all-layer-contexts (all-layer-contexts)))
    (loop for layer-context in all-layer-contexts do
          (with-lock ((layer-context-lock layer-context))
            (setf (layer-context-children/ensure-active layer-context)
                  (loop for (key child) on (layer-context-children/ensure-active layer-context) by #'cddr
                        unless (funcall test key)
                        nconc (list key child))))))

  (defun clear-layer-inactive-caches (test &optional (all-layer-contexts (all-layer-contexts)))
    (loop for layer-context in all-layer-contexts do
          (with-lock ((layer-context-lock layer-context))
            (setf (layer-context-children/ensure-inactive layer-context)
                  (loop for (key child) on (layer-context-children/ensure-inactive layer-context) by #'cddr
                        unless (funcall test key)
                        nconc (list key child))))))

  (defgeneric clear-layer-context-caches (layer)
    (:method ((layer symbol)) (clear-layer-context-caches (find-layer-class layer)))
    (:method ((layer standard-layer-object)) (clear-layer-context-caches (find-layer-class layer)))
    (:method ((layer-class cl:class))
     (let ((all-layer-contexts (all-layer-contexts))
           (test (lambda (key) (subtypep (find-layer-class key) layer-class))))
       (clear-layer-active-caches test all-layer-contexts)
       (clear-layer-inactive-caches test all-layer-contexts))))

  (defun clear-layer-caches ()
    (let ((all-layer-contexts (all-layer-contexts)))
      (loop for layer-context in all-layer-contexts do
            (with-lock ((layer-context-lock layer-context))
              (setf (layer-context-children/ensure-active layer-context) '()
                    (layer-context-children/ensure-inactive layer-context) '())))))

  (defmethod reinitialize-instance :after
    ((class standard-layer-class) &rest initargs)
    (declare (ignore initargs))
    (clear-layer-context-caches class))

  (defgeneric clear-activation-method-caches (gf method)
    (:method (gf method) (declare (ignore gf method)) nil)
    (:method ((gf (eql (lf-definer-name 'adjoin-layer-using-class))) method)
     (let ((layer-specializer (first (layered-method-specializers method))))
       (if (typep layer-specializer 'eql-specializer)
         (let ((eql-specializer-object (eql-specializer-object layer-specializer)))
           (clear-layer-active-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object))))
         (clear-layer-active-caches (lambda (key) (typep (find-layer-class key) layer-specializer))))))
    (:method ((gf (eql (lf-definer-name 'remove-layer-using-class))) method)
     (let ((layer-specializer (first (layered-method-specializers method))))
       (if (typep layer-specializer 'eql-specializer)
         (let ((eql-specializer-object (eql-specializer-object layer-specializer)))
           (clear-layer-inactive-caches (lambda (key) (eql (find-layer-class key) eql-specializer-object))))
         (clear-layer-inactive-caches (lambda (key) (typep (find-layer-class key) layer-specializer)))))))

  (defmethod add-method :after
    ((gf layered-function) (method layered-method))
    (clear-activation-method-caches (generic-function-name gf) method))

  (defmethod remove-method :after
    ((gf layered-function) (method layered-method))
    (clear-activation-method-caches (generic-function-name gf) method)))