diff --git a/plugins-multistage.cabal b/plugins-multistage.cabal --- a/plugins-multistage.cabal +++ b/plugins-multistage.cabal @@ -1,5 +1,5 @@ name: plugins-multistage -version: 0.5.3 +version: 0.6 synopsis: Dynamic linking for embedded DSLs with staged compilation description: Dynamic compilation, linking and loading of functions in staged languages. @@ -26,6 +26,9 @@ System.Plugins.MultiStage build-depends: base >= 4 && < 4.9 + , ghc + , process + , directory , template-haskell , th-desugar @@ -33,22 +36,23 @@ ghc-options: -fcontext-stack=100 --- test-suite regression --- type: exitcode-stdio-1.0 +test-suite regression + type: exitcode-stdio-1.0 --- hs-source-dirs: tests + hs-source-dirs: tests --- main-is: RegressionTests.hs + main-is: RegressionTests.hs --- default-language: Haskell2010 + default-language: Haskell2010 --- build-depends: --- plugins-multistage, --- base, --- tasty >= 0.3, --- tasty-th >= 0.1, --- tasty-quickcheck >= 0.3, --- QuickCheck >= 2.5 && < 3.0 + build-depends: + plugins-multistage, + base, + template-haskell, + tasty >= 0.3, + tasty-th >= 0.1, + tasty-quickcheck >= 0.3, + QuickCheck >= 2.5 && < 3.0 -- benchmark needforspeed -- type: exitcode-stdio-1.0 diff --git a/src/System/Plugins/MultiStage.hs b/src/System/Plugins/MultiStage.hs --- a/src/System/Plugins/MultiStage.hs +++ b/src/System/Plugins/MultiStage.hs @@ -16,6 +16,7 @@ -- * Configuration , Config(..) , defaultConfig + , defaultBuilder -- * Calling Convention , CallConv(..) @@ -33,19 +34,28 @@ import Debug.Trace +import BasicTypes (failed) +import ObjLink (initObjLinker,loadObj,resolveObjs) + import Language.Haskell.TH import Language.Haskell.TH.Desugar import Data.Int import Data.Word import Data.Maybe (mapMaybe) +import Control.Monad import Control.Applicative import Foreign.Ptr -import Foreign.Marshal (new) +import Foreign.C.String (CString,withCString) +import Foreign.Marshal (new,with) import Foreign.Marshal.Unsafe (unsafeLocalState) import Foreign.Storable +import System.Info (os) +import System.Process (readProcessWithExitCode) +import System.Directory (doesFileExist, removeFile, createDirectoryIfMissing) + -- | Configuration parameters for the function loader data Config = Config { declWorker :: Config -> Name -> Name -> [Name] -> Type -> [DecQ] , builder :: Config -> Name -> Q Body @@ -54,6 +64,7 @@ , mkHSig :: Type -> Q Type , mkCSig :: Type -> Q Type , prefix :: String + , suffix :: String , wdir :: String , opts :: [String] , safety :: Safety @@ -64,29 +75,53 @@ , builder = noBuilder , worker = noWorker , typeFromName = loadFunType - , mkHSig = return - , mkCSig = return + , mkHSig = buildType resultInIO + , mkCSig = buildType resultInIO , prefix = "c_" + , suffix = "" , wdir = "tmp" , opts = [] , safety = unsafe } noBuilder :: Config -> Name -> Q Body -noBuilder _ _ = normalB [| return nullPtr |] +noBuilder _ _ = normalB [| nullPtr |] noWorker :: Name -> [Name] -> Q Body noWorker fun as = normalB $ appsE $ map varE $ fun:as +-- | Build, load and link a C file +defaultBuilder :: Config -> Name -> Q Body +defaultBuilder Config{..} name = + normalB [|unsafeLocalState $ do + createDirectoryIfMissing True wdir + compileAndLoad srcname objname [] + lookupSymbol symbol + |] + where + base = nameBase name ++ suffix + srcname = wdir ++ "/" ++ base ++ ".c" + objname = wdir ++ "/" ++ base ++ ".o" + symbol = ldprefix ++ base -- encodeFunctionName base + ldprefix = case os of + "darwin" -> "_" + _ -> "" + +resultInIO :: CallConv +resultInIO = CallConv{..} + where + arg = return + res t = [t| IO $(return t) |] + -- | Generic function compiler and loader loadFunWithConfig :: Config -> [Name] -> Q [Dec] loadFunWithConfig conf@Config{..} names = concat <$> mapM go names where go name = do typ <- typeFromName name - let base = nameBase name - let cname = mkName $ prefix ++ base - let wname = mkName $ prefix ++ base ++ "_worker" + let base = prefix ++ nameBase name ++ suffix + let cname = mkName base + let wname = mkName $ base ++ "_worker" let args = [mkName $ 'v' : show i | i <- [1..(arity typ)]] sequence $ declWorker conf wname name args typ ++ declareWrapper cname wname args typ @@ -115,10 +150,10 @@ , funD wname [clause (map varP as) (worker rname as) []] ] where - base = nameBase name - bname = mkName $ prefix ++ base ++ "_builder" - factory = mkName $ prefix ++ base ++ "_factory" - rname = mkName $ prefix ++ base ++ "_raw" + base = prefix ++ nameBase name ++ suffix + bname = mkName $ base ++ "_builder" + factory = mkName $ base ++ "_factory" + rname = mkName $ base ++ "_raw" hsig = mkHSig typ csig = mkCSig typ @@ -152,6 +187,36 @@ go r = res r arrT t = appT (appT arrowT t) + +compileAndLoad :: FilePath -> FilePath -> [String] -> IO () +compileAndLoad cname oname opts = do + exists <- doesFileExist oname + when exists $ removeFile oname + compileC cname oname opts + initObjLinker + _ <- loadObj oname + res <- resolveObjs + when (failed res) $ error $ "Symbols in " ++ oname ++ " could not be resolved" + +compileC :: String -> String -> [String] -> IO () +compileC srcfile objfile opts = do + let args = [ "-optc -std=c99" + , "-optc -Wall" + , "-w" + , "-c" + ] + (_,stdout,stderr) <- readProcessWithExitCode "ghc" (args ++ opts ++ ["-o",objfile,srcfile]) "" + let output = stdout ++ stderr + unless (null output) $ putStrLn output + +lookupSymbol :: String -> IO (Ptr a) +lookupSymbol symbol = do + mptr <- withCString symbol _lookupSymbol + when (mptr == nullPtr) $ error $ "Symbol " ++ symbol ++ " not found" + return mptr + +foreign import ccall safe "lookupSymbol" + _lookupSymbol :: CString -> IO (Ptr a) -- | Apply a type family applyTF :: Name -> Type -> Q Type diff --git a/tests/RegressionTests.hs b/tests/RegressionTests.hs new file mode 100644 --- /dev/null +++ b/tests/RegressionTests.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck + +import Data.Word + +import System.Plugins.MultiStage + +prog0 :: Word32 -> Word32 -> Word32 +prog0 = (+) + +loadFunWithConfig defaultConfig{ wdir="tests",builder=defaultBuilder } ['prog0 ] +loadFunWithConfig defaultConfig{ wdir="tests",builder=defaultBuilder,suffix="_suf"} ['prog0 ] + +prop_prog0 :: Word32 -> Word32 -> Property +prop_prog0 x y = prog0 x y === c_prog0 x y + +prop_prog0_suf :: Word32 -> Word32 -> Property +prop_prog0_suf x y = prog0 x y === c_prog0_suf x y + +-- prog1 :: Vector1 Index -> Vector1 Index +-- prog1 = id + +-- loadFunWithConfig defaultConfig ['prog1 ] + +-- prog2 :: Vector1 Index -> PushVector1 Index +-- prog2 v = let pv = toPush v in pv PV.++ pv + +-- loadFun ['prog2 ] + +-- prop_prog1 :: Property +-- prop_prog1 = eval prog1 === c_prog1 + +-- prop_prog2 :: NonEmptyList WordN -> Property +-- prop_prog2 (NonEmpty xs) = eval prog2 xs === c_prog2 xs + +tests :: TestTree +tests = $(testGroupGenerator) + +main :: IO () +main = defaultMain tests