From manuel at bl0rg.net Thu May 20 19:28:49 2004 From: manuel at bl0rg.net (Manuel Odendahl) Date: Thu, 20 May 2004 21:28:49 +0200 (CEST) Subject: [cl-gd-devel] cl-gd memory leak fix Message-ID: <20040520212005.E9896@androgyn.bl0rg.net> 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 From edi at agharta.de Fri May 21 09:50:10 2004 From: edi at agharta.de (Edi Weitz) Date: Fri, 21 May 2004 11:50:10 +0200 Subject: [cl-gd-devel] cl-gd memory leak fix In-Reply-To: <20040520212005.E9896@androgyn.bl0rg.net> (Manuel Odendahl's message of "Thu, 20 May 2004 21:28:49 +0200 (CEST)") References: <20040520212005.E9896@androgyn.bl0rg.net> Message-ID: Hi! On Thu, 20 May 2004 21:28:49 +0200 (CEST), Manuel Odendahl wrote: > We are using cl-gd in our bknr web framework, and use cl-gd to > scale, transform and otherwise manipulate images. Cool, so someone is actually using it... :) > 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). OK, I'll add that and make a new release. Actually, I didn't steal from UFFI but wrote this myself and IIRC I was a little bit uneasy whether what you're describing above could/would actually happen. I was like "nah, no way," and it turns out I was wrong... :) > 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). I'll add these too. (After removing the tabs... :) Thanks again, Edi. From edi at agharta.de Fri May 21 11:29:47 2004 From: edi at agharta.de (Edi Weitz) Date: Fri, 21 May 2004 13:29:47 +0200 Subject: [cl-gd-devel] New release 0.4.1 Message-ID: Date: Wed, 19 May 2004 07:26:57 +0200 Reply-to: edi at agharta.de User-Agent: Gnus/5.1002 (Gnus v5.10.2) Emacs/21.3.50 (gnu/linux) Hi! A new release is available from . Here's the relevant part from the changelog: Version 0.4.1 2004-05-21 Fix for memory leak (see WITH-SAFE-ALLOC) by Manuel Odendahl Documented COLOR-COMPONENT which was missing in index.html (thanks to Manuel Odendahl) Two new functions, COLOR-COMPONENTS and FIND-COLOR-FROM-IMAGE (both by Manuel Odendahl) Replaced WRITE-BYTE with WRITE-SEQUENCE for LispWorks - see Have fun, Edi.