How to detect if a program has been compiled using -threaded? - haskell

I'm working on a Haskell daemon that uses POSIX fork/exec together with file locking mechanism. My experiments show that file locks aren't inherited during executeFile with -threaded runtime (see also this thread), no matter if I use +RTS -N or not. So I'd like to add a check to be sure that the daemon ins't compiled with -threaded. Is there a portable way to detect it?

There is a value in Control.Concurrent for this, for example:
module Main (main) where
import Control.Concurrent
main :: IO ()
main = print rtsSupportsBoundThreads
And test:
$ ghc -fforce-recomp Test.hs; ./Test
[1 of 1] Compiling Main ( Test.hs, Test.o )
Linking Test ...
False
$ ghc -fforce-recomp -threaded Test.hs; ./Test
[1 of 1] Compiling Main ( Test.hs, Test.o )
Linking Test ...
True
And it's C-part source code:
HsBool
rtsSupportsBoundThreads(void)
{
#if defined(THREADED_RTS)
return HS_BOOL_TRUE;
#else
return HS_BOOL_FALSE;
#endif
}

This is a dirty hack and might be not portable but I can confirm it works for ghc-7.6.3 on linux:
isThreaded :: IO (Maybe Bool)
isThreaded = do
tid <- forkIO $ threadDelay 1000000
yield
stat <- threadStatus tid
killThread tid
case stat of
ThreadBlocked BlockedOnMVar -> return (Just True)
ThreadBlocked BlockedOnOther -> return (Just False)
_ -> return Nothing
See BlockedOnOther docstring for details.

Related

Running a custom per-component `IO ()` before building components, interleaved with actual building

