extra/cuda/gl/gl.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.destructors
   3 alien.enums continuations cuda cuda.contexts cuda.ffi
   4 cuda.gl.ffi destructors fry gpu.buffers kernel ;
   5 IN: cuda.gl
   6
   7 : create-gl-cuda-context ( device flags -- context )
   8     swap
   9     [ CUcontext <c-object> ] 2dip
  10     [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
  11
  12 : with-gl-cuda-context ( device flags quot -- )
  13     [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
  14
  15 : gl-buffer>resource ( gl-buffer flags -- resource )
  16     enum>number
  17     [ CUgraphicsResource <c-object> ] 2dip
  18     [ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
  19
  20 : buffer>resource ( buffer flags -- resource )
  21     [ handle>> ] dip gl-buffer>resource ; inline
  22
  23 : map-resource ( resource -- device-ptr size )
  24     [ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
  25         [ CUdeviceptr <c-object> uint <c-object> ] dip
  26         [ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
  27         [ uint deref ] [ uint deref ] bi*
  28     ] bi ; inline
  29
  30 : unmap-resource ( resource -- )
  31     1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
  32
  33 DESTRUCTOR: unmap-resource
  34
  35 : free-resource ( resource -- )
  36     cuGraphicsUnregisterResource cuda-error ; inline
  37
  38 DESTRUCTOR: free-resource
  39
  40 : with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
  41     over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
  42
  43 TUPLE: cuda-buffer
  44     { buffer buffer }
  45     { resource pinned-c-ptr } ;
  46
  47 : <cuda-buffer> ( upload usage kind size initial-data flags -- buffer )
  48     [ <buffer> dup ] dip buffer>resource cuda-buffer boa ; inline
  49
  50 M: cuda-buffer dispose
  51     [ [ free-resource ] when* f ] change-resource
  52     buffer>> dispose ; inline
  53
  54 : with-mapped-cuda-buffer ( ..a cuda-buffer quot: ( ..a device-ptr size -- ..b ) -- ..b )
  55     [ resource>> ] dip with-mapped-resource ; inline