fix some issues with freeing Xft/fontconfig resources.

Remaining problem: - XftFontsetDestroy() calls free() for each XftPattern stored in the Fontset. XftPatterns created by MAKE-XFT-PATTERN get their own finalizer, thus if added to the fontset, there might be two calls to free() for that object. That needs fixing.
2004-04-25 09:27:40 +00:00 · 2004-04-25 09:27:40 +00:00 · afb80004d6
parent 6ae8950d98
commit afb80004d6
5 changed files with 217 additions and 50 deletions
--- a/Makefile.am
+++ b/Makefile.am
@ -37,6 +37,7 @@ EXTRA_DIST = \
        scheme/libs/xpm.scm \
        scheme/libs/xft.scm \
        scheme/libs/xrender.scm \
+	scheme/libs/weak-list.scm \
        scheme/xt/widget-type.scm \
        scheme/xt/widget.scm \
        scheme/xt/resource-types.scm
--- a/scheme/libs/libs-interfaces.scm
+++ b/scheme/libs/libs-interfaces.scm
@ -116,3 +116,11 @@
   set-xrendercolor-green!
   set-xrendercolor-blue!
   set-xrendercolor-alpha!))
+
+(define-interface weak-table-interface
+  (export
+   make-value-weak-table
+   weak-table?
+   add-to-weak-table!
+   remove-from-weak-table!
+   lookup-in-weak-table))
--- a/scheme/libs/libs-packages.scm
+++ b/scheme/libs/libs-packages.scm
@ -13,7 +13,9 @@
 	define-record-types
 	finite-types
 	srfi-1
-	external-calls)
+	external-calls
+	weak-table
+	weak)
  (files xft))

 (define-structure xrender xrender-interface
@ -22,3 +24,9 @@
 	external-calls)
  (files xrender))

