extra/cuda/gl/gl.factor

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