I have a per-component custom action that I would like to run before the given component is built:
justBeforeBuilding :: LocalBuildInfo -> BuildFlags -> Component -> IO BuildInfo
Because the action might require dependencies to be already built, for example, if a given Cabal package has both a library and executables using that library, it is important that each component's justBeforeBuilding is run only before the actual component is built, but after all its dependencies are built.
So here's what I tried: instead of calling the default build hook once, I go over all enabled components one by one in dependency order, call my justBeforeBuilding function, and then sneakily change the buildArgs so that the default build hook would only build the single current component:
restrictBuildFlags :: PackageDescription -> Component -> BuildFlags -> BuildFlags
restrictBuildFlags pkg c buildFlags = buildFlags
{ buildArgs = selectedArgs
}
where
selectedArgs = [showBuildTarget (packageId pkg) $ BuildTargetComponent $ componentName c]
type BuildHook = PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
myBuildHook :: BuildHook -> BuildHook
myBuildHook nextBuildHook pkg lbi userHooks flags = do
let reqSpec = componentEnabledSpec lbi
withAllComponentsInBuildOrder pkg lbi $ \c clbi -> do
flags <- return $ restrictBuildFlags pkg c flags
when (componentEnabled reqSpec c && not (null $ buildArgs flags)) $ do
justBeforeBuilding lbi flags c
nextBuildHook pkg lbi userHooks flags
main :: IO ()
main = defaultMainWithHooks simpleUserHooks
{ buildHook = myBuildHook $ buildHook simpleUserHooks
}
The problem is that when justBeforeBuilding runs, it does not have access to library dependencies even if they are already built by that point. To demonstrate, here's a function that prints the contents of the Cabal-provided package DBs:
justBeforeBuilding :: LocalBuildInfo -> BuildFlags -> Component -> IO ()
justBeforeBuilding lbi flags c = do
pkgdbs <- absolutePackageDBPaths $ withPackageDB lbi
let dbpaths = nub . sort $ [ path | SpecificPackageDB path <- pkgdbs ]
dbflags = concat [ ["-package-db", path] | path <- dbpaths ]
putStrLn $ "!!! Processing component " <> show (componentName c)
putStrLn "!!! At this point, the package DB paths are:"
forM_ dbpaths $ \dir -> do
putStrLn dir
files <- listDirectory dir
mapM_ (printf " %s\n") files
For testing, I am using a Cabal package with one library and one exe; in HPack format:
name: cabal-component-hook
version: 0.1.0
custom-setup:
dependencies:
- base
- Cabal
- directory
dependencies:
- base >= 4.7 && < 5
library:
source-dirs: lib
exposed-modules:
- Foo
executables:
bar:
source-dirs: app
main: bar.hs
dependencies:
- cabal-component-hook
If I then do a stack build, first, the library is built, and the package DB of course doesn't contain the library yet:
!!! Processing component CLibName LMainLibName
!!! At this point, the package DB paths are:
/home/cactus/prog/clash/bugs/cabal-component-hook/.stack-work/install/x86_64-linux-tinfo6/82781a0829e0e0da301c1db4825858dea8980a6a982b679eb178870c6c0ec1ee/8.10.4/pkgdb
package.cache.lock
package.cache
/home/cactus/sdk/stack/snapshots/x86_64-linux-tinfo6/82781a0829e0e0da301c1db4825858dea8980a6a982b679eb178870c6c0ec1ee/8.10.4/pkgdb
package.cache.lock
StateVar-1.2.1-7vo3tV8mPssJqOV48TU4OF.conf
call-stack-0.2.0-4YzMVPI02PxAK0TxyBY7Iv.conf
cabal-doctest-1.0.8-I4vvWDvrsGA6v5uZj1lZJi.conf
base-orphans-0.8.4-JVJ8ttw51H7Dc3tJYgx6uK.conf
parallel-3.2.2.0-HTf2o2horULDwL7cXUB9uv.conf
hashable-1.3.0.0-K3FFBNAmsvaIvBv4Qg15rQ.conf
semigroups-0.19.1-CdJZL8lQRXTEuOuxFhFNIa.conf
contravariant-1.5.3-A4NbUFeaP6W4UzkL1ejoXa.conf
indexed-traversable-0.1.1-Dw8MIJyvCj8IZQDXOa8TBp.conf
tagged-0.8.6.1-A3E8I7zg2qBFE9O5vQsg6C.conf
void-0.7.3-FJLCa6y31Qt20kSi8TCcBC.conf
transformers-compat-0.6.6-CZr4aajtyBTi4Enjszw8H.conf
reflection-2.1.6-CzOlI803nFuvt8AikdOut.conf
distributive-0.6.2.1-Lhog8B4NdHk7JJdshqpkhJ.conf
transformers-base-0.4.5.2-2JwY8UMK4YFHH9faaNEDAI.conf
th-abstraction-0.4.2.0-CPMLTlyMgmr6dbHxHL95CG.conf
comonad-5.0.8-EA0Scey7jOW6LX5RvNTIb8.conf
primitive-0.7.1.0-Jxsyd70oUttYiCXCa0HqV.conf
unordered-containers-0.2.13.0-3awuPgUx2yvAACRZkw6am3.conf
bifunctors-5.5.10-1Xyw3zBBKdPGoolSEEYrSo.conf
profunctors-5.5.2-Jd7sxJvE4zaBkftBvoi6oJ.conf
semigroupoids-5.3.5-A5MCqcbuwFnHzZu6aqZxm4.conf
invariant-0.5.4-Ca6182XTMBJ4627vLKNFdU.conf
free-5.1.5-JCTHYv08sV0j7gsEXshfc.conf
adjunctions-4.4-4Q0IXuLBVoCBKmI2ZpS7bE.conf
kan-extensions-5.2.2-Z55rpCSAQY7rC9ino1jlr.conf
vector-0.12.1.2-6jlbObSa8iuJfxUVGBQC5r.conf
lens-4.19.2-86eTsWPqcVQ3qs5KiS7cYu.conf
package.cache
Preprocessing library for cabal-component-hook-0.1.0..
Building library for cabal-component-hook-0.1.0..
[1 of 2] Compiling Foo
[2 of 2] Compiling Paths_cabal_component_hook
However, then the executable is built, and the package DB still doesn't contain the just-built library:
!!! Processing component CExeName (UnqualComponentName "bar")
!!! At this point, the package DB paths are:
/home/cactus/prog/clash/bugs/cabal-component-hook/.stack-work/install/x86_64-linux-tinfo6/82781a0829e0e0da301c1db4825858dea8980a6a982b679eb178870c6c0ec1ee/8.10.4/pkgdb
package.cache.lock
package.cache
/home/cactus/sdk/stack/snapshots/x86_64-linux-tinfo6/82781a0829e0e0da301c1db4825858dea8980a6a982b679eb178870c6c0ec1ee/8.10.4/pkgdb
package.cache.lock
StateVar-1.2.1-7vo3tV8mPssJqOV48TU4OF.conf
call-stack-0.2.0-4YzMVPI02PxAK0TxyBY7Iv.conf
cabal-doctest-1.0.8-I4vvWDvrsGA6v5uZj1lZJi.conf
base-orphans-0.8.4-JVJ8ttw51H7Dc3tJYgx6uK.conf
parallel-3.2.2.0-HTf2o2horULDwL7cXUB9uv.conf
hashable-1.3.0.0-K3FFBNAmsvaIvBv4Qg15rQ.conf
semigroups-0.19.1-CdJZL8lQRXTEuOuxFhFNIa.conf
contravariant-1.5.3-A4NbUFeaP6W4UzkL1ejoXa.conf
indexed-traversable-0.1.1-Dw8MIJyvCj8IZQDXOa8TBp.conf
tagged-0.8.6.1-A3E8I7zg2qBFE9O5vQsg6C.conf
void-0.7.3-FJLCa6y31Qt20kSi8TCcBC.conf
transformers-compat-0.6.6-CZr4aajtyBTi4Enjszw8H.conf
reflection-2.1.6-CzOlI803nFuvt8AikdOut.conf
distributive-0.6.2.1-Lhog8B4NdHk7JJdshqpkhJ.conf
transformers-base-0.4.5.2-2JwY8UMK4YFHH9faaNEDAI.conf
th-abstraction-0.4.2.0-CPMLTlyMgmr6dbHxHL95CG.conf
comonad-5.0.8-EA0Scey7jOW6LX5RvNTIb8.conf
primitive-0.7.1.0-Jxsyd70oUttYiCXCa0HqV.conf
unordered-containers-0.2.13.0-3awuPgUx2yvAACRZkw6am3.conf
bifunctors-5.5.10-1Xyw3zBBKdPGoolSEEYrSo.conf
profunctors-5.5.2-Jd7sxJvE4zaBkftBvoi6oJ.conf
semigroupoids-5.3.5-A5MCqcbuwFnHzZu6aqZxm4.conf
invariant-0.5.4-Ca6182XTMBJ4627vLKNFdU.conf
free-5.1.5-JCTHYv08sV0j7gsEXshfc.conf
adjunctions-4.4-4Q0IXuLBVoCBKmI2ZpS7bE.conf
kan-extensions-5.2.2-Z55rpCSAQY7rC9ino1jlr.conf
vector-0.12.1.2-6jlbObSa8iuJfxUVGBQC5r.conf
lens-4.19.2-86eTsWPqcVQ3qs5KiS7cYu.conf
package.cache
Preprocessing library for cabal-component-hook-0.1.0..
Building library for cabal-component-hook-0.1.0..
Preprocessing executable 'bar' for cabal-component-hook-0.1.0..
Building executable 'bar' for cabal-component-hook-0.1.0..
[1 of 2] Compiling Main
[2 of 2] Compiling Paths_cabal_component_hook
Linking .stack-work/dist/x86_64-linux-tinfo6/Cabal-3.2.1.0/build/bar/bar ...
At the end of this whole process, though the package DB directory is correctly populated:
/home/cactus/prog/clash/bugs/cabal-component-hook/.stack-work/install/x86_64-linux-tinfo6/82781a0829e0e0da301c1db4825858dea8980a6a982b679eb178870c6c0ec1ee/8.10.4/pkgdb
├── cabal-component-hook-0.1.0-8kPvy0LMfqKAbvXmH5zWaP.conf
├── package.cache
└── package.cache.lock
So my question is, how can I arrange for justBeforeBuilding to run just before building each individual component, when its dependencies are already fully processed, i.e. library dependencies are copied to the build-internal package DB?
It turns out I was on the right track, except I also need to include the so-called internal package DB in the list of package DBs. Distribution.Simple.Build exports a function called createInternalPackageDB, which, unfortunately, we can't use wholesale (since it deletes and re-initializes the internal package DB, in effect deleting the build outputs of previous components); but we can duplicate its behaviour:
justBeforeBuilding :: LocalBuildInfo -> BuildFlags -> Component -> IO ()
justBeforeBuilding lbi flags c = do
pkgdb0 <- do
let dbPath = internalPackageDBPath lbi distPref
existsAlready <- doesPackageDBExist dbPath
unless existsAlready $ do
createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
return $ SpecificPackageDB dbPath
pkgdbs <- absolutePackageDBPaths $ withPackageDB lbi
let dbpaths = nub . sort $ [ path | SpecificPackageDB path <- pkgdb0:pkgdbs ]
... -- Here we can proceed as before and things work out
where
verbosity = fromFlagOrDefault normal (buildVerbosity flags)
distPref = fromFlag (buildDistPref flags)

