{-# LANGUAGE CPP #-}{-# LANGUAGE MagicHash #-}{-# LANGUAGE UnboxedTuples #-}{-# LANGUAGE ForeignFunctionInterface #-}---- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons-- -- 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-- /plugins/.moduleSystem.Plugins.Load(-- * The @LoadStatus@ typeLoadStatus(..)-- * High-level interface,load,load_,dynload,pdynload,pdynload_,unload,unloadAll,reload,Module(..)-- * Low-level interface,initLinker-- start it up,loadModule-- load a vanilla .o,loadFunction-- retrieve a function from an object,loadFunction_-- retrieve a function from an object,loadPackageFunction,loadPackage-- load a ghc library and its cbits,unloadPackage-- unload a ghc library and its cbits,loadPackageWith-- load a pkg using the package.conf provided,loadShared-- load a .so object file,resolveObjs-- and resolve symbols,loadRawObject-- load a bare .o. no dep chasing, no .hi file reading,Symbol,getImports)where#include "../../../config.h"importSystem.Plugins.Make(build)importSystem.Plugins.EnvimportSystem.Plugins.UtilsimportSystem.Plugins.Consts(sysPkgSuffix,hiSuf,prefixUnderscore)importSystem.Plugins.LoadTypes-- import Language.Hi.ParserimportBinIfaceimportHscTypesimportModule(moduleName,moduleNameString,packageIdString)importHscMain(newHscEnv)importTcRnMonad(initTcRnIf)importData.Dynamic(fromDynamic,Dynamic)importData.Typeable(Typeable)importData.List(isSuffixOf,nub,nubBy)importControl.Monad(when,filterM,liftM)importSystem.Directory(doesFileExist,removeFile)importForeign.C.String(CString,withCString,peekCString)importGHC(defaultCallbacks)importGHC.Ptr(Ptr(..),nullPtr)importGHC.Exts(addrToHValue#)importGHC.Prim(unsafeCoerce#)#if DEBUGimportSystem.IO(hFlush,stdout)#endifimportSystem.IO(hClose)ifaceModuleName=moduleNameString.moduleName.mi_modulereadBinIface'::FilePath->IOModIfacereadBinIface'hi_path=do-- kludgy as helle<-newHscEnvdefaultCallbacksundefinedinitTcRnIf'r'eundefinedundefined(readBinIfaceIgnoreHiWayQuietBinIFaceReadinghi_path)-- TODO need a loadPackage p package.conf :: IO () primitive---- | The @LoadStatus@ type encodes the return status of functions that-- perform dynamic loading in a type isomorphic to 'Either'. Failure-- returns a list of error strings, success returns a reference to a-- loaded module, and the Haskell value corresponding to the symbol that-- was indexed.--dataLoadStatusa=LoadSuccessModulea|LoadFailureErrors---- | 'load' is the basic interface to the dynamic loader. A call to-- 'load' imports a single object file into the caller's address space,-- returning the value associated with the symbol requested. Libraries-- and modules that the requested module depends upon are loaded and-- linked in turn.---- The first argument is the path to the object file to load, the second-- argument is a list of directories to search for dependent modules.-- The third argument is a list of paths to user-defined, but-- unregistered, /package.conf/ files. The 'Symbol' argument is the-- symbol name of the value you with to retrieve.---- The value returned must be given an explicit type signature, or-- 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"-- > case mv of-- > LoadFailure msg -> print msg-- > LoadSuccess _ v -> return v--load::FilePath-- ^ object file->[FilePath]-- ^ any include paths->[PackageConf]-- ^ list of package.conf paths->Symbol-- ^ symbol to find->IO(LoadStatusa)loadobjincpathspkgconfssym=doinitLinker-- load extra package informationmapM_addPkgConfpkgconfs(hif,moduleDeps)<-loadDependsobjincpaths-- why is this the package name?#if DEBUGputStr(' ':(decode$ifaceModuleNamehif))>>hFlushstdout#endifm'<-loadObjectobj.Object.ifaceModuleName$hifletm=m'{iface=hif}resolveObjs(mapM_unloadAll(m:moduleDeps))#if DEBUGputStrLn" ... done">>hFlushstdout#endifaddModuleDepsm'moduleDepsv<-loadFunctionmsymreturn$casevofNothing->LoadFailure["load: couldn't find symbol <<"++sym++">>"]Justa->LoadSuccessma---- | Like load, but doesn't want a package.conf arg (they are rarely used)--load_::FilePath->[FilePath]->Symbol->IO(LoadStatusa)load_ois=loadoi[]s---- 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...---- The problem with dynload is that it requires the plugin to export-- a value that is a Dynamic (in our case a (TypeRep,a) pair). If this-- is not the case, we core dump. Use pdynload if you don't trust the-- user to supply you with a Dynamic--dynload::Typeablea=>FilePath->[FilePath]->[PackageConf]->Symbol->IO(LoadStatusa)dynloadobjincpathspkgconfssym=dos<-loadobjincpathspkgconfssymcasesofe@(LoadFailure_)->returneLoadSuccessmdyn_v->return$casefromDynamic(unsafeCoerce#dyn_v::Dynamic)ofJustv'->LoadSuccessmv'Nothing->LoadFailure["Mismatched types in interface"]---------------------------------------------------------------------------- The super-replacement for dynload---- Use GHC at runtime so we get staged type inference, providing full-- power dynamics, *on module interfaces only*. This is quite suitable-- for plugins, of coures :)---- TODO where does the .hc file go in the call to build() ?--pdynload::FilePath-- ^ object to load->[FilePath]-- ^ include paths->[PackageConf]-- ^ package confs->Type-- ^ API type->Symbol-- ^ symbol->IO(LoadStatusa)pdynloadobjectincpathspkgconfstysym=do#if DEBUGputStr"Checking types ... ">>hFlushstdout#endiferrors<-unifyobjectincpaths[]tysym#if DEBUGputStrLn"done"#endififnullerrorsthenloadobjectincpathspkgconfssymelsereturn$LoadFailureerrors---- | Like pdynload, but you can specify extra arguments to the-- typechecker.--pdynload_::FilePath-- ^ object to load->[FilePath]-- ^ include paths for loading->[PackageConf]-- ^ any extra package.conf files->[Arg]-- ^ extra arguments to ghc, when typechecking->Type-- ^ expected type->Symbol-- ^ symbol to load->IO(LoadStatusa)pdynload_objectincpathspkgconfsargstysym=do#if DEBUGputStr"Checking types ... ">>hFlushstdout#endiferrors<-unifyobjectincpathsargstysym#if DEBUGputStrLn"done"#endififnullerrorsthenloadobjectincpathspkgconfssymelsereturn$LoadFailureerrors-------------------------------------------------------------------------- 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-- the module, when performing `unify'. Normally make() will handle this-- (as it takes extra ghc args). pdynload ignores these, atm -- but it-- shouldn't. Consider a pdynload() that accepts extra -package flags?---- Also, pdynload() should accept extra in-scope modules.-- Maybe other stuff we want to hack in here.--unifyobjincsargstysym=do(tmpf,hdl)<-mkTemp(tmpf1,hdl1)<-mkTemp-- and send .hi file here.hClosehdl1letnm=mkModid(basenametmpf)src=mkTestnm(hierize'.mkModid.hierize$obj)(fst$break(=='.')ty)tysymis=map("-i"++)incs-- apii="-i"++dirnameobj-- pluginhWritehdlsrce<-buildtmpftmpf1(i:is++args++["-fno-code","-ohi "++tmpf1])mapM_removeFile[tmpf,tmpf1]returnewhere-- fix up hierarchical nameshierize[]=[]hierize('/':cs)='\\':hierizecshierize(c:cs)=c:hierizecshierize'[]=[]hierize'('\\':cs)='.':hierize'cshierize'(c:cs)=c:hierize'csmkTestmodnmpluginapitysym="module "++modnm++" where"++"\nimport qualified "++plugin++"\nimport qualified "++api++"{-# LINE 1 \"<typecheck>\" #-}"++"\n_ = "++plugin++"."++sym++" :: "++ty------------------------------------------------------------------------{-
--
-- old version that tried to rip stuff from .hi files
--
pdynload obj incpaths pkgconfs sym ty = do
(m, v) <- load obj incpaths pkgconfs sym
ty' <- mungeIface sym obj
if ty == ty'
then return $ Just (m, v)
else return Nothing -- mismatched types
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
let hi = replaceSuffix o hiSuf
(out,_) <- exec ghc ["--show-iface", hi]
case find (\s -> (sym ++ " :: ") `isPrefixOf` s) out of
Nothing -> return undefined
Just v -> do let v' = drop 3 $ dropWhile (/= ':') v
return v'
-}{-
--
-- a version of load the also unwraps and types a Dynamic object
--
dynload2 :: Typeable a =>
FilePath ->
FilePath ->
Maybe [PackageConf] ->
Symbol ->
IO (Module, a)
dynload2 obj incpath pkgconfs sym = do
(m, v) <- load obj incpath pkgconfs sym
case fromDynamic v of
Nothing -> panic $ "load: couldn't type "++(show v)
Just a -> return (m,a)
-}---------------------------------------------------------------------------- | unload a module (not its dependencies)-- we have the dependencies, so cascaded unloading is possible---- once you unload it, you can't 'load' it again, you have to 'reload'-- it. Cause we don't unload all the dependencies--unload::Module->IO()unloadm=rmModuleDepsm>>unloadObjm---------------------------------------------------------------------------- | unload a module and its dependencies-- we have the dependencies, so cascaded unloading is possible--unloadAll::Module->IO()unloadAllm=domoduleDeps<-getModuleDepsmrmModuleDepsmmapM_unloadAllmoduleDepsunloadm---- | this will be nice for panTHeon, needs thinking about the interface-- reload a single object file. don't care about depends, assume they-- are loaded. (should use state to store all this)---- assumes you've already done a 'load'---- should factor the code--reload::Module->Symbol->IO(LoadStatusa)reloadm@(Module{path=p,iface=hi})sym=dounloadObjm-- unload module (and delete)#if DEBUGputStr("Reloading "++(mnamem)++" ... ")>>hFlushstdout#endifm_<-loadObjectp.Object.ifaceModuleName$hi-- load object at path pletm'=m_{iface=hi}resolveObjs(unloadAllm)#if DEBUGputStrLn"done">>hFlushstdout#endifv<-loadFunctionm'symreturn$casevofNothing->LoadFailure["load: couldn't find symbol <<"++sym++">>"]Justa->LoadSuccessm'a---- This is a stripped-down version of Andre Pang's runtime_loader,-- which in turn is based on GHC's ghci\/ObjLinker.lhs binding---- Load and unload\/Haskell modules at runtime. This is not really-- \'dynamic loading\', as such -- that implies that you\'re working-- with proper shared libraries, whereas this is far more simple and-- only loads object files. But it achieves the same goal: you can-- load a Haskell module at runtime, load a function from it, and run-- the function. I have no idea if this works for types, but that-- doesn\'t mean that you can\'t try it :).---- read $fptools\/ghc\/compiler\/ghci\/ObjLinker.lhs for how to use this stuff---- | Call the initLinker function first, before calling any of the other-- functions in this module - otherwise you\'ll get unresolved symbols.-- initLinker :: IO ()-- our initLinker transparently calls the one in GHC---- | Load a function from a module (which must be loaded and resolved first).--loadFunction::Module-- ^ The module the value is in->String-- ^ Symbol name of value->IO(Maybea)-- ^ The value you wantloadFunction(Module{iface=i})valsym=loadFunction_(ifaceModuleNamei)valsymloadFunction_::String->String->IO(Maybea)loadFunction_=loadFunction__NothingloadFunction__::MaybeString->String->String->IO(Maybea)loadFunction__pkgmvalsym=doletsymbol=prefixUnderscore++(maybe""(\p->encodep++"_")pkg)++encodem++"_"++(encodevalsym)++"_closure"#if DEBUGputStrLn$"Looking for <<"++symbol++">>"#endifptr@(Ptraddr)<-withCStringsymbolc_lookupSymbolif(ptr==nullPtr)thenreturnNothingelsecaseaddrToHValue#addrof(#hval#)->return(Justhval)-- | Loads a function from a package module, given the package name,-- module name and symbol name.loadPackageFunction::String-- ^ Package name, including version number.->String-- ^ Module name->String-- ^ Symbol to lookup in the module->IO(Maybea)loadPackageFunctionpkgNamemodNamefunctionName=doloadPackagepkgNameresolveObjs(unloadPackagepkgName)loadFunction__(JustpkgName)modNamefunctionName---- | Load a GHC-compiled Haskell vanilla object file.-- The first arg is the path to the object file---- We make it idempotent to stop the nasty problem of loading the same-- .o twice. Also the rts is a very special package that is already-- loaded, even if we ask it to be loaded. N.B. we should insert it in-- the list of known packages.---- 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->IOModuleloadObjectpky@(Objectk)=loadObject'pkykloadObjectpky@(Packagek)=loadObject'pkykloadObject'::FilePath->Key->String->IOModuleloadObject'pkyk|("HSrts"++sysPkgSuffix)`isSuffixOf`p=return(emptyModp)|otherwise=doalreadyLoaded<-isLoadedkwhen(notalreadyLoaded)$dor<-withCStringpc_loadObjwhen(notr)(panic$"Could not load module `"++p++"'")addModulek(emptyModp)-- needs to Z-encode module namereturn(emptyModp)whereemptyModq=Moduleq(mkModidq)Vanillaundefinedky---- load a single object. no dependencies. You should know what you're-- doing.--loadModule::FilePath->IOModuleloadModuleobj=dolethifile=replaceSuffixobjhiSufexists<-doesFileExisthifileif(notexists)thenerror$"No .hi file found for "++showobjelsedohiface<-readBinIface'hifileloadObjectobj(Object(ifaceModuleNamehiface))---- | Load a generic .o file, good for loading C objects.-- You should know what you're doing..-- Returns a fairly meaningless iface value.--loadRawObject::FilePath->IOModuleloadRawObjectobj=loadObjectobj(Objectk)wherek=encode(mkModidobj)-- Z-encoded module name---- | Resolve (link) the modules loaded by the 'loadObject' function.--resolveObjs::IOa->IO()resolveObjsunloadLoaded=dor<-c_resolveObjswhen(notr)$unloadLoaded>>panic"resolvedObjs failed."-- | Unload a moduleunloadObj::Module->IO()unloadObj(Module{path=p,kind=k,key=ky})=casekofVanilla->withCStringp$\c_p->doremoved<-rmModulenamewhen(removed)$dor<-c_unloadObjc_pwhen(notr)(panic"unloadObj: failed")Shared->return()-- can't unload .so?wherename=casekyofObjects->s;Packagepk->pk---- | from ghci\/ObjLinker.c---- Load a .so type object file.--loadShared::FilePath->IOModuleloadSharedstr=do#if DEBUGputStrLn$" shared: "++str#endifmaybe_errmsg<-withCStringstr$\dll->c_addDLLdllifmaybe_errmsg==nullPtrthenreturn(Modulestr(mkModidstr)Sharedundefined(Package(mkModidstr)))elsedoe<-peekCStringmaybe_errmsgpanic$"loadShared: couldn't load `"++str++"\' because "++e---- 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-- in the environment. It is just a matter of looking it up.---- Not printing names of dependent pkgs--loadPackage::String->IO()loadPackagep=do#if DEBUGputStr(' ':p)>>hFlushstdout#endif(libs,dlls)<-lookupPkgpmapM_(\l->loadObjectl(Package(mkModidl)))libs#if DEBUGputStr(' ':showlibs)>>hFlushstdoutputStr(' ':showdlls)>>hFlushstdout#endifmapM_loadShareddlls---- 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.---- Note that we currently need to unload everything. grumble grumble.---- We need to add the version number to the package name with 6.4 and-- over. "yi-0.1" for example. This is a bug really.--unloadPackage::String->IO()unloadPackagepkg=doletpkg'=takeWhile(/='-')pkg-- in case of *-0.1libs<-liftM(\(a,_)->(filter(isSublistOfpkg'))a)(lookupPkgpkg)flipmapM_libs$\p->withCStringp$\c_p->dor<-c_unloadObjc_pwhen(notr)(panic"unloadObj: failed")rmModule(mkModidp)-- unrecord this module ---- 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.--loadPackageWith::String->[PackageConf]->IO()loadPackageWithppkgconfs=do#if DEBUGputStr"Loading package">>hFlushstdout#endifmapM_addPkgConfpkgconfsloadPackagep#if DEBUGputStrLn" done"#endif-- ----------------------------------------------------------------------- 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-- the dependencies, packages first, then the modules. If it doesn't-- exist, assume the user knows what they are doing and continue. The-- linker will crash on them anyway. Second argument is any include-- paths to search in---- ToDo problem with absolute and relative paths, and different forms of-- relative paths. A user may cause a dependency to be loaded, which-- will search the incpaths, and perhaps find "./Foo.o". The user may-- then explicitly load "Foo.o". These are the same, and the loader-- should ignore the second load request. However, isLoaded will say-- that "Foo.o" is not loaded, as the full string is used as a key to-- the modenv fm. We need a canonical form for the keys -- is basename-- good enough?--loadDepends::FilePath->[FilePath]->IO(ModIface,[Module])loadDependsobjincpaths=dolethifile=replaceSuffixobjhiSufexists<-doesFileExisthifileif(notexists)thendo#if DEBUGputStrLn"No .hi file found.">>hFlushstdout#endifreturn(undefined,[])-- could be considered fatalelsedohiface<-readBinIface'hifileletds=mi_depshiface-- remove ones that we've already loadedds'<-filterMloaded.map(moduleNameString.fst).dep_mods$ds-- now, try to generate a path to the actual .o file-- fix up hierachical namesletmods_=map(\s->(s,map(\c->ifc=='.'then'/'elsec)$s))ds'-- construct a list of possible dependent modules to loadletmods=concatMap(\p->map(\(hi,m)->(hi,p</>m++".o"))mods_)incpaths-- remove modules that don't existmods'<-filterM(\(_,y)->doesFileExisty)$nubBy(\vu->sndv==sndu)mods-- now remove duplicate valid paths to the same objectletmods''=nubBy(\vu->fstv==fstu)mods'-- and find some packages to load, as well.letps=dep_pkgsdsps'<-filterMloaded.mappackageIdString.nub$ps#if DEBUGwhen(not(nullps'))$putStr"Loading package">>hFlushstdout#endifmapM_loadPackageps'#if DEBUGwhen(not(nullps'))$putStr" ... linking ... ">>hFlushstdout#endifresolveObjs(mapM_unloadPackageps')#if DEBUGwhen(not(nullps'))$putStrLn"done"putStr"Loading object"mapM_(\(m,_)->putStr(" "++m)>>hFlushstdout)mods''#endifmoduleDeps<-mapM(\(hi,m)->loadObjectm(Objecthi))mods''return(hiface,moduleDeps)-- ----------------------------------------------------------------------- Nice interface to .hi parser--getImports::String->IO[String]getImportsm=dohi<-readBinIface'(m++hiSuf)return.map(moduleNameString.fst).dep_mods.mi_deps$hi-- ----------------------------------------------------------------------- C interface--foreignimportccallsafe"lookupSymbol"c_lookupSymbol::CString->IO(Ptra)foreignimportccallunsafe"loadObj"c_loadObj::CString->IOBoolforeignimportccallunsafe"unloadObj"c_unloadObj::CString->IOBoolforeignimportccallunsafe"resolveObjs"c_resolveObjs::IOBoolforeignimportccallunsafe"addDLL"c_addDLL::CString->IOCStringforeignimportccallunsafe"initLinker"initLinker::IO()