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