Commit 904d4d24 authored by Dave Cooper's avatar Dave Cooper

added some bordeaux-threads locks in vanilla-mixin.lisp and sequence.lisp

parent 3e37c859
......@@ -3,7 +3,7 @@
(asdf:defsystem #:base :description
"The Gendl\" Base Core Kernel Engine" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20150330" :depends-on nil
:serial t :version "20150330" :depends-on (:bordeaux-threads)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
(:bordeaux-threads)
\ No newline at end of file
......@@ -159,7 +159,9 @@ with <tt>:sequence (:size ...))</tt>), elements can be surgically inserted and d
:child-types)
:computed-slots
((ht (progn (the :child-types)
((lock (bt:make-lock))
(ht (progn (the :child-types)
;;
;; FLAG -- consider increasing initial size or rehash-size
;;
......@@ -196,12 +198,15 @@ with <tt>:sequence (:size ...))</tt>), elements can be surgically inserted and d
(last (the (:get-member (first (last (the :element-index-list)))))))
:functions
(("Void. Resets the variable sequence to its default list of indices (i.e. clears out any inserted or deleted elements and
((exists? (index) (gethash index (the ht)))
("Void. Resets the variable sequence to its default list of indices (i.e. clears out any inserted or deleted elements and
re-evaluates the expression to compute the original list of indices)"
reset!
()
(the (restore-slot-default! :element-index-list))
(the (restore-slot-default! :ht)))
(progn ;;bt:with-lock-held ((the lock))
(the (restore-slot-default! :element-index-list))
(the (restore-slot-default! :ht))))
(instantiated-indices () (remove-if-not #'(lambda(index)
(second (multiple-value-list (gethash index (the :ht)))))
......@@ -232,10 +237,11 @@ re-evaluates the expression to compute the original list of indices)"
:arguments (index \"Integer, Symbol, or other object matching with <tt>eql</tt>. The identifier used when the element was initialized or inserted.\")"
delete!
(index)
(the (:set-slot! :ht (the :ht)))
(remhash index (the ht))
(the (:modify-attribute! :element-index-list
(remove index (the :element-index-list)))))
(bt:with-lock-held ((the lock))
(the (:set-slot! :ht (the :ht)))
(remhash index (the ht))
(the (:modify-attribute! :element-index-list
(remove index (the :element-index-list))))))
(activate! (index) (the (:insert! index)))
......@@ -247,15 +253,15 @@ re-evaluates the expression to compute the original list of indices)"
insert!
(index)
(multiple-value-bind (value found?)
(gethash index (the ht))
(gethash index (the ht))
(declare (ignore value))
(if (not found?)
(progn
(setf (gethash index (the ht)) nil)
(the (set-slot! :ht (the ht)))
(the (set-slot! :element-index-list
(append (the element-index-list) (list index)))))
(error "The element ~a is already active in ~s" index self))))))
(bt:with-lock-held ((the lock))
(setf (gethash index (the ht)) nil)
(the (set-slot! :ht (the ht)))
(the (set-slot! :element-index-list
(append (the element-index-list) (list index)))))
(error "The element ~a is already active in ~s" index self))))))
......
......@@ -817,6 +817,11 @@ toplevel inputs as specified in the snapshot file.
(defparameter *dep-hash-threshhold* 1000)
(defparameter *invalid-aggregate-behavior* :error)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '*invalid-aggregate-behavior* :gdl))
(defun add-notify-cons (notify-cons value &optional self message)
;;
;; FLAG -- this was added as a fix for github Issue #69, but causes
......@@ -834,13 +839,39 @@ toplevel inputs as specified in the snapshot file.
(let ((aggregate (gdl-acc::%aggregate% (first notify-cons))))
(when (and (consp aggregate)
(not (consp (gdl-acc::%aggregate% self))))
(let ((num-value (gdl-acc::number-of-elements (first aggregate))))
(when (and (consp num-value)
(let ((value (funcall message self)))
(not
(and (consp value)
(typep (first value) 'gdl-basis)))))
(add-notify-cons (list self message) num-value))))))
(let ((agg (first aggregate)))
(if agg
(let ((num-value (gdl-acc::number-of-elements agg)))
(when (and (consp num-value)
(let ((value (funcall message self)))
(not
(and (consp value)
(typep (first value) 'gdl-basis)))))
(add-notify-cons (list self message) num-value)))
(let ((error-message (format nil "
!!!
Invalid internal Gendl data structure detected.
notify-cons = ~s
aggregate = ~a
value = ~s
self = ~a
message = ~s
!!!
"
notify-cons aggregate value self message)))
(ecase *invalid-aggregate-behavior*
(:error (error error-message))
(:warn (warn error-message))
(nil ))))))))
(let ((second (second value)))
(if (and (listp second) (< (length second) *dep-hash-threshhold*))
(let ((matching-sublist (assoc (first notify-cons) (second value))))
......
......@@ -354,32 +354,33 @@ or all mixins from the entire inheritance hierarchy.\")"
reading from databases or external files). Defaults to nil.\")"
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (the :root))
(bt:with-lock-held (*binding-lock*)
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (the :root))
(root-path (remove :root-object-object (the root-path)))
;;(root-path (the root-path))
(root-path (remove :root-object-object (the root-path)))
;;(root-path (the root-path))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset)))))))))
(restore-attribute-default! (attribute) (the (restore-slot-default! attribute)))
......@@ -510,7 +511,7 @@ from
value
(cons 'the (append (reverse (the-object (first *notify-cons*) root-path))
(list (make-keyword (second *notify-cons*)))))))
(progn ;; bt:with-lock-held (*binding-lock*) FLAG - bring in later in bootstrapping.
(bt:with-lock-held (*binding-lock*)
(unless (eql attribute :%primary?%)
(when (not *run-with-dependency-tracking?*)
(error "Dependency Tracking must be enabled in order to forcibly
......@@ -886,10 +887,7 @@ a separate object hierarchy." object self)))
(defparameter *unbound-slots* nil)
;;
;; FLAG -- bring this in later in bootstrapping when we have bordeaux-threads.
;;
;;(defparameter *binding-lock* (bt:make-lock "unbinding-lock"))
(defparameter *binding-lock* (bt:make-lock "unbinding-lock"))
(defun unbind-dependent-slots (object slot &key updating?)
(let ((*unbound-slots* (glisp:make-sans-value-equalp-hash-table)))
......
......@@ -66,14 +66,25 @@ Perhaps a zombie process is holding port ~a?~%" port port))
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*)
(external-format :utf8-base))
(net.aserve:shutdown)
(let ((port port))
(do ((error (client-test port) (client-test port)))
(error (format t "~&Starting AllegroServe on ~a...~%" port)
(net.aserve:start :port port :listeners listeners #-mswindows :external-format #-mswindows external-format)
port)
(incf port))))
(external-format :utf8-base))
(net.aserve:shutdown)
(let ((wait-time 1))
(block :outer
(do () ()
(let ((port port))
(block :inner
(do ((port-free? (client-test port) (client-test port)))
(port-free?
(format t (if (> wait-time 1) "~&Retrying AllegroServe on ~a...~%"
"~&Trying to start AllegroServe on ~a...~%") port)
(if (ignore-errors
(net.aserve:start :port port :listeners listeners
#-mswindows :external-format #-mswindows external-format))
(return-from :outer port)
(progn (sleep (random wait-time)) (return-from :inner))))
(incf port))))
(incf wait-time 0.1)))))
(defvar *settings*
(list (list '*static-home* *static-home*
......
;;
;; Copyright 2002-2012 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(#+allegro
excl:without-package-locks
#-allegro progn
(defparameter *invalid-aggregate-behavior* :error)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '*invalid-aggregate-behavior* :gdl))
(defun add-notify-cons (notify-cons value &optional self message)
;;
;; FLAG -- this was added as a fix for github Issue #69, but causes
;; a regression by polluting the dependency graph with normal objects
;; which may then become unbound spuriously. Retracted until a more
;; benign fix for Issue #69 can be determined.
;;
;;(declare (ignore self message))
;;
;; FLAG -- we put back the extra tracking of notify-cons but only if
;; the message does not name a GDL object -- we don't want those
;; being the target of dependencies or they can be orphaned.
;;
(when (and self message)
(let ((aggregate (gdl-acc::%aggregate% (first notify-cons))))
(when (and (consp aggregate)
(not (consp (gdl-acc::%aggregate% self))))
(let ((agg (first aggregate)))
(if agg
(let ((num-value (gdl-acc::number-of-elements agg)))
(when (and (consp num-value)
(let ((value (funcall message self)))
(not
(and (consp value)
(typep (first value) 'gdl-basis)))))
(add-notify-cons (list self message) num-value)))
(let ((error-message (format nil "
!!!
Invalid internal Gendl data structure detected.
notify-cons = ~s
aggregate = ~a
value = ~s
self = ~a
message = ~s
!!!
"
notify-cons aggregate value self message)))
(ecase *invalid-aggregate-behavior*
(:error (error error-message))
(:warn (warn error-message))
(nil ))))))))
(let ((second (second value)))
(if (and (listp second) (< (length second) *dep-hash-threshhold*))
(let ((matching-sublist (assoc (first notify-cons) (second value))))
(if matching-sublist (pushnew (second notify-cons) (rest matching-sublist))
(push (copy-list notify-cons) (second value))))
(progn
(when (listp second) (setf (second value) (alist-to-hash second)))
(pushnew (second notify-cons) (gethash (first notify-cons) (second value)))))))))
(in-package :gwl)
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(#+allegro
excl:without-package-locks
#-allegro progn
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*)
(external-format :utf8-base))
(net.aserve:shutdown)
(let ((wait-time 1))
(block :outer
(do () ()
(let ((port port))
(block :inner
(do ((port-free? (client-test port) (client-test port)))
(port-free?
(format t (if (> wait-time 1) "~&Retrying AllegroServe on ~a...~%"
"~&Trying to start AllegroServe on ~a...~%") port)
(if (ignore-errors
(net.aserve:start :port port :listeners listeners
#-mswindows :external-format #-mswindows external-format))
(return-from :outer port)
(progn (sleep (random wait-time)) (return-from :inner))))
(incf port))))
(incf wait-time 0.1)))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment