From f9a8e90c410c3608f6e73d3e80568bedd5bb453a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 14 May 2010 15:59:31 -0700
Subject: [PATCH] cuda: add "cuda.gl" vocab with words for cuda/opengl/gpu
 interop

---
 extra/cuda/cuda.factor       |  9 +++++++--
 extra/cuda/gl/ffi/ffi.factor |  8 ++++++++
 extra/cuda/gl/gl.factor      | 35 +++++++++++++++++++++++++++++++++++
 3 files changed, 50 insertions(+), 2 deletions(-)
 create mode 100644 extra/cuda/gl/ffi/ffi.factor
 create mode 100644 extra/cuda/gl/gl.factor

diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor
index 3b472854b3..893058eec5 100644
--- a/extra/cuda/cuda.factor
+++ b/extra/cuda/cuda.factor
@@ -21,14 +21,19 @@ TUPLE: launcher
 TUPLE: function-launcher
 dim-grid dim-block shared-size stream ;
 
-: with-cuda-context ( flags device quot -- )
+: (set-up-cuda-context) ( flags device create-quot -- )
     H{ } clone cuda-modules set-global
     H{ } clone cuda-functions set
-    [ create-context ] dip 
+    call ; inline
+
+: (with-cuda-context) ( context quot -- )
     [ '[ _ @ ] ]
     [ drop '[ [ sync-context ] ignore-errors _ destroy-context ] ] 2bi
     [ ] cleanup ; inline
 
+: with-cuda-context ( flags device quot -- )
+    [ [ create-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
+
 : with-cuda-program ( flags device quot -- )
     [ dup cuda-device set ] 2dip
     '[ cuda-context set _ call ] with-cuda-context ; inline
diff --git a/extra/cuda/gl/ffi/ffi.factor b/extra/cuda/gl/ffi/ffi.factor
new file mode 100644
index 0000000000..c08ee92a8c
--- /dev/null
+++ b/extra/cuda/gl/ffi/ffi.factor
@@ -0,0 +1,8 @@
+! (c)2010 Joe Groff bsd license
+USING: alien.c-types alien.syntax cuda.ffi opengl.gl ;
+IN: cuda.gl.ffi
+
+FUNCTION: CUresult cuGLCtxCreate ( CUcontext* pCtx, uint Flags, CUdevice device ) ;
+FUNCTION: CUresult cuGraphicsGLRegisterBuffer ( CUgraphicsResource* pCudaResource, GLuint buffer, uint Flags ) ;
+FUNCTION: CUresult cuGraphicsGLRegisterImage ( CUgraphicsResource* pCudaResource, GLuint image, GLenum target, uint Flags ) ;
+
diff --git a/extra/cuda/gl/gl.factor b/extra/cuda/gl/gl.factor
new file mode 100644
index 0000000000..268d270e7f
--- /dev/null
+++ b/extra/cuda/gl/gl.factor
@@ -0,0 +1,35 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.c-types alien.data alien.destructors
+continuations cuda cuda.ffi cuda.gl.ffi cuda.utils destructors
+fry gpu.buffers kernel ;
+IN: cuda.gl
+
+: create-gl-cuda-context ( flags device -- context )
+    [ CUcontext <c-object> ] 2dip
+    [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
+
+: with-gl-cuda-context ( flags device quot -- )
+    [ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline 
+
+: gl-buffer>resource ( gl-buffer flags -- resource )
+    [ CUgraphicsResource <c-object> ] 2dip
+    [ cuGraphicsGLRegisterBuffer cuda-error ] 3keep 2drop *void* ; inline
+
+: buffer>resource ( buffer flags -- resource )
+    [ handle>> ] dip gl-buffer>resource ; inline
+
+: map-resource ( resource -- device-ptr size )
+    [ 1 swap <void*> f cuGraphicsMapResources cuda-error ] [
+        [ CUdeviceptr <c-object> uint <c-object> ] dip
+        [ cuGraphicsResourceGetMappedPointer cuda-error ] 3keep drop
+        [ *uint ] [ *uint ] bi*
+    ] bi ; inline
+
+: unmap-resource ( resource -- )
+    1 swap <void*> f cuGraphicsUnmapResources cuda-error ; inline
+
+DESTRUCTOR: unmap-resource
+
+: with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
+    over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
+