Whacking down memory usage of CLSQL-SYS::MAP-QUERY-FOR-EFFECT

Hi,

A few days ago, I posted a message about CLSQL:MAP-QUERY using more memory
than CLSQL:QUERY.  After poking around a bit deeper in the source code,
I came up with a hack to greatly reduce the amount of memory used by
(CLSQL:MAP-QUERY NIL ...).  With this hack, the profile report of the
following 2 test functions:

(defun test-1 ()
  (clsql:map-query nil
      	           #'identity
		   (clsql:query "select c1, c2, c3, c4, c5, c6, c7 from Cells")))

(defun test-2 ()
  (clsql:query "select c1, c2, c3, c4, c5, c6, c7 from Cells") )

is

  seconds  |    consed   | calls |  sec/call  |  name
---------------------------------------------------------
    46.778 | 147,860,728 |     1 |  46.777996 | TEST-2
    44.614 |  14,768,136 |     1 |  44.613995 | TEST-1


The old profile report without this hack was:

  seconds  |    consed   | calls |  sec/call  |  name
---------------------------------------------------------
    46.957 | 147,875,120 |     1 |  46.957000 | TEST-2
    44.244 | 161,921,920 |     1 |  44.244000 | TEST-1


The profiling runs were done with the win32 version of sbcl 1.0.37.12.
The hack is attached at the end of this email and is for the ODBC back-end
of clsql-5.0.2.

Best,

Jason

;;-------------------------------------------------------------------------------------------------------------

(in-package :clsql-sys)

;; new hack
(defvar *map-query-for-effect-row*)

;; replace the old MAP-QUERY-FOR-EFFECT.
(defun map-query-for-effect (function query-expression database result-types)
  (multiple-value-bind (result-set columns)
      (database-query-result-set query-expression database :full-set nil
                                 :result-types result-types)
    (let ((flatp (and (= columns 1)
                      (typep query-expression 'sql-query)
                      (slot-value query-expression 'flatp))))
      (when result-set
        (unwind-protect
	     (let ((*map-query-for-effect-row* (make-list columns)))
	       (do ((row (make-list columns)))
		   ((not (database-store-next-row result-set database row))
		    nil)
		 (if flatp
		     (apply function row)
		     (funcall function row))))
          (database-dump-result-set result-set database))))))

(in-package :odbc-dbi)

;; new hack adapted from DB-FETCH-QUERY-RESULTS.
(defun db-fetch-single-row (query)
  (declare (type odbc-query query)
	   (special clsql-sys::*map-query-for-effect-row*))
  (when (query-active-p query)
    (with-slots (column-data-ptrs column-c-types column-sql-types
                 column-out-len-ptrs column-precisions hstmt
computed-result-types)
        query
      (let ((cols-fetched 0))
	(unless (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)
	  (loop for result-type across computed-result-types
	     for data-ptr across column-data-ptrs
	     for c-type across column-c-types
	     for sql-type across column-sql-types
	     for out-len-ptr across column-out-len-ptrs
	     for precision across column-precisions
	     for j from 0    ; column count is zero based in lisp
	     for rest on clsql-sys::*map-query-for-effect-row*
	     do
	       (setf (car rest)
		     (cond ((< 0 precision (query-width query))
			    (read-data data-ptr c-type sql-type out-len-ptr result-type))
			   ((zerop (get-cast-long out-len-ptr))
			    nil)
			   (t
			    (read-data-in-chunks hstmt j data-ptr c-type sql-type
						 out-len-ptr result-type))))
	       (incf cols-fetched)))
	(values clsql-sys::*map-query-for-effect-row* query cols-fetched)))))

;; replace the old FETCH-ROW.
(defun fetch-row (query &optional (eof-errorp t) eof-value)
  (multiple-value-bind (row query count) (db-fetch-single-row query)
    (cond
     ((zerop count)
      (close-query query)
      (when eof-errorp
        (error 'clsql:sql-database-data-error
               :message "ODBC: Ran out of data in fetch-row"))
      eof-value)
     (t
      row))))