How do I use the output of a program from an earlier part of a Stack/Cabal build as source in a later part of the same build?

I have a very peculiar dependency situation that I would like to package up in a single Stack/Cabal package: I need to build and run my program to get the input to a code-generator which produces output that needs to be linked in to... my program.
OK so in more concrete terms, here are the steps manually:
stack build to install all dependencies, and build all non-Verilator-using executables.
stack exec phase1 to run the first phase which generates, among other things, a Verilog file and a Clash .manifest file.
I have a custom source generator, which consumes the .manifest file from step 2, and produces C++ code and a Makefile that can be used to drive Verilator.
Run the Makefile generated in step 3:
It runs Verilator on the Verilog sources from step 2, which produces more C++ source code and a new Makefile
Then it runs the newly generated second Makefile, which produces a binary library
stack build --flag phase2 builds the second executable. This executable includes .hsc files that process headers produced in step 2, and it links to the C++ libraries produced in step 4/2.
I would like to automate this so that I can just run stack build and all this would happen behind the scenes. Where do I even start?!
To illustrate the whole process, here is a self-contained model:
package.yaml
name: clashilator-model
version: 0
category: acme
dependencies:
- base
- directory
source-dirs:
- src
flags:
phase2:
manual: True
default: False
executables:
phase1:
main: phase1.hs
phase2:
main: phase2.hs
when:
- condition: flag(phase2)
then:
source-dirs:
- src
- _build/generated
extra-libraries: stdc++
extra-lib-dirs: _build/compiled
ghc-options:
-O3 -fPIC -pgml g++
-optl-Wl,--allow-multiple-definition
-optl-Wl,--whole-archive -optl-Wl,-Bstatic
-optl-Wl,-L_build/compiled -optl-Wl,-lImpl
-optl-Wl,-Bdynamic -optl-Wl,--no-whole-archive
build-tools: hsc2hs
include-dirs: _build/generated
else:
buildable: false
src/phase1.hs
import System.Directory
main :: IO ()
main = do
createDirectoryIfMissing True "_build/generated"
writeFile "_build/generated/Interface.hsc" hsc
writeFile "_build/generated/Impl.h" h
writeFile "_build/generated/Impl.c" c
writeFile "_build/Makefile" makeFile
makeFile = unlines
[ "compiled/libImpl.a: compiled/Impl.o"
, "\trm -f $#"
, "\tmkdir -p compiled"
, "\tar rcsT $# $^"
, ""
, "compiled/Impl.o: generated/Impl.c generated/Impl.h"
, "\tmkdir -p compiled"
, "\t$(COMPILE.c) $(OUTPUT_OPTION) $<"
]
hsc = unlines
[ "module Interface where"
, "import Foreign.Storable"
, "import Foreign.Ptr"
, ""
, "data FOO = FOO Int deriving Show"
, ""
, "#include \"Impl.h\""
, ""
, "foreign import ccall unsafe \"bar\" bar :: Ptr FOO -> IO ()"
, "instance Storable FOO where"
, " alignment _ = #alignment FOO"
, " sizeOf _ = #size FOO"
, " peek ptr = FOO <$> (#peek FOO, fd1) ptr"
, " poke ptr (FOO x) = (#poke FOO, fd1) ptr x"
]
h = unlines
[ "#pragma once"
, ""
, "typedef struct{ int fd1; } FOO;"
]
c = unlines
[ "#include \"Impl.h\""
, "#include <stdio.h>"
, ""
, "void bar(FOO* arg)"
, "{ printf(\"bar: %d\\n\", arg->fd1); }"
]
src/phase2.hs
import Interface
import Foreign.Marshal.Utils
main :: IO ()
main = with (FOO 42) bar
Script to run the whole thing manually
stack build
stack run phase1
make -C _build
stack build --flag clashilator-model:phase2
stack exec phase2
The yak is fully bare: I managed to solve it with a custom Setup.hs.
In buildHook, I basically do whatever phase1 was supposed to do (instead of leaving it in a phase1 executable), putting all generated files in places below the buildDir of the LocalBuildInfo argument. These generated files are C++ source files and an .hsc file.
I then run make in the right directory, producing some libFoo.a.
Still in buildHook, now the fun part starts: editing the Executables in the PackageDescription.
I add the hsc file's location to hsSourceDirs, and the module itself to otherModules. Since hsc2hs requires access to the generated C++ headers, I also add the right directory to includeDirs. For the library itself, I add to extraLibDirs and edit options to link statically to libFoo.a, by passing flags directly to the linker.
The result of all this is a modified set of Executables, which I put back into the PackageDescription before passing it to the default buildHook. That one then runs hsc2hs and ghc to compile and link the phase2 executables.
I have put a full example project on Github. Look at Setup.hs and clashilator/src/Clash/Clashilator/Setup.hs to see this in action; in particular, here is the editing of the Executables in the PackageDescription:
-- TODO: Should we also edit `Library` components?
buildVerilator :: LocalBuildInfo -> BuildFlags -> [FilePath] -> String -> IO (Executable -> Executable)
buildVerilator localInfo buildFlags srcDir mod = do
let outDir = buildDir localInfo
(verilogDir, manifest) <- clashToVerilog localInfo buildFlags srcDir mod
let verilatorDir = "_verilator"
Clashilator.generateFiles (".." </> verilogDir) (outDir </> verilatorDir) manifest
-- TODO: bake in `pkg-config --cflags verilator`
() <- cmd (Cwd (outDir </> verilatorDir)) "make"
let incDir = outDir </> verilatorDir </> "src"
libDir = outDir </> verilatorDir </> "obj"
lib = "VerilatorFFI"
let fixupOptions f (PerCompilerFlavor x y) = PerCompilerFlavor (f x) (f y)
linkFlags =
[ "-fPIC"
, "-pgml", "g++"
, "-optl-Wl,--whole-archive"
, "-optl-Wl,-Bstatic"
, "-optl-Wl,-l" <> lib
, "-optl-Wl,-Bdynamic"
, "-optl-Wl,--no-whole-archive"
]
fixupExe = foldr (.) id $
[ includeDirs %~ (incDir:)
, extraLibDirs %~ (libDir:)
, options %~ fixupOptions (linkFlags++)
, hsSourceDirs %~ (incDir:)
, otherModules %~ (fromString lib:)
]
return fixupExe

