cuda: more API cleanups:
- remove useless with-cuda and with-cuda-program combinators - eliminate redundant cuda-device, cuda-context variables - rearrange arguments of with-*cuda-context to ( device flags quot -- ) - don't pass context to with-cuda-context quot - add context-device word to ask for current devicedb4
							parent
							
								
									5c0c87fcaa
								
							
						
					
					
						commit
						22e853ecb0
					
				| 
						 | 
				
			
			@ -10,40 +10,20 @@ sequences words cuda.libraries ;
 | 
			
		|||
QUALIFIED-WITH: alien.c-types c
 | 
			
		||||
IN: cuda
 | 
			
		||||
 | 
			
		||||
TUPLE: launcher
 | 
			
		||||
{ device integer initial: 0 }
 | 
			
		||||
{ device-flags initial: 0 } ;
 | 
			
		||||
 | 
			
		||||
: <launcher> ( device-id -- launcher )
 | 
			
		||||
    launcher new
 | 
			
		||||
        swap >>device ; inline
 | 
			
		||||
 | 
			
		||||
TUPLE: function-launcher
 | 
			
		||||
dim-grid dim-block shared-size stream ;
 | 
			
		||||
 | 
			
		||||
: (set-up-cuda-context) ( flags device create-quot -- )
 | 
			
		||||
: (set-up-cuda-context) ( device flags create-quot -- )
 | 
			
		||||
    H{ } clone cuda-modules set-global
 | 
			
		||||
    H{ } clone cuda-functions set
 | 
			
		||||
    call ; inline
 | 
			
		||||
 | 
			
		||||
