git.iko.soy/Idris-dev
on d1bc3fa help sign in
Idris-dev/src/Util/DynamicLinker.hs
184 lines 7.3 kB history raw
1{-|
2Module : Util.DynamicLinker
3Description : Platform-specific dynamic linking support. Add new platforms to this file through conditional compilation.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE CPP, ExistentialQuantification, ScopedTypeVariables #-}
9module Util.DynamicLinker ( ForeignFun(..)
10 , DynamicLib(..)
11 , tryLoadLib
12 , tryLoadFn
13 ) where
15#ifdef IDRIS_FFI
16import Foreign.LibFFI
17import Foreign.Ptr (FunPtr, Ptr(), castPtrToFunPtr, nullFunPtr, nullPtr)
18import System.Directory
19#ifndef mingw32_HOST_OS
20import Control.Exception (IOException, throwIO, try)
21import Data.Array (Array, bounds, inRange, (!))
22import Data.Functor ((<$>))
23import Data.Maybe (catMaybes)
24import System.FilePath.Posix ((</>))
25import System.Posix.DynamicLinker
26import Text.Regex.TDFA
27#else
28import qualified Control.Exception as Exception (IOException, catch)
29import System.FilePath.Windows ((</>))
30import System.Win32.DLL
31import System.Win32.Types
32type DL = HMODULE
33#endif
35hostDynamicLibExt :: String
36#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS) \
37 || defined(dragonfly_HOST_OS) || defined(openbsd_HOST_OS) \
38 || defined(netbsd_HOST_OS)
39hostDynamicLibExt = "so"
40#elif defined(darwin_HOST_OS)
41hostDynamicLibExt = "dylib"
42#elif defined(mingw32_HOST_OS)
43hostDynamicLibExt = "dll"
44#else
45hostDynamicLibExt = error $ unwords
46 [ "Undefined file extension for dynamic libraries"
47 , "in Idris' Util.DynamicLinker."
48 ]
49#endif
51data ForeignFun = forall a. Fun { fun_name :: String
52 , fun_handle :: FunPtr a
53 }
55data DynamicLib = Lib { lib_name :: String
56 , lib_handle :: DL
57 }
59instance Eq DynamicLib where
60 (Lib a _) == (Lib b _) = a == b
62firstExisting :: [FilePath] -> IO (Maybe FilePath)
63firstExisting [] = return Nothing
64firstExisting (f:fs) = do exists <- doesFileExist f
65 if exists
66 then return (Just f)
67 else firstExisting fs
69libFileName :: [FilePath] -> String -> IO String
70libFileName dirs lib = do let names = [lib, lib ++ "." ++ hostDynamicLibExt]
71 cwd <- getCurrentDirectory
72 found <- firstExisting $
73 map ("."</>) names ++ [d </> f | d <- cwd:dirs, f <- names]
74 return $ maybe (lib ++ "." ++ hostDynamicLibExt) id found
76#ifndef mingw32_HOST_OS
77-- Load a dynamic library on POSIX systems.
78-- In the simple case, we just find the appropriate filename and call dlopen().
79-- In the complicated case our "foo.so" isn't actually a library. Some of the
80-- .so files on modern Linux systems are linker scripts instead. dlopen()
81-- doesn't know anything about those. We need to look inside the script for the
82-- actual library path and load that. This is a horrible hack, the correct
83-- method would be to actually parse the scripts and execute them. The approach
84-- below is what GHC does.
85tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
86tryLoadLib dirs lib = do
87 filename <- libFileName dirs lib
88 res :: Either IOException DL <- try $
89 dlopen filename [RTLD_NOW, RTLD_GLOBAL]
90 mbDL <- case res of
91 Right handle -> return $ Just handle
92#ifdef linux_HOST_OS
93 Left ex ->
94 -- dlopen failed, run a regex to see if the error message looks like it
95 -- could be a linker script.
96 case matchAllText invalidLibRegex (show ex) of
97 (x:_) -> do
98 if inRange (bounds x) 1
99 then do
100 -- filename above may be a relative path. Get the full path out of
101 -- the error message.
102 let realPath = fst $ x ! 1
103 fileLines <- lines <$> readFile realPath
104 -- Go down the linker script line by line looking for .so
105 -- filenames and try each one.
106 let matches = catMaybes $ map
107 (getLastMatch . matchAllText linkerScriptRegex)
108 fileLines
109 mapMFirst (\f -> dlopen f [RTLD_NOW, RTLD_GLOBAL]) matches
110 else return Nothing
111 [] -> return Nothing
112#else
113 Left ex -> throwIO ex
114#endif
115 case mbDL of
116 Just handle -> if undl handle == nullPtr
117 then return Nothing
118 else return . Just $ Lib lib handle
119 Nothing -> return Nothing
121getLastMatch :: [MatchText String] -> Maybe String
122getLastMatch [] = Nothing
123getLastMatch (x:_) = case bounds x of
124 (low, high) -> if low > high
125 then Nothing
126 else Just $ fst $ x ! high
128mapMFirst :: (a -> IO b) -> [a] -> IO (Maybe b)
129mapMFirst f [] = return Nothing
130mapMFirst f (a:as) = do res <- try (f a)
131 case res of
132 Left (ex :: IOException) -> mapMFirst f as
133 Right res -> return $ Just res
135-- Both regexes copyright 2009-2011 Howard B. Golden, CJ van den Berg and Ian
136-- Lynagh. From the Glasgow Haskell Compiler. BSD licensed.
137invalidLibRegex :: Regex
138invalidLibRegex = makeRegex "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)"
140linkerScriptRegex :: Regex
141linkerScriptRegex = makeRegex "(GROUP|INPUT) *\\( *([^ )]+)"
143tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
144tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn
145 if cFn == nullFunPtr
146 then return Nothing
147 else return . Just $ Fun fn cFn
148#else
149tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
150tryLoadLib dirs lib = do filename <- libFileName dirs lib
151 handle <- Exception.catch (loadLibrary filename) nullPtrOnException
152 if handle == nullPtr
153 then return Nothing
154 else return . Just $ Lib lib handle
155 where nullPtrOnException :: Exception.IOException -> IO DL
156 nullPtrOnException e = return nullPtr
157 -- `show e` will however give broken error message
159tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
160tryLoadFn fn (Lib _ h) = do cFn <- getProcAddress h fn
161 if cFn == nullPtr
162 then return Nothing
163 else return . Just $ Fun fn (castPtrToFunPtr cFn)
164#endif
165#else
166-- no libffi, just add stubbs.
168data DynamicLib = Lib { lib_name :: String
169 , lib_handle :: ()
170 }
171 deriving Eq
173data ForeignFun = forall a. Fun { fun_name :: String
174 , fun_handle :: ()
175 }
177tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
178tryLoadLib fps lib = do putStrLn $ "WARNING: Cannot load '" ++ lib ++ "' at compile time because Idris was compiled without libffi support."
179 return Nothing
181tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
182tryLoadFn fn lib = do putStrLn $ "WARNING: Cannot load '" ++ fn ++ "' at compile time because Idris was compiled without libffi support."
183 return Nothing
184#endif