From afb80004d6a16f716275b7f30410d7fde549b99c Mon Sep 17 00:00:00 2001 From: eknauel Date: Sun, 25 Apr 2004 09:27:40 +0000 Subject: [PATCH] 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. --- Makefile.am | 1 + scheme/libs/libs-interfaces.scm | 8 ++ scheme/libs/libs-packages.scm | 12 +- scheme/libs/weak-table.scm | 24 ++++ scheme/libs/xft.scm | 222 +++++++++++++++++++++++++------- 5 files changed, 217 insertions(+), 50 deletions(-) create mode 100644 scheme/libs/weak-table.scm diff --git a/Makefile.am b/Makefile.am index 7824e89..b3f84d7 100644 --- 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 diff --git a/scheme/libs/libs-interfaces.scm b/scheme/libs/libs-interfaces.scm index b369786..d439617 100644 --- 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)) diff --git a/scheme/libs/libs-packages.scm b/scheme/libs/libs-packages.scm index 93ff451..e3fb44f 100644 --- 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 @@ -21,4 +23,10 @@ define-record-types external-calls) (files xrender)) - \ No newline at end of file + +(define-structure weak-table weak-table-interface + (open scheme + srfi-9 + general-tables + weak) + (files weak-table)) diff --git a/scheme/libs/weak-table.scm b/scheme/libs/weak-table.scm new file mode 100644 index 0000000..2e82d08 --- /dev/null +++ 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))) diff --git a/scheme/libs/xft.scm b/scheme/libs/xft.scm index 2e79ec3..25dfc10 100644 --- 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")