1 ! Copyright (C) 2010 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.data alien.parser alien.strings
4 alien.syntax arrays assocs byte-arrays classes.struct
5 combinators continuations cuda.ffi cuda.memory cuda.utils
6 destructors fry init io io.backend io.encodings.string
7 io.encodings.utf8 kernel lexer locals macros math math.parser
8 namespaces opengl.gl.extensions parser prettyprint quotations
9 sequences words cuda.libraries ;
10 QUALIFIED-WITH: alien.c-types c
14 { device integer initial: 0 }
15 { device-flags initial: 0 } ;
17 : <launcher> ( device-id -- launcher )
19 swap >>device ; inline
21 TUPLE: function-launcher
22 dim-grid dim-block shared-size stream ;
24 : with-cuda-context ( flags device quot -- )
25 H{ } clone cuda-modules set-global
26 H{ } clone cuda-functions set
27 [ create-context ] dip
29 [ drop '[ _ destroy-context ] ] 2bi
32 : with-cuda-program ( flags device quot -- )
33 [ dup cuda-device set ] 2dip
34 '[ cuda-context set _ call ] with-cuda-context ; inline
36 : with-cuda ( launcher quot -- )
39 [ [ device>> ] [ device-flags>> ] bi ] bi
40 ] [ with-cuda-program ] bi* ; inline
42 : c-type>cuda-setter ( c-type -- n cuda-type )
44 { [ dup c:int = ] [ drop 4 [ cuda-int* ] ] }
45 { [ dup c:uint = ] [ drop 4 [ cuda-int* ] ] }
46 { [ dup c:float = ] [ drop 4 [ cuda-float* ] ] }
47 { [ dup c:pointer? ] [ drop 4 [ cuda-int* ] ] }
48 { [ dup c:void* = ] [ drop 4 [ cuda-int* ] ] }
52 : block-dim ( block -- x y z )
53 dup sequence? [ 3 1 pad-tail first3 ] [ 1 1 ] if ; inline
54 : grid-dim ( block -- x y )
55 dup sequence? [ 2 1 pad-tail first2 ] [ 1 ] if ; inline
58 : run-function-launcher ( function-launcher function -- )
61 [ dim-block>> block-dim function-block-shape* ]
62 [ shared-size>> function-shared-size* ]
65 [ grid-dim launch-function-grid* ]
66 [ launch-function* ] if*
70 : cuda-argument-setter ( offset c-type -- offset' quot )
72 [ over [ + ] dip ] dip
73 '[ swap _ swap _ call ] ;
75 MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
76 [ 0 ] dip [ cuda-argument-setter ] map reverse
77 swap '[ _ param-size* ] suffix
80 : define-cuda-word ( word module-name function-name arguments -- )
84 [ nip _ cuda-arguments ]
85 [ run-function-launcher ] 2bi
88 [ 2nip \ function-launcher suffix c:void function-effect ]