2017-08-25 18:34:26 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								! Copyright (C) 2010 Joe Groff.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								USING: alien.c-types alien.data continuations cuda cuda.ffi
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-25 00:38:25 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								cuda.libraries alien.destructors fry kernel namespaces ;
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: cuda.contexts
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-25 00:38:25 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: set-up-cuda-context ( -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    H{ } clone cuda-modules set-global
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    H{ } clone cuda-functions set-global ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: create-context ( device flags -- context )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    swap
							 | 
						
					
						
							
								
									
										
										
										
											2010-12-25 19:54:45 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    [ { CUcontext } ] 2dip
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    '[ _ _ cuCtxCreate cuda-error ] with-out-parameters ; inline
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: sync-context ( -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    cuCtxSynchronize cuda-error ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: context-device ( -- n )
							 | 
						
					
						
							
								
									
										
										
										
											2010-12-25 19:54:45 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    { CUdevice } [ cuCtxGetDevice cuda-error ] with-out-parameters ; inline
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-25 00:38:25 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: clean-up-context ( context -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ sync-context ] ignore-errors destroy-context ; inline
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								DESTRUCTOR: destroy-context
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								DESTRUCTOR: clean-up-context
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: (with-cuda-context) ( context quot -- )
							 | 
						
					
						
							
								
									
										
										
										
											2019-04-22 10:49:05 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    swap '[ _ clean-up-context ] finally ; inline
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-20 17:32:35 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: with-cuda-context ( device flags quot -- )
							 | 
						
					
						
							
								
									
										
										
										
											2010-05-25 00:38:25 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    [ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline
							 |