CLIM mail archive
[Prev][Next][Index][Thread]

Super quick attempt at recycling output-records, any takers!

This is mainly for the CLIM wizards out there (mainly to think about the
capability for recycling output-records, rather than relying on the ole
gc of catching them)!  In my case I typically generate and throw away
hundreds to thousands each time I regenerate my display ala scaling or
panning by my own means (no incremental redisplay here)!

Below is some of the clim internal code I massaged quickly that allows
recycling of output-records (at least linear-output-records in my case)! I'm
sure that this code is poorly done and is probably not generic
(mainly because of no doc or real understanding of it), but it seems to work
for me.  If any of you CLIM wizards out there wish to refine this, a lot of
CLIM users would sure love this capability! This is only useful if YOU control
the output-record history tree directly (ala you have to insure that children
records are put on the recycle pile before the parents)!

The code works for me in the following brain-dead manner:

If you constantly throw away records to some recycle list like:

(get 'clim::linear-output-record 'old-output-records)

You can output stuff to your non-recording display in the following dumb
manner:

(let ((record (pop (get 'clim::linear-output-record 'old-output-records)))))
  (setf my-record
	(cond (record (clim::recycle-record (stream record)
					(with-output-as-presentation (...)
					   (draw ....))))
	      (t (with-output-to-output-record (stream)  ;no record to reuse
		     (with-output-as-presentation (...)
		        (draw ....))))))   ;exactly same as for recycle-record
  (add-output-record-element my-records-parent my-record)
  (replay my-record stream)

When you want to trash the record, just do the following besides erasing it:

    (push my-record (get 'clim::linear-output-record 'old-output-records))


Below is the recycle stuff, that I quickly massaged from the
with-new-output-record macros.

;;; -*- Mode: Common-Lisp; Package: Clim -*-

(in-package clim)

(defmacro Cycle-Output-Record
    ((stream old-record &optional record-type record &rest init-args) &body body)
  #+Genera (declare (zwei:indentation 0 3 1 1))
  (default-output-stream stream)
  ;; --- validate protocol here.
  `(with-output-recording-options (,stream :draw-p nil :record-p t)
     (letf-globally (((output-recording-stream-current-output-record-stack ,stream) nil)
		     ((output-recording-stream-output-record ,stream) nil)
		     ((output-recording-stream-text-output-record ,stream) nil))
		    (with-possibly-old-output-record (,stream ,old-record ,record-type ,record ,@init-args)
		      (with-stream-cursor-position-saved (,stream)
			,@body)))))

;This turkey probably has more junk than necessary, but I was not sure what
;to throw away from with-new-output-record!

(defmacro with-possibly-old-output-record
    ((stream old-record &optional record-type record &rest init-args)
     &body body &environment env)
  #+Genera (declare (zwei:indentation 0 3 1 1))
  (unless record-type
    (setq record-type `'linear-output-record))
  (let ((constructor nil) (ignore-record nil))
    (when (and (constantp record-type #+(or Genera Minima) env)
	       (setq constructor
		 (gethash (eval record-type) *output-record-constructor-cache*))))
    (unless record
      (setq record '#:record
	    ignore-record t))
    `(flet ((with-new-output-record-body (,record)
	      ,@(when ignore-record `((declare (ignore ,record))))
	      ,@body))
       (with-old-output-record-internal		  
	   #'with-new-output-record-body
	 ,stream ,old-record ',constructor ,@init-args))))


;My own recycled copy from with-new-output-record-internal. Again there
;is probably more crap here than what I need!

(defun with-old-output-record-internal (continuation stream old-record constructor
					&rest init-args &key parent &allow-other-keys)
  (declare (dynamic-extent init-args))
  (with-rem-keywords (init-args init-args '(:parent))
    (let* ((current-output-record (output-recording-stream-current-output-record-stack stream)))
      (multiple-value-bind (cursor-x cursor-y)
	  (stream-cursor-position* stream)
	(declare (fixnum cursor-x cursor-y))
	(multiple-value-bind (x y)
	    (multiple-value-bind (px py)
		(point-position*
		  (output-recording-stream-output-record-absolute-position stream))
	      (declare (fixnum px py))
	      (position-difference* cursor-x cursor-y px py))
	  (declare (fixnum x y))
	  (clear-output-record old-record)
	  (output-record-set-start-position* old-record x y)
	  (with-output-record-internal continuation stream old-record
				       cursor-x cursor-y)
	  ;; We set the parent after doing everything else so that calls
	  ;; to RECOMPUTE-CONTENTS-OK inside the dynamic extent of the
	  ;; continuation won't take forever.
	  (let ((parent (or parent
			    current-output-record
			    (output-recording-stream-output-record stream))))
	    (when parent (add-output-record-element parent old-record)))
	  old-record)))))


0,,
Main Index | Thread Index