+(define-structure weak-table weak-table-interface
+  (open scheme
+	srfi-9
+	general-tables
+	weak)
+  (files weak-table))
--- a/scheme/libs/weak-table.scm
+++ b/scheme/libs/weak-table.scm
@ -0,0 +1,24 @@
+;;; weak table with weak values
+
+(define-record-type weak-table
+  (really-make-weak-table table)
+  weak-table?
+  (table weak-table-table))
+
+(define (make-value-weak-table)
+  (really-make-weak-table (make-integer-table)))
+
+(define (add-to-weak-table! table address object)
+  (table-set! (weak-table-table table)
+	      address 
+	      (make-weak-pointer object)))
+
+(define (remove-from-weak-table! table address)
+  (table-set! (weak-table-table table)
+	      address #f))
+
+(define (lookup-in-weak-table table address)
+  (cond
+   ((table-ref (weak-table-table table) address)
+    => weak-pointer-ref)
+   (else #f)))
--- a/scheme/libs/xft.scm
+++ b/scheme/libs/xft.scm
@ -1,4 +1,42 @@

+;; *object-table* maps each Xft object (identified by its memory
+;; address) to the correspoding Scheme object.  This avoids situations
+;; where we have two pointer Scheme objects for one Xft object.  In
+;; these situations we would call the finalizer (Xft free() operation)
+;; on twice on the same object.  This may crash the system, or, at
+;; least print bogus error messages.
+;; Key is an integer (memory address of the Xft structure), value a
+;; weak pointer to the Scheme object.
+
+(define *freed-objects* '())
+
+(define *object-table*
+  (make-value-weak-table))
+
+(define (register-xft-pointer! pointer object)
+  (add-to-weak-table! *object-table* pointer object))
+
+(define (unregister-xft-pointer! pointer)
+  (remove-from-weak-table! *object-table* pointer))
+
+(define (lookup-xft-pointer pointer)
+  (lookup-in-weak-table *object-table* pointer))
+
+;; Be careful about sequence in which we call the finalizers on Xft
+;; objects.  There are some dependencies which impose constraints on
+;; the sequence we can call the finalizers.  Ok, maybe I'm a bit
+;; paranoid about that.
+
+(define (cons-weak obj list)
+  (cons (make-weak-pointer obj) list))
+
+(define (filter-collected list)
+  (filter (lambda (weak-pointer)
+            (not (weak-pointer-ref weak-pointer)))
+          list))
+
+;; types
+
 (define-record-type xft-pattern :xft-pattern
  (really-make-xft-pattern c-pointer)
  xft-pattern?
@ -40,10 +78,10 @@
 (define-exported-binding "xft-objectset" :xft-objectset)

 (define-record-type xft-fontset :xft-fontset
-  (really-make-xft-fontset c-pointer patterns)
+  (really-make-xft-fontset c-pointer dependencies)
  xft-fontset?
  (c-pointer xft-fontset-c-pointer)
-  (patterns xft-fontset-patterns set-xft-fontset-patterns!))
+  (dependencies xft-fontset-dependencies set-xft-fontset-dependencies!))

 (define-exported-binding "xft-fontset" :xft-fontset)

@ -174,17 +212,76 @@
       (else
 	(error "scx: internal error. Could not map rgba id to finite type"))))))

-;;; add finalizers
+(define (xft-pattern-finalizer pattern)
+  (if (member (xft-pattern-c-pointer pattern) *freed-objects*)
+      (error "free() called twice on" pattern)
+      (set! *freed-objects* (cons (xft-pattern-c-pointer pattern) *freed-objects*)))
+  (unregister-xft-pointer! (xft-pattern-c-pointer pattern))
+  (xft-pattern-destroy pattern))
+
+(define (xft-color-finalizer color)
+  (if (member (xft-color-c-pointer color) *freed-objects*)
+      (error "free() called twice on" color)
+      (set! *freed-objects* (cons (xft-color-c-pointer color) *freed-objects*)))
+   (unregister-xft-pointer! (xft-color-c-pointer color))
+   (xft-color-free (xft-color-display color)
+ 		  (xft-color-visual color)
+ 		  (xft-color-colormap color)
+ 		  color))
+
+(define (xft-draw-finalizer draw)
+  (if (member (xft-draw-c-pointer draw) *freed-objects*)
+      (error "free() called twice on" draw)
+      (set! *freed-objects* (cons (xft-draw-c-pointer draw) *freed-objects*)))
+   (unregister-xft-pointer! (xft-draw-c-pointer draw))
+   (xft-draw-destroy draw))
+
+(define (xft-objectset-finalizer objectset)
+  (if (member (xft-objectset-c-pointer objectset) *freed-objects*)
+      (error "free() called twice on" objectset)
+      (set! *freed-objects* (cons (xft-objectset-c-pointer objectset) *freed-objects*)))
+ (unregister-xft-pointer! (xft-objectset-c-pointer objectset))
+ (xft-objectset-destroy objectset))
+
+(define (xft-fontset-finalizer fontset)
+  (cond
+   ((null? (xft-fontset-dependencies fontset))
+    (add-finalizer! fontset xft-fontset-freeing-finalizer))
+   (else
+    (set-xft-fontset-dependencies! 
+     fontset (filter-collected (xft-fontset-dependencies fontset)))
+    (add-finalizer! fontset xft-fontset-finalizer))))
+
+(define (xft-fontset-freeing-finalizer fontset)
+  (if (member (xft-fontset-c-pointer fontset) *freed-objects*)
+      (error "free() called twice on" fontset)
+      (set! *freed-objects* (cons (xft-fontset-c-pointer fontset) *freed-objects*)))
+  (unregister-xft-pointer! (xft-fontset-c-pointer fontset))
+  (xft-fontset-destroy fontset))
+
+(define (xft-font-finalizer font)
+  (if (member (xft-font-c-pointer font) *freed-objects*)
+      (error "free() called twice on" font)
+      (set! *freed-objects* (cons (xft-font-c-pointer font) *freed-objects*)))
+  (unregister-xft-pointer! (xft-font-c-pointer font))
+  (xft-font-close-internal font))

 (define (make-xft-pattern)
  (let ((pattern (xft-pattern-create)))
-    (add-finalizer! pattern xft-pattern-destroy)
-    pattern))
+    (or (lookup-xft-pointer (xft-pattern-c-pointer pattern))
+	(begin
+	  (register-xft-pointer! (xft-pattern-c-pointer pattern) pattern)
+	  (add-finalizer! pattern xft-pattern-finalizer)
+	  pattern))))

 (define (xft-pattern-duplicate pattern)
-  (let ((copy (xft-pattern-duplicate-internal pattern)))
-    (add-finalizer! copy xft-pattern-destroy)
-    copy))
+  (let* ((copy (xft-pattern-duplicate-internal pattern))
+	 (pointer (xft-pattern-c-pointer copy)))
+    (or (lookup-xft-pointer pointer)
+	(begin
+	  (register-xft-pointer! pointer copy)
+	  (add-finalizer! copy xft-pattern-finalizer)
+	  copy))))

 (define (xft-pattern-get pattern object id)
  (let ((object-id (xft-pattern-object-id object)))
@ -230,43 +327,65 @@
       (apply values
 	      (xft-font-match-internal display screen-number pattern))))
   (lambda (result pattern)
-     (add-finalizer! pattern xft-pattern-destroy)
-     (values result pattern))))
-
-(define (xft-font-close font)
-  (xft-font-close (xft-font-display font) font))
+     (let ((pointer (xft-pattern-c-pointer pattern)))
+       (cond 
+	((lookup-xft-pointer pointer)
+	 => (lambda (obj) (values result obj)))
+	(else
+	 (register-xft-pointer! (xft-pattern-c-pointer pattern) pattern)
+	 (add-finalizer! pattern xft-pattern-finalizer)
+	 (values result pattern)))))))

 (define (xft-font-open-pattern display pattern)
  (let ((font (xft-font-open-pattern-internal display pattern)))
-    (if font (add-finalizer! font xft-font-close))
-    font))
+    (or (lookup-xft-pointer (xft-font-c-pointer font))
+	(begin
+	  (register-xft-pointer! (xft-font-c-pointer font) font)
+	  (add-finalizer! font xft-font-finalizer)
+	  font))))

 (define (xft-font-open-name display screen name)
  (let* ((screen-number (screen:number screen))
 	 (font (xft-font-open-name-internal display screen-number name)))
-    (if font (add-finalizer! font xft-font-close))
-    font))
+    (or (lookup-xft-pointer (xft-font-c-pointer font))
+	(begin
+	  (register-xft-pointer! (xft-font-c-pointer font) font)
+	  (add-finalizer! font xft-font-finalizer)
+	  font))))

 (define (xft-font-open-xlfd display screen name)
  (let* ((screen-numer (screen:number screen))
 	 (font (xft-font-open-xlfd-internal display screen-numer name)))
-    (if font (add-finalizer! font xft-font-close))
-    font))
+    (or (lookup-xft-pointer (xft-font-c-pointer font) font)
+	(begin
+	  (register-xft-pointer! (xft-font-c-pointer font) font)
+	  (add-finalizer! font xft-font-finalizer)
+	  font))))

 (define (make-xft-draw display drawable visual colormap)
  (let ((draw (xft-draw-create-internal display drawable visual colormap)))
-    (add-finalizer! draw xft-draw-destroy)
-    draw))
+    (or (lookup-xft-pointer (xft-draw-c-pointer draw))
+	(begin
+	  (register-xft-pointer! (xft-draw-c-pointer draw) draw)
+	  (add-finalizer! draw xft-draw-finalizer)
+	  draw))))

 (define (make-xft-draw-bitmap display drawable)
  (let ((draw (xft-draw-create-bitmap-internal display drawable)))
-    (add-finalizer! draw xft-draw-destroy)
-    draw))
+    (or (lookup-xft-pointer (xft-draw-c-pointer draw))
+	(begin
+	  (register-xft-pointer! (xft-draw-c-pointer draw) draw)
+	  (add-finalizer! draw xft-draw-finalizer)
+	  draw))))

 (define (make-xft-objectset)
  (let ((objectset (xft-objectset-create)))
-    (add-finalizer! objectset xft-objectset-destroy)
-    objectset))
+    (or (lookup-xft-pointer (xft-objectset-c-pointer objectset))
+	(begin
+	  (register-xft-pointer! (xft-objectset-c-pointer objectset)
+				 objectset)
+	  (add-finalizer! objectset xft-objectset-finalizer)
+	  objectset))))

 (define (xft-objectset-add objectset pattern-object)
  (xft-objectset-add-internal 
@ -274,46 +393,59 @@

 (define (xft-draw-display draw)
  (let ((display (xft-draw-display-internal draw)))
-    (if display
-	display
+    (or display
 	(error "XftDrawDisplay() unavailable in this version of Xft"))))

 (define (xft-draw-drawable draw)
  (let ((drawable (xft-draw-drawable-internal draw)))
-    (if drawable
-	drawable
+    (or drawable
 	(error "XftDrawDrawable() unavailable in this version of Xft"))))

 (define (xft-draw-colormap draw)
  (let ((colormap (xft-draw-colormap-internal draw)))
-    (if colormap
-	colormap
+    (or colormap
 	(error "XftDrawColormap() unavailable in this version of Xft"))))

 (define (xft-draw-visual draw)
  (let ((visual (xft-draw-visual-internal draw)))
-    (if visual
-	visual
+    (or visual
 	(error "XftDrawVisual() unavailable in this version of Xft"))))

 (define (xft-list-fonts-pattern-objects display screen pattern objectset)
  (let* ((screen-number (screen:number screen))
 	 (fontset (xft-list-fonts-pattern-objects-internal
 		   display screen-number pattern objectset)))
-    (add-finalizer! fontset xft-fontset-destroy)
-    fontset))
+    (or (lookup-xft-pointer (xft-fontset-c-pointer fontset))
+	(begin
+	  (register-xft-pointer! (xft-fontset-c-pointer fontset) fontset)
+	  (set-xft-fontset-dependencies! fontset '())
+	  (add-finalizer! fontset xft-fontset-finalizer)
+	  fontset))))

 (define (make-xft-fontset)
  (let ((fontset (xft-fontset-create)))
-    (set-xft-fontset-patterns! fontset '())
-    (add-finalizer! fontset xft-fontset-create)
-    fontset))
+    (or (lookup-xft-pointer (xft-fontset-c-pointer fontset))
+	(begin
+	  (register-xft-pointer! (xft-fontset-c-pointer fontset) fontset)
+	  (set-xft-fontset-dependencies! fontset '())
+	  (add-finalizer! fontset xft-fontset-finalizer)
+	  fontset))))

 (define (xft-fontset-add fontset pattern)
-  (set-xft-fontset-patterns! 
-   fontset (lset-adjoin eq? pattern (xft-fontset-patterns fontset)))
+  (set-xft-fontset-dependencies! 
+   fontset (cons-weak pattern (xft-fontset-dependencies fontset)))
  (xft-fontset-add-internal fontset pattern))

+(define (xft-fontset-ref fontset index)
+  (let ((pattern (xft-fontset-ref-internal fontset index)))
+    (or (lookup-xft-pointer (xft-pattern-c-pointer pattern))
+	(begin
+	  (register-xft-pointer! (xft-pattern-c-pointer pattern) pattern)
+	  (set-xft-fontset-dependencies! 
+	   fontset (cons-weak pattern (xft-fontset-dependencies fontset)))
+	  ;(add-finalizer! pattern xft-pattern-finalizer)
+	  pattern))))
+
 (define (xft-color-alloc-name display visual colormap name)
  (call-with-values
   (lambda ()
@ -342,12 +474,6 @@
     (add-finalizer! color xft-color-finalizer)
     color)))

-(define (xft-color-finalizer color)
-  (xft-color-free (xft-color-display color)
-		  (xft-color-visual color)
-		  (xft-color-colormap color)
-		  color))
-
 (define (xft-default-substitute display screen pattern)
  (xft-default-substitute-internal display (screen:number screen) pattern))

@ -391,7 +517,7 @@
 			  "scx_XftPatternCreate")

 (import-lambda-definition xft-pattern-destroy
-			  ()
+			  (pattern)
 			  "scx_XftPatternDestroy")

 (import-lambda-definition xft-pattern-duplicate-internal
@ -550,6 +676,6 @@
 			  (fontset)
 			  "scx_xftfontset_count_get")

-(import-lambda-definition xft-fontset-ref
+(import-lambda-definition xft-fontset-ref-internal
 			  (fontset index)
 			  "scx_xftfontset_pattern_ref")