: (with-cuda-context) ( context quot -- )
 | 
			
		||||
    [ '[ _ @ ] ]
 | 
			
		||||
    [ drop '[ [ sync-context ] ignore-errors _ destroy-context ] ] 2bi
 | 
			
		||||
    [ ] cleanup ; inline
 | 
			
		||||
    swap '[ [ sync-context ] ignore-errors _ destroy-context ] [ ] cleanup ; inline
 | 
			
		||||
 | 
			
		||||
: with-cuda-context ( flags device quot -- )
 | 
			
		||||
: with-cuda-context ( device flags 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
 | 
			
		||||
 | 
			
		||||
: with-cuda ( launcher quot -- )
 | 
			
		||||
    init-cuda [
 | 
			
		||||
        [ cuda-launcher set ]
 | 
			
		||||
        [ [ device>> ] [ device-flags>> ] bi ] bi
 | 
			
		||||
    ] [ with-cuda-program ] bi* ; inline
 | 
			
		||||
 | 
			
		||||
: c-type>cuda-setter ( c-type -- n cuda-type )
 | 
			
		||||
    {
 | 
			
		||||
        { [ dup c:int = ] [ drop 4 [ cuda-int* ] ] }
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -11,9 +11,10 @@ CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
 | 
			
		|||
CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
 | 
			
		||||
 | 
			
		||||
: cuda-hello-world ( -- )
 | 
			
		||||
    init-cuda
 | 
			
		||||
    [
 | 
			
		||||
        [
 | 
			
		||||
            cuda-launcher get device>> number>string
 | 
			
		||||
            context-device number>string
 | 
			
		||||
            "CUDA device " ": " surround write
 | 
			
		||||
            "Hello World!" >byte-array [ - ] map-index host>device &cuda-free
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -8,9 +8,8 @@ CUDA-LIBRARY: prefix-sum vocab:cuda/demos/prefix-sum/prefix-sum.ptx
 | 
			
		|||
CUDA-FUNCTION: prefix_sum_block ( uint* in, uint* out, uint n ) ;
 | 
			
		||||
 | 
			
		||||
:: cuda-prefix-sum ( -- )
 | 
			
		||||
    T{ launcher { device 0 } }
 | 
			
		||||
    [
 | 
			
		||||
    0 0 [
 | 
			
		||||
        ! { 1 1 1 } { 2 1 } 0 3<<< prefix_sum_block
 | 
			
		||||
    ] with-cuda ;
 | 
			
		||||
    ] with-cuda-context ;
 | 
			
		||||
 | 
			
		||||
MAIN: cuda-prefix-sum
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -16,7 +16,7 @@ IN: cuda.devices
 | 
			
		|||
    #cuda-devices iota [ n>cuda-device ] map ;
 | 
			
		||||
 | 
			
		||||
: with-each-cuda-device ( quot -- )
 | 
			
		||||
    [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
 | 
			
		||||
    [ enumerate-cuda-devices ] dip '[ 0 _ with-cuda-context ] each ; inline
 | 
			
		||||
 | 
			
		||||
: cuda-device-properties ( n -- properties )
 | 
			
		||||
    [ CUdevprop <struct> ] dip
 | 
			
		||||
| 
						 | 
				
			
			@ -81,6 +81,6 @@ IN: cuda.devices
 | 
			
		|||
    grid-size block-size per-block-shared ; inline
 | 
			
		||||
 | 
			
		||||
: distribute-jobs ( job-count per-job-shared -- launcher )
 | 
			
		||||
    cuda-device get cuda-device-properties 
 | 
			
		||||
    context-device cuda-device-properties 
 | 
			
		||||
    [ sharedMemPerBlock>> ] [ maxThreadsDim>> first ] bi
 | 
			
		||||
    (distribute-jobs) 3<<< ; inline
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -4,11 +4,12 @@ continuations cuda cuda.ffi cuda.gl.ffi cuda.utils destructors
 | 
			
		|||
fry gpu.buffers kernel ;
 | 
			
		||||
IN: cuda.gl
 | 
			
		||||
 | 
			
		||||
: create-gl-cuda-context ( flags device -- context )
 | 
			
		||||
: create-gl-cuda-context ( device flags -- context )
 | 
			
		||||
    swap
 | 
			
		||||
    [ CUcontext <c-object> ] 2dip
 | 
			
		||||
    [ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
 | 
			
		||||
 | 
			
		||||
: with-gl-cuda-context ( flags device quot -- )
 | 
			
		||||
: with-gl-cuda-context ( device flags quot -- )
 | 
			
		||||
    [ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline 
 | 
			
		||||
 | 
			
		||||
: gl-buffer>resource ( gl-buffer flags -- resource )
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -6,11 +6,8 @@ io io.backend io.encodings.utf8 kernel math.parser namespaces
 | 
			
		|||
prettyprint sequences ;
 | 
			
		||||
IN: cuda.utils
 | 
			
		||||
 | 
			
		||||
SYMBOL: cuda-device
 | 
			
		||||
SYMBOL: cuda-context
 | 
			
		||||
SYMBOL: cuda-module
 | 
			
		||||
SYMBOL: cuda-function
 | 
			
		||||
SYMBOL: cuda-launcher
 | 
			
		||||
 | 
			
		||||
SYMBOL: cuda-modules
 | 
			
		||||
SYMBOL: cuda-functions
 | 
			
		||||
| 
						 | 
				
			
			@ -38,13 +35,17 @@ ERROR: throw-cuda-error n ;
 | 
			
		|||
        get-function-ptr* cuda-function set
 | 
			
		||||
    ] dip call ; inline
 | 
			
		||||
 | 
			
		||||
: create-context ( flags device -- context )
 | 
			
		||||
: create-context ( device flags -- context )
 | 
			
		||||
    swap
 | 
			
		||||
    [ CUcontext <c-object> ] 2dip
 | 
			
		||||
    [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
 | 
			
		||||
 | 
			
		||||
: sync-context ( -- )
 | 
			
		||||
    cuCtxSynchronize cuda-error ; inline
 | 
			
		||||
 | 
			
		||||
: context-device ( -- n )
 | 
			
		||||
    CUdevice <c-object> [ cuCtxGetDevice cuda-error ] keep *int ; inline
 | 
			
		||||
 | 
			
		||||
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
 | 
			
		||||
 | 
			
		||||
: launch-function* ( function -- ) cuLaunch cuda-error ; inline
 | 
			
		||||
| 
						 | 
				
			
			@ -95,3 +96,4 @@ ERROR: throw-cuda-error n ;
 | 
			
		|||
: function-shared-size ( n -- )
 | 
			
		||||
    [ cuda-function get ] dip
 | 
			
		||||
    cuFuncSetSharedSize cuda-error ; inline
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue