[cl-gd-devel] cl-gd memory leak fix
Manuel Odendahl
manuel at bl0rg.net
Thu May 20 19:28:49 UTC 2004
Hi!
We are using cl-gd in our bknr web framework, and use cl-gd to scale,
transform and otherwise manipulate images. We had the problem that
sometimes cl-gd would quit on us saying it could not allocate additional
memory, which suggested a memory leak somewhere. After some code
browsing and testing, I found several race conditions in cl-gd, having
to do with the use of UNWIND-PROTECT, which looked like this:
(let* ((c-style (allocate-foreign-object :int length)))
(unwind-protect (yadayada)
(free-foreign-object c-style)))
However, if somehow the stack is unwound just after the call to
ALLOCATE-FOREIGN-OBJECT, C-STYLE will never get freed. I guess the
UNWIND-PROTECT code was taken from uffi (specifically from
with-foreign-object), which has the same problem (but this is another
story). Anyway, while uffi gets fixed to rewrite the above nicely, I
have added the WITH-SAFE-ALLOC to util.lisp:
(defmacro with-safe-alloc ((var alloc free) &rest body)
`(let (,var)
(unwind-protect
(progn (setf ,var ,alloc)
, at body)
(when ,var ,free))))
and sprinkled the code with it (I replaced all occurences of
UNWIND-PROTECT dealing with memory allocation, and quickly browsed the
code for other allocation code, but couldn't find any).
This seems to fix our problems. On another front, I have added the
function COLOR-COMPONENTS, which returns a list of the color copmonents
of a color (we needed this somewhere), and the function
FIND-COLOR-FROM-IMAGE, which tries to FIND-COLOR a color from a source
image inside a new image (to copy colors between images).
(defun color-components (color &key (image *default-image*))
"Returns the color components of COLOR as a list. The components are in the
order red, green, blue, alpha."
(mapcar #'(lambda (c) (color-component c color :image image))
'(:red :green :blue :alpha)))
(defun find-color-from-image (color source-image &key alpha exact hwb
resolve (image *default-image*))
"Returns the color in IMAGE corresponding to COLOR in SOURCE-IMAGE. The
keyword parameters are passed to FIND-COLOR."
(let ((red (color-component :red color :image source-image))
(blue (color-component :blue color :image source-image))
(green (color-component :green color :image source-image))
(alpha (when alpha (color-component :alpha color :image source-image))))
(find-color red green blue :alpha alpha :exact exact :hwb hwb
:resolve resolve :image image)))
I have made a patch file which I'll attach to the mail, and the patched
cl-gd directory can be downloaded from
http://bl0rg.net/~manuel/cl-gd-patched.tar.gz. I have changed index.html
with documentation for the new functions and a documentation for
COLOR-COMPONENT, which was referenced but not included. I have also
added the Makefile we have to produce the .so file (FreeBSD, haven't
checked it on another platform).
Hope this helps :}
Regards, Manuel Odendahl
-------------- next part --------------
Only in cl-gd-patched: Makefile
diff -u cl-gd-0.3.1/colors-aux.lisp cl-gd-patched/colors-aux.lisp
--- cl-gd-0.3.1/colors-aux.lisp Tue Aug 26 12:33:15 2003
+++ cl-gd-patched/colors-aux.lisp Thu May 20 21:00:34 2004
@@ -95,37 +95,33 @@
(defmethod (setf current-style) ((style list) &optional (image *default-image*))
(check-type image image)
- (let* ((length (length style))
- (c-style (allocate-foreign-object :int length)))
- (unwind-protect
- (progn
- (loop for color in style
- for i from 0
- do (setf (deref-array c-style '(:array :int) i)
- (typecase color
- (null +transparent+)
- (integer color)
- (t 1))))
- (gd-image-set-style (img image) c-style length)
- style)
- (free-foreign-object c-style))))
+ (let ((length (length style)))
+ (with-safe-alloc (c-style (allocate-foreign-object :int length)
+ (free-foreign-object c-style))
+ (loop for color in style
+ for i from 0
+ do (setf (deref-array c-style '(:array :int) i)
+ (typecase color
+ (null +transparent+)
+ (integer color)
+ (t 1))))
+ (gd-image-set-style (img image) c-style length)
+ style)))
(defmethod (setf current-style) ((style vector) &optional (image *default-image*))
(check-type image image)
- (let* ((length (length style))
- (c-style (allocate-foreign-object :int length)))
- (unwind-protect
- (progn
- (loop for color across style
- for i from 0
- do (setf (deref-array c-style '(:array :int) i)
- (typecase color
- (null +transparent+)
- (integer color)
- (t 1))))
- (gd-image-set-style (img image) c-style length)
- style)
- (free-foreign-object c-style))))
+ (let ((length (length style)))
+ (with-safe-alloc (c-style (allocate-foreign-object :int length)
+ (free-foreign-object c-style))
+ (loop for color across style
+ for i from 0
+ do (setf (deref-array c-style '(:array :int) i)
+ (typecase color
+ (null +transparent+)
+ (integer color)
+ (t 1))))
+ (gd-image-set-style (img image) c-style length)
+ style)))
(defun set-anti-aliased (color do-not-blend &optional (image *default-image*))
"Set COLOR to be the current anti-aliased color of
@@ -169,4 +165,4 @@
(with-unique-names (c-color-arg)
`(let ((,c-color-arg (resolve-c-color color image)))
,@(sublis (list (cons 'color c-color-arg))
- body :test #'eq))))
\ No newline at end of file
+ body :test #'eq))))
diff -u cl-gd-0.3.1/colors.lisp cl-gd-patched/colors.lisp
--- cl-gd-0.3.1/colors.lisp Tue Aug 26 21:43:31 2003
+++ cl-gd-patched/colors.lisp Thu May 20 21:00:42 2004
@@ -218,4 +218,21 @@
((:blue) #'gd-image-get-blue)
((:alpha) #'gd-image-get-alpha))
(img image)
- color))
\ No newline at end of file
+ color))
+
+(defun color-components (color &key (image *default-image*))
+ "Returns the color components of COLOR as a list. The components are in the
+order red, green, blue, alpha."
+ (mapcar #'(lambda (c) (color-component c color :image image))
+ '(:red :green :blue :alpha)))
+
+(defun find-color-from-image (color source-image &key alpha exact hwb
+ resolve (image *default-image*))
+ "Returns the color in IMAGE corresponding to COLOR in SOURCE-IMAGE. The
+keyword parameters are passed to FIND-COLOR."
+ (let ((red (color-component :red color :image source-image))
+ (blue (color-component :blue color :image source-image))
+ (green (color-component :green color :image source-image))
+ (alpha (when alpha (color-component :alpha color :image source-image))))
+ (find-color red green blue :alpha alpha :exact exact :hwb hwb
+ :resolve resolve :image image)))
Common subdirectories: cl-gd-0.3.1/doc and cl-gd-patched/doc
diff -u cl-gd-0.3.1/drawing.lisp cl-gd-patched/drawing.lisp
--- cl-gd-0.3.1/drawing.lisp Tue Aug 26 21:43:31 2003
+++ cl-gd-patched/drawing.lisp Thu May 20 21:00:18 2004
@@ -134,24 +134,23 @@
(unless (and (>= effective-length 6)
(evenp effective-length))
(error "We need an even number of at least six vertices"))
- (let ((arr (allocate-foreign-object 'gd-point (/ effective-length 2))))
- (unwind-protect
- (with-color-argument
- (with-transformed-alternative
- (((aref vertices i) x-transformer)
- ((aref vertices (1+ i)) y-transformer))
- (loop for i from start below end by 2
- for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2))
- do (setf (get-slot-value point-ptr 'gd-point 'x)
- (aref vertices i)
- (get-slot-value point-ptr 'gd-point 'y)
- (aref vertices (1+ i))))
- (funcall (if filled
- #'gd-image-filled-polygon
- #'gd-image-polygon)
- (img image) arr (/ effective-length 2) color)
- vertices))
- (free-foreign-object arr)))))
+ (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2))
+ (free-foreign-object arr))
+ (with-color-argument
+ (with-transformed-alternative
+ (((aref vertices i) x-transformer)
+ ((aref vertices (1+ i)) y-transformer))
+ (loop for i from start below end by 2
+ for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2))
+ do (setf (get-slot-value point-ptr 'gd-point 'x)
+ (aref vertices i)
+ (get-slot-value point-ptr 'gd-point 'y)
+ (aref vertices (1+ i))))
+ (funcall (if filled
+ #'gd-image-filled-polygon
+ #'gd-image-polygon)
+ (img image) arr (/ effective-length 2) color)
+ vertices)))))
(defmethod draw-polygon ((vertices list) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*))
(check-type start integer)
@@ -161,28 +160,27 @@
(unless (and (>= effective-length 6)
(evenp effective-length))
(error "We need an even number of at least six vertices"))
- (let ((arr (allocate-foreign-object 'gd-point (/ effective-length 2))))
- (unwind-protect
- (with-color-argument
- (with-transformed-alternative
- (((first x/y) x-transformer)
- ((second x/y) y-transformer))
- (loop for i below (- end start) by 2
- ;; we don't use LOOP's destructuring capabilities here
- ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE
- ;; macro which would get confused
- for x/y on (nthcdr start vertices) by #'cddr
- for point-ptr = (deref-array arr '(:array gd-point) (/ i 2))
- do (setf (get-slot-value point-ptr 'gd-point 'x)
- (first x/y)
- (get-slot-value point-ptr 'gd-point 'y)
- (second x/y)))
- (funcall (if filled
- #'gd-image-filled-polygon
- #'gd-image-polygon)
- (img image) arr (/ effective-length 2) color)
- vertices))
- (free-foreign-object arr)))))
+ (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2))
+ (free-foreign-object arr))
+ (with-color-argument
+ (with-transformed-alternative
+ (((first x/y) x-transformer)
+ ((second x/y) y-transformer))
+ (loop for i below (- end start) by 2
+ ;; we don't use LOOP's destructuring capabilities here
+ ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE
+ ;; macro which would get confused
+ for x/y on (nthcdr start vertices) by #'cddr
+ for point-ptr = (deref-array arr '(:array gd-point) (/ i 2))
+ do (setf (get-slot-value point-ptr 'gd-point 'x)
+ (first x/y)
+ (get-slot-value point-ptr 'gd-point 'y)
+ (second x/y)))
+ (funcall (if filled
+ #'gd-image-filled-polygon
+ #'gd-image-polygon)
+ (img image) arr (/ effective-length 2) color)
+ vertices)))))
(defun draw-filled-ellipse (center-x center-y width height &key (color *default-color*) (image *default-image*))
"Draws a filled ellipse centered at \(CENTER-X, CENTER-Y) with width
diff -u cl-gd-0.3.1/images.lisp cl-gd-patched/images.lisp
--- cl-gd-0.3.1/images.lisp Sun Apr 25 21:07:10 2004
+++ cl-gd-patched/images.lisp Thu May 20 21:02:32 2004
@@ -42,7 +42,8 @@
(gd-image-create width height))))
(when (null-pointer-p image-ptr)
(error "Could not allocate image of size ~A x ~A" width height))
- (make-image image-ptr)))
+ (let ((image (make-image image-ptr)))
+ image)))
(defun destroy-image (image)
"Destroys \(deallocates) IMAGE which has been created by
@@ -65,11 +66,10 @@
exits."
;; we rebind everything so we have left-to-right evaluation
(rebinding (width height true-color)
- `(let ((,name (create-image ,width ,height ,true-color)))
- (unwind-protect
- (progn
- , at body)
- (destroy-image ,name)))))
+ `(with-safe-alloc (,name
+ (create-image ,width ,height ,true-color)
+ (destroy-image ,name))
+ , at body)))
(defmacro with-image* ((width height &optional true-color) &body body)
"Creates an image with size WIDTH x HEIGHT and executes BODY with
@@ -138,7 +138,8 @@
(t
(error "Could not create image from ~A file ~S: errno was ~A"
%type file-name (deref-pointer err :int)))))
- (t (make-image image))))))))
+ (t (let ((image (make-image image)))
+ image))))))))
(defmacro with-image-from-file ((name file-name &optional type) &body body)
"Creates an image from the file specified by FILE-NAME \(which is
@@ -148,12 +149,11 @@
guaranteed to be destroyed before this macro exits."
;; we rebind everything so we have left-to-right evaluation
(rebinding (file-name type)
- `(let ((,name (create-image-from-file ,file-name ,type)))
- (unwind-protect
- , at body
- (when ,name
- (destroy-image ,name))))))
-
+ `(with-safe-alloc (,name
+ (create-image-from-file ,file-name ,type)
+ (destroy-image ,name))
+ , at body)))
+
(defmacro with-image-from-file* ((file-name &optional type) &body body)
"Creates an image from the file specified by FILE-NAME \(which is
either a pathname or a string) and executes BODY with the image bound
@@ -194,11 +194,10 @@
before this macro exits."
;; we rebind everything so we have left-to-right evaluation
(rebinding (file-name src-x src-y width height)
- `(let ((,name (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height)))
- (unwind-protect
- , at body
- (when ,name
- (destroy-image ,name))))))
+ `(with-safe-alloc (,name
+ (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height)
+ (destroy-image ,name))
+ , at body)))
(defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body)
"Creates an image from the part of the GD2 file FILE-NAME \(which is
@@ -221,27 +220,23 @@
(subtypep (stream-element-type stream) 'base-char)
(subtypep (stream-element-type stream) '(unsigned-byte 8)))
(with-foreign-object (size :int)
- (let ((memory ,gd-call))
- (unwind-protect
- (with-cast-pointer (temp memory :unsigned-byte)
- (dotimes (i (deref-pointer size :int))
- (write-byte (deref-array temp '(:array :unsigned-byte) i)
- stream))
- image)
- (gd-free memory)))))
+ (with-safe-alloc (memory ,gd-call (gd-free memory))
+ (with-cast-pointer (temp memory :unsigned-byte)
+ (dotimes (i (deref-pointer size :int))
+ (write-byte (deref-array temp '(:array :unsigned-byte) i)
+ stream))
+ image))))
((subtypep (stream-element-type stream) 'character)
(with-foreign-object (size :int)
- (let ((memory ,gd-call))
- (unwind-protect
- (with-cast-pointer (temp memory
- #+(or :cmu :scl :sbcl) :unsigned-char
- #-(or :cmu :scl :sbcl) :char)
- (dotimes (i (deref-pointer size :int))
- (write-char (ensure-char-character
- (deref-array temp '(:array :char) i))
- stream))
- image)
- (gd-free memory)))))
+ (with-safe-alloc (memory ,gd-call (gd-free memory))
+ (with-cast-pointer (temp memory
+ #+(or :cmu :scl :sbcl) :unsigned-char
+ #-(or :cmu :scl :sbcl) :char)
+ (dotimes (i (deref-pointer size :int))
+ (write-char (ensure-char-character
+ (deref-array temp '(:array :char) i))
+ stream))
+ image))))
(t (error "Can't use a stream with element-type ~A"
(stream-element-type stream))))))
@@ -398,4 +393,4 @@
(((gd-image-get-sx (img image)) w-inv-transformer)
((gd-image-get-sy (img image)) h-inv-transformer))
(values (gd-image-get-sx (img image))
- (gd-image-get-sy (img image)))))
\ No newline at end of file
+ (gd-image-get-sy (img image)))))
diff -u cl-gd-0.3.1/packages.lisp cl-gd-patched/packages.lisp
--- cl-gd-0.3.1/packages.lisp Sat Apr 24 02:17:52 2004
+++ cl-gd-patched/packages.lisp Thu May 20 21:02:42 2004
@@ -40,11 +40,13 @@
#:true-color-p
#:number-of-colors
#:find-color
+ #:find-color-from-image
#:thickness
#:with-thickness
#:alpha-blending-p
#:save-alpha-p
#:color-component
+ #:color-components
#:draw-polygon
#:draw-line
#:set-pixel
@@ -74,4 +76,4 @@
#:do-pixels
#:raw-pixel))
-(pushnew :cl-gd *features*)
\ No newline at end of file
+(pushnew :cl-gd *features*)
diff -u cl-gd-0.3.1/strings.lisp cl-gd-patched/strings.lisp
--- cl-gd-0.3.1/strings.lisp Thu Aug 28 11:08:47 2003
+++ cl-gd-patched/strings.lisp Thu May 20 21:02:50 2004
@@ -145,49 +145,49 @@
(setq string (convert-to-char-references string)))
(with-cstring (c-font-name font-name)
(with-cstring (c-string string)
- (let ((c-bounding-rectangle (allocate-foreign-object :int 8)))
- (unwind-protect
- (let ((msg (convert-from-cstring
- (cond (line-spacing
- (with-foreign-object (strex 'gd-ft-string-extra)
- (setf (get-slot-value strex
- 'gd-ft-string-extra
- 'flags)
- +gd-ftex-linespace+
- (get-slot-value strex
- 'gd-ft-string-extra
- 'line-spacing)
- (coerce line-spacing 'double-float))
- (gd-image-string-ft-ex (if do-not-draw
- *null-image*
- (img image))
- c-bounding-rectangle
- (if anti-aliased color (- color))
- c-font-name
- (coerce point-size 'double-float)
- (coerce angle 'double-float)
- x y
- c-string
- strex)))
- (t
- (gd-image-string-ft (img (if do-not-draw
- *null-image*
- image))
- c-bounding-rectangle
- (if anti-aliased color (- color))
- c-font-name
- (coerce point-size 'double-float)
- (coerce angle 'double-float)
- x y
- c-string))))))
- (when msg
- (error "Error in FreeType library: ~A" msg))
- (let ((bounding-rectangle (make-array 8)))
- ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE
- (loop for i below 8 by 2 do
- (setf (aref bounding-rectangle i)
- (deref-array c-bounding-rectangle '(:array :int) i))
- (setf (aref bounding-rectangle (1+ i))
- (deref-array c-bounding-rectangle '(:array :int) (1+ i))))
- bounding-rectangle))
- (free-foreign-object c-bounding-rectangle)))))))
\ No newline at end of file
+ (with-safe-alloc (c-bounding-rectangle
+ (allocate-foreign-object :int 8)
+ (free-foreign-object c-bounding-rectangle))
+ (let ((msg (convert-from-cstring
+ (cond (line-spacing
+ (with-foreign-object (strex 'gd-ft-string-extra)
+ (setf (get-slot-value strex
+ 'gd-ft-string-extra
+ 'flags)
+ +gd-ftex-linespace+
+ (get-slot-value strex
+ 'gd-ft-string-extra
+ 'line-spacing)
+ (coerce line-spacing 'double-float))
+ (gd-image-string-ft-ex (if do-not-draw
+ *null-image*
+ (img image))
+ c-bounding-rectangle
+ (if anti-aliased color (- color))
+ c-font-name
+ (coerce point-size 'double-float)
+ (coerce angle 'double-float)
+ x y
+ c-string
+ strex)))
+ (t
+ (gd-image-string-ft (img (if do-not-draw
+ *null-image*
+ image))
+ c-bounding-rectangle
+ (if anti-aliased color (- color))
+ c-font-name
+ (coerce point-size 'double-float)
+ (coerce angle 'double-float)
+ x y
+ c-string))))))
+ (when msg
+ (error "Error in FreeType library: ~A" msg))
+ (let ((bounding-rectangle (make-array 8)))
+ ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE
+ (loop for i below 8 by 2 do
+ (setf (aref bounding-rectangle i)
+ (deref-array c-bounding-rectangle '(:array :int) i))
+ (setf (aref bounding-rectangle (1+ i))
+ (deref-array c-bounding-rectangle '(:array :int) (1+ i))))
+ bounding-rectangle)))))))
\ No newline at end of file
Common subdirectories: cl-gd-0.3.1/test and cl-gd-patched/test
diff -u cl-gd-0.3.1/util.lisp cl-gd-patched/util.lisp
--- cl-gd-0.3.1/util.lisp Sun Aug 24 00:38:37 2003
+++ cl-gd-patched/util.lisp Thu May 20 21:02:56 2004
@@ -115,4 +115,11 @@
else do
(write-char #\& s)
(princ char-code s)
- (write-char #\; s)))))
\ No newline at end of file
+ (write-char #\; s)))))
+
+(defmacro with-safe-alloc ((var alloc free) &rest body)
+ `(let (,var)
+ (unwind-protect
+ (progn (setf ,var ,alloc)
+ , at body)
+ (when ,var ,free))))
\ No newline at end of file
More information about the Cl-gd-devel
mailing list