Fixed 2 bugs:
1. potential dangling weak pointer left in COMPACT_WEAK_ARRAY.
2. search could insert new kernels, which could trigger compact
process, so use new function 'get_index' to handle this.
- Qian
--
You received this message because you are subscribed to the Google Groups
"FriCAS - computer algebra system" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to [email protected].
To view this discussion visit
https://groups.google.com/d/msgid/fricas-devel/4280da14-6540-4cef-8e20-565322cdc294%40gmail.com.
diff --git a/src/algebra/kl.spad b/src/algebra/kl.spad
index 0365b60f..27f2b4aa 100644
--- a/src/algebra/kl.spad
+++ b/src/algebra/kl.spad
@@ -28,6 +28,9 @@ SortedCache(S : CachableSet) : Exports == Implementation where
Exports ==> with
clearCache : () -> Void
++ clearCache() empties the cache.
+ getCache : () -> PrimitiveArray S
+ compactCache : () -> Void
+ setExpandCacheThreshold : PositiveInteger -> PositiveInteger
enterInCache : (S, S -> Boolean) -> S
++ enterInCache(x, f) enters x in the cache, calling \spad{f(y)} to
++ determine whether x is equal to y. It returns x with an integer
@@ -55,11 +58,25 @@ SortedCache(S : CachableSet) : Exports == Implementation where
cache : PrimitiveArray S := empty()$(PrimitiveArray S)
cache_size : N := 0
cache_use : N := 0
+ ExpandCacheThreshold : PositiveInteger := 300
+
+ getCache() == cache
+
+ setExpandCacheThreshold n ==
+ old := ExpandCacheThreshold
+ ExpandCacheThreshold :=n
+ old
+
+ compactCache() ==
+ cache_size = 0 => void()
+ cache_use := COMPACT_WEAK_ARRAY(cache, cache_use, cache.0)$Lisp
+ void()
expandCache(x) ==
if cache_size = cache_use then
+ compactCache()
ocache := cache
- cache_size := 2*cache_size + 10
+ cache_size := cache_use + ExpandCacheThreshold
cache := new(cache_size, x)$(PrimitiveArray S)
for k in 0..(cache_use - 1) repeat
cache(k) := ocache(k)
@@ -67,7 +84,6 @@ SortedCache(S : CachableSet) : Exports == Implementation where
insertBefore(l, x) ==
k : Integer
- expandCache(x)
vscan := cache
for k in 0..(cache_use - l - 1) repeat
vscan(cache_use - k) := vscan(cache_use - k - 1)
@@ -95,11 +111,22 @@ SortedCache(S : CachableSet) : Exports == Implementation where
void
insertAtEnd(x : S) : Void ==
- expandCache(x)
cache(cache_use) := x
cache_use := cache_use + 1
void
+ get_index(elem : S, array : PrimitiveArray S, index : Integer) : Integer ==
+ if index >= cache_use then index := cache_use - 1
+ current_elem : S := qelt(array, index)
+ EQ(elem, current_elem)$Lisp => index
+ position(elem) > position(current_elem) =>
+ while not EQ(elem, qelt(array, index))$Lisp repeat
+ index := index + 1
+ return index
+ while not EQ(elem, qelt(array, index))$Lisp repeat
+ index := index - 1
+ return index
+
linearSearch(equal? : S -> Boolean) ==
k : Integer := 0
-- Can not use for loop because equal? can insert new elements
@@ -110,13 +137,17 @@ SortedCache(S : CachableSet) : Exports == Implementation where
equal?(y) => return y
vscan := cache
-- skip over elements possibly inserted by equal?
- while not(EQ(y, vscan(k))$Lisp) repeat k := k + 1
- k := k + 1
+ k := 1 + get_index(y, vscan, k)
return "failed"
enterInCache(x : S, equal? : S -> Boolean) ==
(res := linearSearch(equal?)) case S => res
- setPosition(x, 1 + cache_use)
+ expandCache(x)
+ if cache_use = 0 then
+ pos : N := DIFF
+ else
+ pos : N := DIFF + position cache(cache_use - 1)
+ setPosition(x, pos)
insertAtEnd(x)
x
@@ -140,21 +171,10 @@ SortedCache(S : CachableSet) : Exports == Implementation where
zero?(cp) => return y
vscan := cache
if not(l < 0) then
- if not(EQ(vl, qelt(vscan, l))$Lisp) then
- l0 := l
- while not(EQ(vl, qelt(vscan, l))$Lisp) repeat
- l := l + 1
- i := i + l - l0
- m := m + l - l0
- if not(EQ(y, qelt(vscan, i))$Lisp) then
- i0 := i
- while not(EQ(y, qelt(vscan, i))$Lisp) repeat
- i := i + 1
- m := m + i - i0
+ l := get_index(vl, vscan, l)
+ i := get_index(y, vscan, i)
if has_vm then
- if not(EQ(vm, qelt(vscan, m))$Lisp) then
- while not(EQ(vm, qelt(vscan, m))$Lisp) repeat
- m := m + 1
+ m := get_index(vm, vscan, m)
if cp < 0 then
m := i
else
@@ -166,6 +186,7 @@ SortedCache(S : CachableSet) : Exports == Implementation where
"failed"
enterInCache(x : S, triage : (S, S) -> Integer) ==
+ expandCache(x)
zero?(cache_use) =>
setPosition(x, DIFF)
insertAtEnd(x)
diff --git a/src/lisp/primitives.lisp b/src/lisp/primitives.lisp
index 65783b28..da7e210c 100644
--- a/src/lisp/primitives.lisp
+++ b/src/lisp/primitives.lisp
@@ -892,3 +892,41 @@
`(let ((|$BreakMode| '|trapSpadErrors|))
(declare (special |$BreakMode|))
(CATCH '|trapSpadErrors| ,form)))
+
+(defun fullgc ()
+ #+:cmu
+ (ext:gc :full t)
+ #+:sbcl
+ (sb-ext:gc :full t)
+ #-(or :cmu :sbcl)
+ (reclaim))
+
+(defun make-weak-pointer (object)
+ #+(or :clisp :cmu :ecl)
+ (ext:make-weak-pointer object)
+ #+:sbcl
+ (sb-ext:make-weak-pointer object))
+
+(defun weak-pointer-value (weak-pointer)
+ #+(or :clisp :cmu :ecl)
+ (ext:weak-pointer-value weak-pointer)
+ #+:sbcl
+ (sb-ext:weak-pointer-value weak-pointer))
+
+(defun COMPACT_WEAK_ARRAY (array size default_element)
+ ;; return the size of array after compact
+ #+(or :clisp :cmu :ecl :sbcl)
+ (progn
+ (dotimes (i size)
+ (setf (aref array i) (make-weak-pointer (aref array i))))
+ (fullgc)
+ (do ((i 0 (1+ i)) (j 0))
+ ((= i size) j)
+ (multiple-value-bind (value valid)
+ (weak-pointer-value (aref array i))
+ (setf (aref array i) default_element)
+ (if valid (progn (setf (aref array j) value)
+ (setq j (1+ j)))))))
+
+ #-(or :clisp :cmu :ecl :sbcl)
+ size)
