wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Adapt to work with GHC 6.12

Browse Source 
- Adapted the package to work with GHC 6.12
- Plugins that depend on the old base3 are currently
  not correctly loaded as the plugin loaded misses
  the dependence on syb (leading to unresolved symbols)
- Cleaned up most of the testsuite (there are still
  some outstanding failures, of which only one
  demonstrates a bug in the plugins library as far
  as I can see — see previous bullet point)
- Cleaned out a little cruft (but more could be done)
This commit is contained in:
Manuel M T Chakravarty 2010-09-22 05:10:19 +00:00
parent 67635f72b8
commit 838f8c0aca
34 changed files with 89 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Setup.lhs
View File

@ -2,4 +2,4 @@
> module Main where
> import Distribution.Simple
> main :: IO ()
> main = defaultMainWithHooks defaultUserHooks
> main = defaultMainWithHooks autoconfUserHooks

4
plugins.cabal
View File

@ -1,5 +1,5 @@
name: plugins
version: 1.4.1
version: 1.5.1
homepage: http://code.haskell.org/~dons/code/hs-plugins
synopsis: Dynamic linking for Haskell and C objects
description: Dynamic linking and runtime evaluation of Haskell,
@ -14,6 +14,7 @@ author: Don Stewart 2004-2009
maintainer: Don Stewart <dons@galois.com>
cabal-version: >= 1.6
build-type: Configure
Tested-with: GHC >= 6.12.1
extra-source-files: config.guess, config.h.in, config.mk.in, config.sub,
configure, configure.ac, install.sh, Makefile,
testsuite/makewith/io/TestIO.conf.in,
@ -46,6 +47,7 @@ library
containers,
array,
directory,
filepath,
random,
process,
ghc >= 6.10,

6
src/System/Eval/Haskell.hs
View File

@ -51,11 +51,11 @@ import System.Plugins.Load
import Data.Dynamic ( Dynamic )
import Data.Typeable ( Typeable )
import Data.Either
import Data.Either ( )
import Data.Map as Map
import Data.Char
import System.IO
import System.IO ( )
import System.Directory
import System.Random
import System.IO.Unsafe
@ -122,7 +122,7 @@ eval_ src mods args ldflags incs = do
pwd <- getCurrentDirectory
(cmdline,loadpath) <- getPaths -- find path to altdata
tmpf <- mkUniqueWith dynwrap src mods
status <- make tmpf $ ["-Onot"] ++ cmdline ++ args
status <- make tmpf $ ["-O0"] ++ cmdline ++ args
m_rsrc <- case status of
MakeSuccess _ obj -> do
m_v <- dynload obj (pwd:incs) (loadpath++ldflags) symbol

2
src/System/Eval/Utils.hs
View File

@ -71,7 +71,7 @@ escape s = concatMap (\c -> showLitChar c $ "") s
--
getPaths :: IO ([String],[String])
getPaths = do
let make_line = ["-Onot","-fglasgow-exts","-package","plugins"]
let make_line = ["-O0","-fglasgow-exts","-package","plugins"]
return (make_line,[])
-- ---------------------------------------------------------------------

9
src/System/MkTemp.hs
View File

@ -36,7 +36,7 @@ module System.MkTemp (
) where
import Data.List
import Data.List ( )
import Data.Char ( chr, ord, isDigit )
import Control.Monad ( liftM )
import Control.Exception ( handleJust )
@ -44,13 +44,12 @@ import System.FilePath ( splitFileName, (</>) )
import System.Directory ( doesDirectoryExist, doesFileExist, createDirectory )
import System.IO
#ifndef __MINGW32__
import System.IO.Error ( isAlreadyExistsError )
import System.IO.Error ( mkIOError, alreadyExistsErrorType,
isAlreadyExistsError )
#else
import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError )
#endif
import GHC.IOBase (IOException(..), IOErrorType(AlreadyExists) )
#ifndef __MINGW32__
import qualified System.Posix.Internals ( c_getpid )
#endif
@ -216,7 +215,7 @@ open0600 f = do
if b then ioError err -- race
else openFile f ReadWriteMode
where
err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing
err = mkIOError alreadyExistsErrorType "op0600" Nothing (Just f)
{-
-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600)

76
src/System/Plugins/Env.hs
View File

