git.iko.soy/Idris-dev
on 0c8a486 help sign in
Idris-dev/src/Util/DynamicLinker.hs
182 lines 7.1 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 ExistentialQuantification, CPP, ScopedTypeVariables #-}
9module Util.DynamicLinker ( ForeignFun(..)
10 , DynamicLib(..)
11 , tryLoadLib
12 , tryLoadFn
13 ) where
15#ifdef IDRIS_FFI
16import Foreign.LibFFI
17import Foreign.Ptr (Ptr(), nullPtr, FunPtr, nullFunPtr, castPtrToFunPtr)
18import System.Directory
19#ifndef mingw32_HOST_OS
20import Control.Exception (try, IOException, throwIO)
21import Data.Array (Array, inRange, bounds, (!))
22import Data.Functor ((<$>))
23import Data.Maybe (catMaybes)
24import System.Posix.DynamicLinker
25import System.FilePath.Posix ((</>))
26import Text.Regex.TDFA
27#else
28import qualified Control.Exception as Exception (catch, IOException)
29import System.Win32.DLL
30import System.Win32.Types
31import System.FilePath.Windows ((</>))
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
135invalidLibRegex :: Regex
136invalidLibRegex = makeRegex "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)"
138linkerScriptRegex :: Regex
139linkerScriptRegex = makeRegex "(GROUP|INPUT) *\\( *([^ )]+)"
141tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
142tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn
143 if cFn == nullFunPtr
144 then return Nothing
145 else return . Just $ Fun fn cFn
146#else
147tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
148tryLoadLib dirs lib = do filename <- libFileName dirs lib
149 handle <- Exception.catch (loadLibrary filename) nullPtrOnException
150 if handle == nullPtr
151 then return Nothing
152 else return . Just $ Lib lib handle
153 where nullPtrOnException :: Exception.IOException -> IO DL
154 nullPtrOnException e = return nullPtr
155 -- `show e` will however give broken error message
157tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
158tryLoadFn fn (Lib _ h) = do cFn <- getProcAddress h fn
159 if cFn == nullPtr
160 then return Nothing
161 else return . Just $ Fun fn (castPtrToFunPtr cFn)
162#endif
163#else
164-- no libffi, just add stubbs.
166data DynamicLib = Lib { lib_name :: String
167 , lib_handle :: ()
168 }
169 deriving Eq
171data ForeignFun = forall a. Fun { fun_name :: String
172 , fun_handle :: ()
173 }
175tryLoadLib :: [FilePath] -> String -> IO (Maybe DynamicLib)
176tryLoadLib fps lib = do putStrLn $ "WARNING: Cannot load '" ++ lib ++ "' at compile time because Idris was compiled without libffi support."
177 return Nothing
179tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
180tryLoadFn fn lib = do putStrLn $ "WARNING: Cannot load '" ++ fn ++ "' at compile time because Idris was compiled without libffi support."
181 return Nothing
182#endif