! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.data alien.parser
-alien.strings arrays assocs byte-arrays classes.struct
-combinators continuations cuda.ffi destructors fry io
-io.backend io.encodings.string io.encodings.utf8 kernel lexer
-locals math math.parser namespaces opengl.gl.extensions
-prettyprint quotations sequences ;
+USING: alien.c-types alien.data cuda.ffi kernel ;
+QUALIFIED-WITH: alien.c-types c
IN: cuda
-SYMBOL: cuda-device
-SYMBOL: cuda-context
-SYMBOL: cuda-module
-SYMBOL: cuda-function
-SYMBOL: cuda-launcher
-SYMBOL: cuda-memory-hashtable
+ERROR: cuda-error-state code ;
-ERROR: throw-cuda-error n ;
-
-: cuda-error ( n -- )
- dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
+: cuda-error ( code -- )
+ dup CUDA_SUCCESS = [ drop ] [ cuda-error-state ] if ;
: cuda-version ( -- n )
- int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
+ { c:int } [ cuDriverGetVersion cuda-error ] with-out-parameters ;
: init-cuda ( -- )
- 0 cuInit cuda-error ;
-
-TUPLE: launcher
-{ device integer initial: 0 }
-{ device-flags initial: 0 }
-path block-shape shared-size grid ;
-
-: with-cuda-context ( flags device quot -- )
- [
- [ CUcontext <c-object> ] 2dip
- [ cuCtxCreate cuda-error ] 3keep 2drop *void*
- ] dip
- [ '[ _ @ ] ]
- [ drop '[ _ cuCtxDestroy cuda-error ] ] 2bi
- [ ] cleanup ; inline
-
-: with-cuda-module ( path quot -- )
- [
- normalize-path
- [ CUmodule <c-object> ] dip
- [ cuModuleLoad cuda-error ] 2keep drop *void*
- ] dip
- [ '[ _ @ ] ]
- [ drop '[ _ cuModuleUnload cuda-error ] ] 2bi
- [ ] cleanup ; inline
-
-: with-cuda-program ( flags device path quot -- )
- [ dup cuda-device set ] 2dip
- '[
- cuda-context set
- _ [
- cuda-module set
- _ call
- ] with-cuda-module
- ] with-cuda-context ; inline
-
-: with-cuda ( launcher quot -- )
- [
- init-cuda
- H{ } clone cuda-memory-hashtable
- ] 2dip '[
- _
- [ cuda-launcher set ]
- [ [ device>> ] [ device-flags>> ] [ path>> ] tri ] bi
- _ with-cuda-program
- ] with-variable ; inline
-
-<PRIVATE
-
-: #cuda-devices ( -- n )
- int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
-
-: n>cuda-device ( n -- device )
- [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
-
-: enumerate-cuda-devices ( -- devices )
- #cuda-devices iota [ n>cuda-device ] map ;
-
-: cuda-device-properties ( device -- properties )
- [ CUdevprop <c-object> ] dip
- [ cuDeviceGetProperties cuda-error ] 2keep drop
- CUdevprop memory>struct ;
-
-PRIVATE>
-
-: cuda-devices ( -- assoc )
- enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
-
-: cuda-device-name ( n -- string )
- [ 256 [ <byte-array> ] keep ] dip
- [ cuDeviceGetName cuda-error ]
- [ 2drop utf8 alien>string ] 3bi ;
-
-: cuda-device-capability ( n -- pair )
- [ int <c-object> int <c-object> ] dip
- [ cuDeviceComputeCapability cuda-error ]
- [ drop [ *int ] bi@ ] 3bi 2array ;
-
-: cuda-device-memory ( n -- bytes )
- [ uint <c-object> ] dip
- [ cuDeviceTotalMem cuda-error ]
- [ drop *uint ] 2bi ;
-
-: get-cuda-function* ( module string -- function )
- [ CUfunction <c-object> ] 2dip
- [ cuModuleGetFunction cuda-error ] 3keep 2drop *void* ;
-
-: get-cuda-function ( string -- function )
- [ cuda-module get ] dip get-cuda-function* ;
-
-: with-cuda-function ( string quot -- )
- [
- get-cuda-function cuda-function set
- ] dip call ; inline
-
-: launch-function* ( function -- ) cuLaunch cuda-error ;
-
-: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
-
-: launch-function-grid* ( function width height -- )
- cuLaunchGrid cuda-error ;
-
-: launch-function-grid ( width height -- )
- [ cuda-function get ] 2dip
- cuLaunchGrid cuda-error ;
-
-TUPLE: cuda-memory < disposable ptr length ;
-
-: <cuda-memory> ( ptr length -- obj )
- cuda-memory new-disposable
- swap >>length
- swap >>ptr ;
-
-: add-cuda-memory ( obj -- obj )
- dup dup ptr>> cuda-memory-hashtable get set-at ;
-
-: delete-cuda-memory ( obj -- )
- cuda-memory-hashtable delete-at ;
-
-ERROR: invalid-cuda-memory ptr ;
-
-: cuda-memory-length ( cuda-memory -- n )
- ptr>> cuda-memory-hashtable get ?at [
- length>>
- ] [
- invalid-cuda-memory
- ] if ;
-
-M: cuda-memory byte-length length>> ;
-
-: cuda-malloc ( n -- ptr )
- [ CUdeviceptr <c-object> ] dip
- [ cuMemAlloc cuda-error ] 2keep
- [ *int ] dip <cuda-memory> add-cuda-memory ;
-
-: cuda-free* ( ptr -- )
- cuMemFree cuda-error ;
-
-M: cuda-memory dispose ( ptr -- )
- ptr>> cuda-free* ;
-
-: host>device ( dest-ptr src-ptr -- )
- [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ;
-
-:: device>host ( ptr -- seq )
- ptr byte-length <byte-array>
- [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
-
-: memcpy-device>device ( dest-ptr src-ptr count -- )
- cuMemcpyDtoD cuda-error ;
-
-: memcpy-device>array ( dest-array dest-index src-ptr count -- )
- cuMemcpyDtoA cuda-error ;
-
-: memcpy-array>device ( dest-ptr src-array src-index count -- )
- cuMemcpyAtoD cuda-error ;
-
-: memcpy-array>host ( dest-ptr src-array src-index count -- )
- cuMemcpyAtoH cuda-error ;
-
-: memcpy-host>array ( dest-array dest-index src-ptr count -- )
- cuMemcpyHtoA cuda-error ;
-
-: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
- cuMemcpyAtoA cuda-error ;
-
-: cuda-int* ( function offset value -- )
- cuParamSeti cuda-error ;
-
-: cuda-int ( offset value -- )
- [ cuda-function get ] 2dip cuda-int* ;
-
-: cuda-float* ( function offset value -- )
- cuParamSetf cuda-error ;
-
-: cuda-float ( offset value -- )
- [ cuda-function get ] 2dip cuda-float* ;
-
-: cuda-vector* ( function offset ptr n -- )
- cuParamSetv cuda-error ;
-
-: cuda-vector ( offset ptr n -- )
- [ cuda-function get ] 3dip cuda-vector* ;
-
-: param-size* ( function n -- )
- cuParamSetSize cuda-error ;
-
-: param-size ( n -- )
- [ cuda-function get ] dip param-size* ;
-
-: malloc-device-string ( string -- n )
- utf8 encode
- [ length cuda-malloc ] keep
- [ host>device ] [ drop ] 2bi ;
-
-ERROR: bad-cuda-parameter parameter ;
-
-:: set-parameters ( seq -- )
- cuda-function get :> function
- 0 :> offset!
- seq [
- [ offset ] dip
- {
- { [ dup cuda-memory? ] [ ptr>> cuda-int ] }
- { [ dup float? ] [ cuda-float ] }
- { [ dup integer? ] [ cuda-int ] }
- [ bad-cuda-parameter ]
- } cond
- offset 4 + offset!
- ] each
- offset param-size ;
-
-: cuda-device-attribute ( attribute dev -- n )
- [ int <c-object> ] 2dip
- [ cuDeviceGetAttribute cuda-error ]
- [ 2drop *int ] 3bi ;
-
-: function-block-shape* ( function x y z -- )
- cuFuncSetBlockShape cuda-error ;
-
-: function-block-shape ( x y z -- )
- [ cuda-function get ] 3dip
- cuFuncSetBlockShape cuda-error ;
-
-: function-shared-size* ( function n -- )
- cuFuncSetSharedSize cuda-error ;
-
-: function-shared-size ( n -- )
- [ cuda-function get ] dip
- cuFuncSetSharedSize cuda-error ;
-
-: launch ( -- )
- cuda-launcher get {
- [ block-shape>> first3 function-block-shape ]
- [ shared-size>> function-shared-size ]
- [
- grid>> [
- launch-function
- ] [
- first2 launch-function-grid
- ] if-empty
- ]
- } cleave ;
-
-: cuda-device. ( n -- )
- {
- [ "Device: " write number>string print ]
- [ "Name: " write cuda-device-name print ]
- [ "Memory: " write cuda-device-memory number>string print ]
- [
- "Capability: " write
- cuda-device-capability [ number>string ] map " " join print
- ]
- [ "Properties: " write cuda-device-properties . ]
- [
- "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
- CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
- cuda-device-attribute number>string print
- ]
- } cleave ;
-
-: cuda. ( -- )
- "CUDA Version: " write cuda-version number>string print nl
- #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
-
-
-: test-cuda0 ( -- )
- T{ launcher
- { path "vocab:cuda/hello.ptx" }
- { block-shape { 6 6 6 } }
- { shared-size 2 }
- { grid { 2 6 } }
- } [
- "helloWorld" [
- "Hello World!" [ - ] map-index
- malloc-device-string &dispose
-
- [ 1array set-parameters ]
- [ drop launch ]
- [ device>host utf8 alien>string . ] tri
- ] with-cuda-function
- ] with-cuda ;
+ 0 cuInit cuda-error ; inline
projects / factor.git / blobdiff