@ -52,16 +52,16 @@ module System.Plugins.Env (
import System.Plugins.LoadTypes (Module)
import System.Plugins.PackageAPI {- everything -}
import System.Plugins.Consts ( sysPkgConf, sysPkgSuffix )
import System.Plugins.Consts ( sysPkgSuffix )
import Control.Monad ( liftM )
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
import Data.Maybe ( isJust, isNothing, fromMaybe )
import Data.List ( isInfixOf, nub )
import Data.List ( nub )
import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( hGetContents )
import System.Directory ( doesFileExist )
import System.Process ( waitForProcess, runInteractiveCommand )
#if defined(CYGWIN) || defined(__MINGW32__)
import Prelude hiding ( catch, ioError )
import System.IO.Error ( catch, ioError, isDoesNotExistError )
@ -91,6 +91,10 @@ emptyFM = M.empty
addToFM :: (Ord key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt
addToFM = \m k e -> M.insert k e m
addWithFM :: (Ord key)
=> (elt -> elt -> elt) -> FiniteMap key elt -> key -> elt -> FiniteMap key elt
addWithFM = \comb m k e -> M.insertWith comb k e m
delFromFM :: (Ord key) => FiniteMap key elt -> key -> FiniteMap key elt
delFromFM = flip M.delete
@ -160,7 +164,9 @@ env = unsafePerformIO $ do
ref2 <- newIORef emptyFM
p <- grabDefaultPkgConf
ref3 <- newIORef p -- package.conf info
ref4 <- newIORef (S.fromList ["base","Cabal-1.1.6","haskell-src-1.0"]) -- FIXME
ref4 <- newIORef (S.fromList ["base","Cabal","haskell-src", "containers",
"arrays", "directory", "random", "process",
"ghc", "ghc-prim"])
ref5 <- newIORef emptyFM -- merged files
return (mvar, ref1, ref2, ref3, ref4, ref5)
{-# NOINLINE env #-}
@ -282,15 +288,25 @@ addPkgConf f = do
modifyPkgEnv env $ \ls -> return $ union ls ps
--
-- | add a new FM for the package.conf to the list of existing ones
-- | add a new FM for the package.conf to the list of existing ones; if a package occurs multiple
-- times, pick the one with the higher version number as the default (e.g., important for base in
-- GHC 6.12)
--
union :: PkgEnvs -> [PackageConfig] -> PkgEnvs
union ls ps' =
let fm = emptyFM -- new FM for this package.conf
in foldr (\p fm' -> if (display $ package p) == "base" -- ghc doesn't supply a version with 'base'
-- for some reason.
then addToFM (addToFM fm' (display $ package p) p) (packageName p) p
else addToFM fm' (packageName p) p) fm ps' : ls
in foldr addOnePkg fm ps' : ls
where
-- we add each package with and without it's version number
addOnePkg p fm' = addToPkgEnvs (addToPkgEnvs fm' (display $ sourcePackageId p) p)
(packageName p) p
-- if no version number specified, pick the higher version
addToPkgEnvs = addWithFM higherVersion
higherVersion pkgconf1 pkgconf2
| installedPackageId pkgconf1 >= installedPackageId pkgconf2 = pkgconf1
| otherwise = pkgconf2
--
-- | generate a PkgEnv from the system package.conf
@ -300,11 +316,10 @@ union ls ps' =
--
grabDefaultPkgConf :: IO PkgEnvs
grabDefaultPkgConf = do
pkg_confs <- get_ghc_configs
packages <- mapM readPackageConf pkg_confs
return $ foldl union [] packages
pc <- configureAllKnownPrograms silent defaultProgramConfiguration
pkgIndex <- getInstalledPackages silent [GlobalPackageDB, UserPackageDB] pc
return $ [] `union` allPackages pkgIndex
--
-- parse a source file, expanding any $libdir we see.
@ -312,7 +327,7 @@ grabDefaultPkgConf = do
readPackageConf :: FilePath -> IO [PackageConfig]
readPackageConf f = do
pc <- configureAllKnownPrograms silent defaultProgramConfiguration
pkgIndex <- getInstalledPackages silent (SpecificPackageDB f) pc
pkgIndex <- getInstalledPackages silent [GlobalPackageDB, UserPackageDB, SpecificPackageDB f] pc
return $ allPackages pkgIndex
-- -----------------------------------------------------------
@ -345,13 +360,10 @@ isStaticPkg pkg = withStaticPkgEnv env $ \set -> return $ S.member pkg set
--
lookupPkg :: PackageName -> IO ([FilePath],[FilePath])
lookupPkg p = do
t <- lookupPkg' p
(ps, (f, g)) <- lookupPkg' p
static <- isStaticPkg p
case t of ([],(f,g)) -> return (f,if static then [] else g)
(ps,(f,g)) -> do gss <- mapM lookupPkg ps
let (f',g') = unzip gss
return $ (nub $ (concat f') ++ f
,if static then [] else nub $ (concat g') ++ g)
(f', g') <- liftM unzip $ mapM lookupPkg ps
return $ (nub $ (concat f') ++ f, if static then [] else nub $ (concat g') ++ g)
data LibrarySpec
= DLL String -- -lLib
@ -506,25 +518,3 @@ addMerge a b z = modifyMerged env $ \fm -> return $ addToFM fm (a,b) z
[] </> b = b
a </> b = a ++ "/" ++ b
-------------------------------------------------------------------------
--
-- 'run_cmd' executes command and returns it's standard output
-- as 'String'
run_cmd :: String -> IO String
run_cmd cmd = do (_hI, hO, _hE, hProcess) <- runInteractiveCommand cmd
output <- hGetContents hO
_exitCode <- waitForProcess hProcess
return output
--
-- 'get_ghc_configs' returns list of strings of packages.conf files in system
get_ghc_configs :: IO [String]
get_ghc_configs = do ghc_out <- run_cmd "ghc-pkg list"
let configs = map (reverse.strip_trash.reverse) $
filter (isInfixOf sysPkgConf) $ lines ghc_out
return configs
-- | strip ":\r?" from string head
where strip_trash [] = []
strip_trash xs@(x:xs') | x `elem` ":\r" = strip_trash xs'
| otherwise = xs

7
src/System/Plugins/Load.hs
View File

@ -81,6 +81,7 @@ import Control.Monad ( when, filterM, liftM )
import System.Directory ( doesFileExist, removeFile )
import Foreign.C.String ( CString, withCString, peekCString )
import GHC ( defaultCallbacks )
import GHC.Ptr ( Ptr(..), nullPtr )
import GHC.Exts ( addrToHValue# )
import GHC.Prim ( unsafeCoerce# )
@ -95,7 +96,7 @@ ifaceModuleName = moduleNameString . moduleName . mi_module
readBinIface' :: FilePath -> IO ModIface
readBinIface' hi_path = do
-- kludgy as hell
e <- newHscEnv undefined
e <- newHscEnv defaultCallbacks undefined
initTcRnIf 'r' e undefined undefined (readBinIface IgnoreHiWay QuietBinIFaceReading hi_path)
-- TODO need a loadPackage p package.conf :: IO () primitive
@ -438,7 +439,7 @@ loadFunction__ pkg m valsym
#if DEBUG
putStrLn $ "Looking for <<"++symbol++">>"
#endif
ptr@(~(Ptr addr)) <- withCString symbol c_lookupSymbol
ptr@(Ptr addr) <- withCString symbol c_lookupSymbol
if (ptr == nullPtr)
then return Nothing
else case addrToHValue# addr of
@ -706,7 +707,7 @@ getImports m = do
-- ---------------------------------------------------------------------
-- C interface
--
foreign import ccall threadsafe "lookupSymbol"
foreign import ccall safe "lookupSymbol"
c_lookupSymbol :: CString -> IO (Ptr a)
foreign import ccall unsafe "loadObj"

4
src/System/Plugins/PackageAPI.hs
View File

@ -58,8 +58,8 @@ type PackageName = String
type PackageConfig = InstalledPackageInfo
packageName = display . package
packageName_ = pkgName . package
packageName = display . pkgName . sourcePackageId
packageName_ = pkgName . sourcePackageId
packageDeps = (map display) . depends
updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =

2
src/System/Plugins/Parser.hs
View File

@ -28,7 +28,7 @@ module System.Plugins.Parser (
import Data.List
import Data.Char
import Data.Either
import Data.Either ( )
#if defined(WITH_HSX)
import Language.Haskell.Hsx

10
src/System/Plugins/Process.hs
View File

@ -14,7 +14,7 @@ import Control.Concurrent (forkIO)
import qualified Posix as P
#endif
import qualified Control.OldException as E
import qualified Control.Exception as E
--
-- slight wrapper over popen for calls that don't care about stdin to the program
@ -38,7 +38,7 @@ type ProcessID = ProcessHandle
--
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID)
popen file args minput =
E.handle (\e -> return ([],show e, error (show e))) $ do
E.handle (\e -> return ([],show (e::E.IOException), error (show e))) $ do
(inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing
@ -55,8 +55,8 @@ popen file args minput =
-- data gets pulled as it becomes available. you have to force the
-- output strings before waiting for the process to terminate.
--
forkIO (E.evaluate (length output) >> return ())
forkIO (E.evaluate (length errput) >> return ())
_ <- forkIO (E.evaluate (length output) >> return ())
_ <- forkIO (E.evaluate (length errput) >> return ())
-- And now we wait. We must wait after we read, unsurprisingly.
exitCode <- waitForProcess pid -- blocks without -threaded, you're warned.
@ -79,7 +79,7 @@ popen file args minput =
--
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID)
popen f s m =
E.handle (\e -> return ([], show e, error $ show e )) $ do
E.handle (\e -> return ([], show (e::IOException), error $ show e )) $ do
x@(_,_,pid) <- P.popen f s m
b <- P.getProcessStatus True False pid -- wait
return $ case b of

2
testsuite/build.mk
View File

@ -13,7 +13,7 @@ REALBIN= ./Main
API_OBJ= api/API.o
INCLUDES= -i$(TOP)/testsuite/$(TEST)/api
GHCFLAGS= -Onot -cpp -fglasgow-exts
GHCFLAGS= -O0 -cpp -fglasgow-exts
.SUFFIXES : .o .hs .hi .lhs .hc .s

2
testsuite/dynload/io/TestIO.hs
View File

@ -7,7 +7,7 @@
module TestIO ( resource_dyn ) where
import API
import AltData.Dynamic
import Data.Dynamic
import System.IO
import System.Posix.Types ( ProcessID, Fd )

2
testsuite/dynload/io/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
data TestIO = TestIO {
field :: IO String

2
testsuite/dynload/poly/Plugin.hs
View File

@ -1,7 +1,7 @@
module Plugin where
import API
import AltData.Dynamic
import Data.Dynamic
my_fun = plugin {
equals = \x y -> (x /= y) -- a strange equals function :)

2
testsuite/dynload/poly/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
data Interface = Interface {
equals :: forall t. Eq t => t -> t -> Bool

2
testsuite/dynload/should_fail/Plugin.hs
View File

@ -2,7 +2,7 @@
module Plugin where
import API
import AltData.Dynamic
import Data.Dynamic
v :: Int
v = 0xdeadbeef

2
testsuite/dynload/should_fail/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
data Interface = Interface {
function :: String

2
testsuite/dynload/should_fail_1/Plugin.hs
View File

@ -5,7 +5,7 @@
module Plugin where
import API
import AltData.Dynamic
import Data.Dynamic
v :: Int -> Int
v = \x -> 0xdeadbeef

2
testsuite/dynload/should_fail_1/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
data Interface = Interface {
function :: String

2
testsuite/dynload/should_fail_2/Plugin.in
View File

@ -9,7 +9,7 @@
module Plugin where
import API
import AltData.Typeable
import Data.Typeable
import GHC.Base
v :: Int

2
testsuite/dynload/should_fail_2/Plugin.stub
View File

@ -3,7 +3,7 @@
module Plugin ( resource_dyn ) where
import API
import AltData.Dynamic
import Data.Dynamic
resource = plugin

2
testsuite/dynload/should_fail_2/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
import GHC.Base
data Interface = Interface {

2
testsuite/dynload/should_fail_3/Plugin.in
View File

@ -9,7 +9,7 @@ module Plugin where
import API
import AltData.Typeable
import Data.Typeable
import GHC.Base
v :: Int

2
testsuite/dynload/should_fail_3/Plugin.stub
View File

@ -3,7 +3,7 @@
module Plugin ( resource_dyn ) where
import API
import AltData.Dynamic
import Data.Dynamic
resource = plugin

2
testsuite/dynload/should_fail_3/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
import GHC.Base
data Interface = Interface {

2
testsuite/dynload/simple/Plugin.hs
View File

@ -2,7 +2,7 @@
module Plugin where
import API
import AltData.Dynamic
import Data.Dynamic
my_fun = plugin { function = "plugin says \"hello\"" }

2
testsuite/dynload/simple/api/API.hs
View File

@ -2,7 +2,7 @@
module API where
import AltData.Typeable
import Data.Typeable
data Interface = Interface {
function :: String

2
testsuite/eval/eval_fn1/Poly.hs
View File

@ -1,7 +1,7 @@
{-# OPTIONS -cpp -fglasgow-exts #-}
module Poly where
import AltData.Typeable
import Data.Typeable
data Fn = Fn {fn :: forall t. Eq t => t -> t -> Bool}

5
testsuite/hier/hier1/prog/Main.hs
View File

@ -9,8 +9,7 @@ import System.Plugins
import API
import Modules.Flags as Flags
rec = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 }
record = Flags.FlagRec { Flags.f1 = 4, Flags.f2 = 10 }
main = do
@ -18,4 +17,4 @@ main = do
case status of
LoadFailure _ -> error "load failed"
LoadSuccess _ v -> do let func = dbFunc v
print (func rec)
print (func record)

8
testsuite/misc/mkstemps/Main.hs
View File

@ -36,7 +36,7 @@ main = do
() <- if (not $ all isJust ts)
then putStrLn $ "mkstemp couldn't create all expected files"
else putStrLn $ "mkstemp: created "++(show $ length $ catMaybes ts)++" files"
else putStrLn $ "mkstemp: created "++(show $ length $ catMaybes ts)++" files"
rmAll ts
------------------------------------------------------------------------
@ -47,7 +47,7 @@ main = do
_ -> return v ) [1..2000]
() <- if (not $ all isJust ts)
then putStrLn $ "mkstemps couldn't create all expected files"
else putStrLn $ "mkstemps: created "++(show $ length $ catMaybes ts)++" files"
else putStrLn $ "mkstemps: created "++(show $ length $ catMaybes ts)++" files"
rmAll ts
------------------------------------------------------------------------
@ -55,8 +55,8 @@ main = do
--
ts <- mapM (\_ -> mkdtemp "t/XXXXXXXXXX") [1..2000]
() <- if (not $ all isJust ts)
then putStrLn $ "mkdtemp: couldn't create all expected directories"
else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories"
then putStrLn $ "mkdtemp: couldn't create all expected directories"
else putStrLn $ "mkdtemp: created "++(show $ length $ catMaybes ts)++" directories"
rmAllDirs ts
------------------------------------------------------------------------

6
testsuite/misc/mkstemps/expected
View File

@ -1,5 +1,5 @@
created 53 files
correctly ran out of permutations
mkstemp: created 10000 files
mkstemps: created 2000 files
mkdtemp: created 2000 directories
mkstemp: created 10000 files
mkstemps: created 2000 files
mkdtemp: created 2000 directories

2
testsuite/objc/expression_parser/PluginEvalAux.hs
View File

@ -15,7 +15,7 @@ symbol = "resource"
evalWithStringResult :: FilePath -> String -> IO String
evalWithStringResult srcFile s = do
status <- make srcFile ["-Onot"]
status <- make srcFile ["-O0"]
case status of
MakeFailure err -> putStrLn "error occured" >> return (show err)
MakeSuccess _ obj -> load' obj

4
testsuite/pdynload/poly/Plugin.hs
View File

@ -1,9 +1,11 @@
module Plugin where
import Data.Typeable
import Data.Generics.Aliases
import Data.Generics.Schemes
import API
resource = rsrc {
field = id listify
field = id listify :: Typeable r => (r -> Bool) -> GenericQ [r]
}

2
testsuite/plugs/runplugs/Makefile
View File

@ -1,4 +1,4 @@
GHCFLAGS= -Onot $(GHC_EXTRA_OPTS)
GHCFLAGS= -O0 $(GHC_EXTRA_OPTS)
PKGFLAGS= -package posix
PKGFLAGS+= -package plugins