diff --git a/src/System/Plugins/Load.hs b/src/System/Plugins/Load.hs index 85d0168..82205bd 100644 --- a/src/System/Plugins/Load.hs +++ b/src/System/Plugins/Load.hs @@ -3,23 +3,23 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ForeignFunctionInterface #-} -- --- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons --- +-- Copyright (C) 2004-5 Don Stewart +-- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public -- License as published by the Free Software Foundation; either -- version 2.1 of the License, or (at your option) any later version. --- +-- -- This library is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. --- +-- -- You should have received a copy of the GNU Lesser General Public -- License along with this library; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -- USA --- +-- -- | An interface to the GHC runtime's dynamic linker, providing runtime -- loading and linking of Haskell object files, commonly known as @@ -34,7 +34,7 @@ module System.Plugins.Load ( , load , load_ , dynload - , pdynload + , pdynload , pdynload_ , unload , unloadAll @@ -149,7 +149,7 @@ data LoadStatus a -- provided with appropriate type constraints such that Haskell compiler -- can determine the expected type returned by 'load', as the return -- type is notionally polymorphic. --- +-- -- Example: -- -- > do mv <- load "Plugin.o" ["api"] [] "resource" @@ -184,18 +184,21 @@ load obj incpaths pkgconfs sym = do #endif addModuleDeps m' moduleDeps v <- loadFunction m sym - return $ case v of + return $ case v of Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] Just a -> LoadSuccess m a -- -- | Like load, but doesn't want a package.conf arg (they are rarely used) -- -load_ :: FilePath -> [FilePath] -> Symbol -> IO (LoadStatus a) +load_ :: FilePath -- ^ object file + -> [FilePath] -- ^ any include paths + -> Symbol -- ^ symbol to find + -> IO (LoadStatus a) load_ o i s = load o i [] s --- --- A work-around for Dynamics. The keys used to compare two TypeReps are + +-- | A work-around for Dynamics. The keys used to compare two TypeReps are -- somehow not equal for the same type in hs-plugin's loaded objects. -- Solution: implement our own dynamics... -- @@ -204,8 +207,8 @@ load_ o i s = load o i [] s -- is not the case, we core dump. Use pdynload if you don't trust the -- user to supply you with a Dynamic -- -dynload :: Typeable a - => FilePath +dynload :: Typeable a + => FilePath -> [FilePath] -> [PackageConf] -> Symbol @@ -220,7 +223,8 @@ dynload obj incpaths pkgconfs sym = do Nothing -> LoadFailure ["Mismatched types in interface"] ------------------------------------------------------------------------ --- + +-- | -- The super-replacement for dynload -- -- Use GHC at runtime so we get staged type inference, providing full @@ -229,7 +233,6 @@ dynload obj incpaths pkgconfs sym = do -- -- TODO where does the .hc file go in the call to build() ? -- - pdynload :: FilePath -- ^ object to load -> [FilePath] -- ^ include paths -> [PackageConf] -- ^ package confs @@ -237,7 +240,7 @@ pdynload :: FilePath -- ^ object to load -> Symbol -- ^ symbol -> IO (LoadStatus a) -pdynload object incpaths pkgconfs ty sym = do +pdynload object incpaths pkgconfs ty sym = do #if DEBUG putStr "Checking types ... " >> hFlush stdout #endif @@ -245,7 +248,7 @@ pdynload object incpaths pkgconfs ty sym = do #if DEBUG putStrLn "done" #endif - if null errors + if null errors then load object incpaths pkgconfs sym else return $ LoadFailure errors @@ -269,12 +272,12 @@ pdynload_ object incpaths pkgconfs args ty sym = do #if DEBUG putStrLn "done" #endif - if null errors + if null errors then load object incpaths pkgconfs sym else return $ LoadFailure errors ------------------------------------------------------------------------ --- run the typechecker over the constraint file +-- | run the typechecker over the constraint file -- -- Problem: if the user depends on a non-auto package to build the -- module, then that package will not be in scope when we try to build @@ -290,7 +293,7 @@ unify obj incs args ty sym = do (tmpf1,hdl1) <- mkTemp -- and send .hi file here. hClose hdl1 - let nm = mkModid (basename tmpf) + let nm = mkModid (basename tmpf) src = mkTest nm (hierize' . mkModid . hierize $ obj) (fst $ break (=='.') ty) ty sym is = map ("-i"++) incs -- api @@ -312,7 +315,7 @@ unify obj incs args ty sym = do hierize' ('\\':cs) = '.' : hierize' cs hierize' (c:cs) = c : hierize' cs -mkTest modnm plugin api ty sym = +mkTest modnm plugin api ty sym = "module "++ modnm ++" where" ++ "\nimport qualified " ++ plugin ++ "\nimport qualified " ++ api ++ @@ -327,11 +330,11 @@ mkTest modnm plugin api ty sym = pdynload obj incpaths pkgconfs sym ty = do (m, v) <- load obj incpaths pkgconfs sym ty' <- mungeIface sym obj - if ty == ty' + if ty == ty' then return $ Just (m, v) else return Nothing -- mismatched types - where + where -- grab the iface output from GHC. find the line relevant to our -- symbol. grab the string rep of the type. mungeIface sym o = do @@ -348,11 +351,11 @@ pdynload obj incpaths pkgconfs sym ty = do -- -- a version of load the also unwraps and types a Dynamic object -- -dynload2 :: Typeable a => - FilePath -> - FilePath -> +dynload2 :: Typeable a => + FilePath -> + FilePath -> Maybe [PackageConf] -> - Symbol -> + Symbol -> IO (Module, a) dynload2 obj incpath pkgconfs sym = do @@ -402,13 +405,13 @@ reload m@(Module{path = p, iface = hi}) sym = do #endif m_ <- loadObject p . Object . ifaceModuleName $ hi -- load object at path p let m' = m_ { iface = hi } - + resolveObjs (unloadAll m) #if DEBUG putStrLn "done" >> hFlush stdout #endif v <- loadFunction m' sym - return $ case v of + return $ case v of Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"] Just a -> LoadSuccess m' a @@ -493,31 +496,29 @@ loadPackageFunction pkgName modName functionName = -- NB the environment stores the *full path* to an object. So if you -- want to know if a module is already loaded, you need to supply the -- *path* to that object, not the name. --- +-- -- NB -- let's try just the module name. -- -- loadObject loads normal .o objs, and packages too. .o objs come with -- a nice canonical Z-encoded modid. packages just have a simple name. -- Do we want to ensure they won't clash? Probably. -- - +-- -- -- the second argument to loadObject is a string to use as the unique -- identifier for this object. For normal .o objects, it should be the -- Z-encoded modid from the .hi file. For archives\/packages, we can -- probably get away with the package name -- - - loadObject :: FilePath -> Key -> IO Module -loadObject p ky@(Object k) = loadObject' p ky k -loadObject p ky@(Package k) = loadObject' p ky k +loadObject p ky@(Object k) = loadObject' p ky k +loadObject p ky@(Package k) = loadObject' p ky k loadObject' :: FilePath -> Key -> String -> IO Module loadObject' p ky k | ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p) - | otherwise + | otherwise = do alreadyLoaded <- isLoaded k when (not alreadyLoaded) $ do r <- withCString p c_loadObj @@ -527,7 +528,7 @@ loadObject' p ky k where emptyMod q = Module q (mkModid q) Vanilla undefined ky --- +-- | -- load a single object. no dependencies. You should know what you're -- doing. -- @@ -560,11 +561,11 @@ resolveObjs unloadLoaded -- | Unload a module -unloadObj :: Module -> IO () +unloadObj :: Module -> IO () unloadObj (Module { path = p, kind = k, key = ky }) = case k of Vanilla -> withCString p $ \c_p -> do removed <- rmModule name - when (removed) $ do r <- c_unloadObj c_p + when (removed) $ do r <- c_unloadObj c_p when (not r) (panic "unloadObj: failed") Shared -> return () -- can't unload .so? where name = case ky of Object s -> s ; Package pk -> pk @@ -579,14 +580,14 @@ loadShared str = do putStrLn $ " shared: " ++ str #endif maybe_errmsg <- withCString str $ \dll -> c_addDLL dll - if maybe_errmsg == nullPtr + if maybe_errmsg == nullPtr then return (Module str (mkModid str) Shared undefined (Package (mkModid str))) else do e <- peekCString maybe_errmsg panic $ "loadShared: couldn't load `"++str++"\' because "++e -- --- Load a -package that we might need, implicitly loading the cbits too +-- | Load a -package that we might need, implicitly loading the cbits too -- The argument is the name of package (e.g. \"concurrent\") -- -- How to find a package is determined by the package.conf info we store @@ -610,7 +611,7 @@ loadPackage p = do -- --- Unload a -package, that has already been loaded. Unload the cbits +-- | Unload a -package, that has already been loaded. Unload the cbits -- too. The argument is the name of the package. -- -- May need to check if it exists. @@ -625,12 +626,12 @@ unloadPackage pkg = do let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1 libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg) flip mapM_ libs $ \p -> withCString p $ \c_p -> do - r <- c_unloadObj c_p + r <- c_unloadObj c_p when (not r) (panic "unloadObj: failed") - rmModule (mkModid p) -- unrecord this module + rmModule (mkModid p) -- unrecord this module -- --- load a package using the given package.conf to help +-- | load a package using the given package.conf to help -- TODO should report if it doesn't actually load the package, instead -- of mapM_ doing nothing like above. -- @@ -644,10 +645,10 @@ loadPackageWith p pkgconfs = do #if DEBUG putStrLn " done" #endif - + -- --------------------------------------------------------------------- --- module dependency loading +-- | module dependency loading -- -- given an Foo.o vanilla object file, supposed to be a plugin compiled -- by our library, find the associated .hi file. If this is found, load @@ -684,11 +685,11 @@ loadDepends obj incpaths = do -- now, try to generate a path to the actual .o file -- fix up hierachical names - let mods_ = map (\s -> (s, map (\c -> + let mods_ = map (\s -> (s, map (\c -> if c == '.' then '/' else c) $ s)) ds' -- construct a list of possible dependent modules to load - let mods = concatMap (\p -> + let mods = concatMap (\p -> map (\(hi,m) -> (hi,p m++".o")) mods_) incpaths -- remove modules that don't exist @@ -717,15 +718,15 @@ loadDepends obj incpaths = do #endif resolveObjs (mapM_ unloadPackage ps') #if DEBUG - when (not (null ps')) $ putStrLn "done" - putStr "Loading object" + when (not (null ps')) $ putStrLn "done" + putStr "Loading object" mapM_ (\(m,_) -> putStr (" "++ m) >> hFlush stdout) mods'' #endif moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods'' return (hiface,moduleDeps) -- --------------------------------------------------------------------- --- Nice interface to .hi parser +-- | Nice interface to .hi parser -- getImports :: String -> IO [String] getImports m = do