How do I use a FunPtr from Haskell?

Assuming the following files:
test2.h:
typedef int (*signature) ();
extern const signature lol2;
test2.c:
#include "test2.h"
int lol() {
return 42;
}
const signature lol2 = lol;
Test2.hs:
module Main where
import Foreign.C
import Foreign.Ptr
type Fun =
IO CInt
foreign import ccall
"test2.h lol2"
fun_ptr
:: FunPtr Fun
foreign import ccall "dynamic" mkFun :: FunPtr Fun -> Fun
lol = mkFun fun_ptr
main = do
fortytwo <- lol
putStrLn $ show $ fortytwo
With the following compilation:
gcc -shared test2.c -Wall -Wextra -o libtest2.so -g3 -ggdb3
ghc -o test2 Test2.hs -ltest2 -optl-Wl,-rpath,. -L. -g
(GHC emits a warning about a missing "&" before the lol2 declaration, but I think the warning is wrong, so I ignore it. Also, note that I am not using -dynamic. If I do, the results are the same)
But, I get a SIGSEGV while running:
(gdb) break scheduleWaitThread
Breakpoint 1 at 0x468150: file rts/Schedule.c, line 2509.
(gdb) r
Starting program: [...]/test2
[Thread debugging using libthread_db enabled]
Using host libthread_db library "/lib/x86_64-linux-gnu/libthread_db.so.1".
Breakpoint 1, scheduleWaitThread (tso=0x4200105388, ret=ret#entry=0x0, pcap=pcap#entry=0x7fffffffd7f8) at rts/Schedule.c:2509
2509 rts/Schedule.c: No such file or directory.
(gdb) bt
#0 scheduleWaitThread (tso=0x4200105388, ret=ret#entry=0x0, pcap=pcap#entry=0x7fffffffd7f8) at rts/Schedule.c:2509
#1 0x0000000000483864 in rts_evalLazyIO (cap=cap#entry=0x7fffffffd7f8, p=p#entry=0x4a5420, ret=ret#entry=0x0) at rts/RtsAPI.c:530
#2 0x00000000004707ae in hs_main (argc=1, argv=0x7fffffffd9e8, main_closure=0x4a5420, rts_config=...) at rts/RtsMain.c:72
#3 0x0000000000406b46 in main ()
(gdb) finish
Run till exit from #0 scheduleWaitThread (tso=0x4200105388, ret=ret#entry=0x0, pcap=pcap#entry=0x7fffffffd7f8) at rts/Schedule.c:2509
Program received signal SIGSEGV, Segmentation fault.
0x00000000004a4d90 in lol2 ()
(gdb)
After the crash the stack seems unusable:
(gdb) bt
#0 0x00000000004a4d90 in lol2 ()
#1 0x000000000040669d in r2ad_info ()
#2 0x0000000000000000 in ?? ()
What am I doing wrong? How can I debug this?
ccall can only import functions, but lol2 is no function. Use a capi import with a value qualification:
{-# LANGUAGE CApiFFI #-}
module Main where
-- ... etc ...
foreign import capi "test2.h value lol2" fun_ptr :: FunPtr Fun
-- ... etc ...
It's not immediately obvious, but the manual says to do this, and it works. The warning message you've seen still comes up; I think you may want to report that as a bug.

Calling a CUDA "Hello World" from Haskell using the FFI gives wrong results

This is the standard Hello World CUDA file:
#include <stdio.h>
#include "hello.h"
const int N = 7;
const int blocksize = 7;
__global__ void hello_kernel(char *a, int *b) {
a[threadIdx.x] += b[threadIdx.x];
}
#define cudaCheckError() { \
cudaError_t e=cudaGetLastError(); \
if(e!=cudaSuccess) { \
printf("Cuda failure %s:%d: '%s'\n",__FILE__,__LINE__,cudaGetErrorString(e)); \
exit(0); \
} \
}
void hello() {
char a[N] = "Hello ";
int b[N] = {15, 10, 6, 0, -11, 1, 0};
char *ad;
int *bd;
const int csize = N*sizeof(char);
const int isize = N*sizeof(int);
printf("%s", a);
cudaMalloc( (void**)&ad, csize );
cudaMemcpy( ad, a, csize, cudaMemcpyHostToDevice );
cudaCheckError();
cudaMalloc( (void**)&bd, isize );
cudaMemcpy( bd, b, isize, cudaMemcpyHostToDevice );
cudaCheckError();
dim3 dimBlock( blocksize, 1 );
dim3 dimGrid( 1, 1 );
hello_kernel<<<dimGrid, dimBlock>>>(ad, bd);
cudaMemcpy( a, ad, csize, cudaMemcpyDeviceToHost );
cudaCheckError();
cudaFree( ad );
cudaCheckError();
printf("%s\n", a);
}
And its header:
-- hello.h
extern "C"
void hello();
That's a Haskell file that calls such function:
-- test.hs
{-# LANGUAGE ForeignFunctionInterface #-}
import Foreign.C
import Foreign.Ptr (Ptr,nullPtr)
foreign import ccall "hello" hello :: IO ()
main = hello
I'm compiling it with:
nvcc hello.c -c -o hello.o
ghc test.hs -o test hello.o -L/usr/local/cuda/lib -optl-lcudart
Running that program with ./test results in:
Hello Cuda failure hello.cu:32: 'no CUDA-capable device is detected'
Running the same program with a C main() that just calls hello produces Hello World, as expected.
How do I make Haskell detect the device correctly?
Maybe unrelated, but I was able to reproduce your error on a Mac with separate on-board and discrete graphics cards. When "Automatic graphics switching" is enabled in System Preferences (and no 3D graphics applications are running), I get the same "no CUDA-capable device is detected" error.
When I turn off automatic graphics switching, it forces the Mac to use the discrete graphics card, and then the program runs as expected.
The purely C/CUDA-based version of the code doesn't seem to be affected by this preference and always works whether automatic switching is enabled or not.
Using ghc 7.8.3 and nvcc V6.5.12, I found that your code works as expected. The only different thing that I did was name hello.c as hello.cu.
/:cuda_haskell> nvcc --version
nvcc: NVIDIA (R) Cuda compiler driver
Copyright (c) 2005-2014 NVIDIA Corporation
Built on Thu_Jul_17_19:13:24_CDT_2014
Cuda compilation tools, release 6.5, V6.5.12
/:cuda_haskell> nvcc -o hello.o -c hello.cu
/:cuda_haskell> ghc main.hs -o hello_hs hello.o -L/usr/local/cuda/lib -optl-lcudart
Linking hello_hs ...
/:cuda_haskell> ./hello_hs
Hello World!
/:cuda_haskell> cat main.hs
-- main.hs
{-# LANGUAGE ForeignFunctionInterface #-}
import Foreign.C
import Foreign.Ptr (Ptr,nullPtr)
foreign import ccall "hello" hello :: IO ()
main = hello

Importing 'C' Delay function into Haskell using FFI

There is a function in the wiringPi 'C' library called delay with type
void delay(unsigned int howLong);
This function delays execution of code for howLong milliseconds. I wrote the binding code in haskell to be able to call this function. The haskell code is as follows,
foreign import ccall "wiringPi.h delay" c_delay :: CUInt -> IO ()
hdelay :: Int -> IO ()
hdelay howlong = c_delay (fromIntegral howlong)
After this, I wrote a simple haskell program to call this function. The simply haskell code is as follows..
--After importing relavent libraries I did
main = wiringPiSetup
>> delay 5000
But the delay does not happen or rather the executable generated by the ghc compiler exits right away.
Could someone tell me what could possibly go wrong here? A small nudge in the right direction would help.
Cheers and Regards.
Please ignore the part in block quote, and see update below - I am preserving the original non-solution because of comments associated with it.
You should mark the import as unsafe since you want the main
thread to block while the function is executing (see comment below by
#carl). By default, import is safe, not unsafe. So, changing
the function signature to this should make the main thread block:
foreign import ccall unsafe "wiring.h delay" c_delay :: CUInt -> IO ()
Also, if you plan to write multi-threaded code, GHC docs for multi-threaded FFI is >very useful. This also seems a good starter.
Update
The behavior seems to be due to signal interrupt handling (if I recall correctly, this was added in GHC 7.4+ to fix some bugs). More details here:
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Signals
Please note the comment on the above page: Signal handling differs between the threaded version of the runtime and the non-threaded version.
Approach 1 - Handle signal interrupt in FFI code:
A toy code is below which handles the interrupt in sleep. I tested it on Linux 2.6.18 with ghc 7.6.1.
C code:
/** ctest.c **/
#include <unistd.h>
#include <stdio.h>
#include <time.h>
unsigned delay(unsigned sec)
{
struct timespec req={0};
req.tv_sec = sec;
req.tv_nsec = 0;
while (nanosleep(&req, &req) == -1) {
printf("Got interrupt, continuing\n");
continue;
}
return 1;
}
Haskell code:
{-# LANGUAGE ForeignFunctionInterface #-}
-- Filename Test.hs
module Main (main) where
import Foreign.C.Types
foreign import ccall safe "delay" delay :: CUInt -> IO CUInt
main = do
putStrLn "Sleeping"
n <- delay 2000
putStrLn $ "Got return code from sleep: " ++ show n
Now, after compiling with ghc 7.6.1 (command: ghc Test.hs ctest.c), it waits until sleep finishes, and prints a message every time it gets an interrupt signal during sleep:
./Test
Sleeping
Got interrupt, continuing
Got interrupt, continuing
Got interrupt, continuing
Got interrupt, continuing
....
....
Got return code from sleep: 1
Approach 2 - Disable SIGVTALRM before calling FFI code, and re-enable:
I am not sure what the implications are for disabling SIGVTALRM. This is alternative approach which disables SIGVTALRM during FFI call, if you can't alter FFI code. So, FFI code is not interrupted during sleep (assuming it is SIGVTALRM that is causing the interrupt).
{-# LANGUAGE ForeignFunctionInterface #-}
-- Test.hs
module Main (main) where
import Foreign.C.Types
import System.Posix.Signals
foreign import ccall safe "delay" delay :: CUInt -> IO CUInt
main = do
putStrLn "Sleeping"
-- Block SIGVTALRM temporarily to avoid interrupts while sleeping
blockSignals $ addSignal sigVTALRM emptySignalSet
n <- delay 2
putStrLn $ "Got return code from sleep: " ++ show n
-- Unblock SIGVTALRM
unblockSignals $ addSignal sigVTALRM emptySignalSet
return ()

Resources