[Openmcl-devel] non-consing short float trap parameters

[james anderson]

hello;

i am working to make some graphics code cons less.
in general, i can get through a transformation pipeline w/o consing,  
but when i get to the bottom, calls through the respective graphic  
system's interface tend to generate gratuitous garbage.

the pipeline works with resourced double-float vectors and matrices.
in the case of open-gl, which accept doubles, i can get the location  
coordiantes through the interface for free by simply indirecting  
through stacked double floats with dynamic extent.
short floats, which core graphics likes, are a different story

mr altosaar's recent enquiries about mach-o traps caused me to look  
again at the interface to core-graphics. the enclosed macro,  
auxiliary function, and example graphics operator show what i found  
to be necessary to get short floats out of simple double-float  
vectors and through a trap call without consing.

i have two questions

?1 for mcl, are all these contortions really necessary?
for doubles, i observer that (setf <stacked-double>  (aref <simple  
double vector> i)) is space-free, but the same does not apply to a  
double-to-short transfer.
it would be really nice to be able to expect (setf <y> (float <x>  
<type>)) to be coded inline and without consing for dynamic extent  
targets, but i found no other combination, than that which follows,  
which would move the bits for free.

?2, for open-mcl, i note that this is code from mcl-5.1, but ask  
whether the same situation applies to open-mcl.

------------------------

(defvar *location-vector-type*
       (type-of (make-array 4 :initial-element 0.0d0 :element-type  
'double-float)))
(deftype short-location-vector ()
       "a (4) short float simple array intended to hold location  
coordinates."
       *short-location-vector-type*)
;;; analogous definitions for short location vectors
(ccl:defrecord :single-float-coordinate
   (:float :single-float :default 0.0s0))

(defun %copy-location-to-short-coordinates (location x y &optional z h)
   (declare (type short-float x y))
   (let ((tmp-double 0.0d0)
         (tmp-short 0.0s0))
     (declare (dynamic-extent tmp-double tmp-short)
              (type double-float tmp-double)
              (type short-float tmp-short))
     (rlet ((%tmp-single-coordinate :single-float-coordinate))
       (ecase (array-element-type location)
         (double-float
          (locally (declare (type location-vector location))
            (setf tmp-double (aref location 0))
            (ccl::%set-ieee-single-float-from-double tmp-double %tmp- 
single-coordinate)
            (ccl::%ref-ieee-single-float %tmp-single-coordinate x)
            (setf tmp-double (aref location 1))
            (ccl::%set-ieee-single-float-from-double tmp-double %tmp- 
single-coordinate)
            (ccl::%ref-ieee-single-float %tmp-single-coordinate y)
            (when z
              (locally (declare (type short-float z))
                (setf tmp-double (aref location 2))
                (ccl::%set-ieee-single-float-from-double tmp-double % 
tmp-single-coordinate)
                (ccl::%ref-ieee-single-float %tmp-single-coordinate z))
              (when h
                (locally (declare (type short-float h))
                  (setf tmp-double (aref location 3))
                  (ccl::%set-ieee-single-float-from-double tmp-double  
%tmp-single-coordinate)
                  (ccl::%ref-ieee-single-float %tmp-single-coordinate  
h))))))
         (short-float
          (locally (declare (type short-location-vector location))
            (setf tmp-short (aref location 0))
            (ccl::%set-ieee-single-float tmp-short %tmp-single- 
coordinate)
            (ccl::%ref-ieee-single-float %tmp-single-coordinate x)
            (setf tmp-short (aref location 1))
            (ccl::%set-ieee-single-float tmp-short %tmp-single- 
coordinate)
            (ccl::%ref-ieee-single-float %tmp-single-coordinate y)
            (when z
              (locally (declare (type short-float z))
                (setf tmp-short (aref location 2))
                (ccl::%set-ieee-single-float tmp-short %tmp-single- 
coordinate)
                (ccl::%ref-ieee-single-float %tmp-single-coordinate z))
              (when h
                (locally (declare (type short-float h))
                  (setf tmp-short (aref location 3))
                  (ccl::%set-ieee-single-float tmp-short %tmp-single- 
coordinate)
                  (ccl::%ref-ieee-single-float %tmp-single-coordinate  
h))))))))))

(defmacro with-short-location-coordinates (bindings &rest body)
   "establish dynamic bindings for the components of a location- 
vector as short
    floats."
   (let ((short-variables nil))
     `(let ,(reduce #'append
                    (mapcar #'(lambda (binding)
                                (destructuring-bind (location &rest  
coordinates) binding
                                  (declare (ignore location))
                                  (mapcar #'(lambda (name)
                                              (push name short- 
variables)
                                              `(,name 0.0s0))
                                          coordinates)))
                            bindings))
        (declare (type short-float ,@(reverse short-variables))
                 (dynamic-extent ,@(reverse short-variables)))
        ,@(remove nil (mapcar #'(lambda (binding)
                                  (cons '%copy-location-to-short- 
coordinates binding))
                              bindings))
        , at body)))

(defun core-graphics-line-ndc (cgcontextref l1 l2 properties)
   "draw a line given the ndc endpoints"
   (declare (type location-vector l1 l2))
   #+og.assert-types (progn (assert-type cgcontextref cgcontextref)
                            (assert-types (l1 l2) location-vector)
                            (assert-type properties sequence))
   (with-short-location-coordinates ((l1 x1 y1) (l2 x2 y2))
     (#_CGContextBeginPath cgcontextref)
     (#_CGContextMoveToPoint cgcontextref x1 y1)
     (#_CGContextAddLineToPoint cgcontextref x2 y2)
     ;; don't close a line (#_CGContextClosePath cgcontextref)
     (flet ((line-geometry ()
              (#_CGContextDrawPath cgcontextref *core-graphics-path- 
drawing-mode-value*)))
       (declare (dynamic-extent #'line-geometry))
       (call-with-projection-variables #'line-geometry properties))))


whereby the
    (with-short-location-coordinates ((l1 x1 y1) (l2 x2 y2))
       ...  )

expands to
   (LET ((X1 0.0S0) (Y1 0.0S0) (X2 0.0S0) (Y2 0.0S0))
     (DECLARE (TYPE SHORT-FLOAT X1 Y1 X2 Y2) (DYNAMIC-EXTENT X1 Y1 X2  
Y2))
     (%COPY-LOCATION-TO-SHORT-COORDINATES L1 X1 Y1)
     (%COPY-LOCATION-TO-SHORT-COORDINATES L2 X2 Y2)
     ...    )

...