packages feed

plugins-multistage 0.5.3 → 0.6.3

raw patch · 3 files changed

Files

plugins-multistage.cabal view
@@ -1,5 +1,5 @@ name:           plugins-multistage-version:        0.5.3+version:        0.6.3 synopsis:       Dynamic linking for embedded DSLs with staged compilation description:    Dynamic compilation, linking and loading of functions in                 staged languages.@@ -12,7 +12,7 @@ license-file:   LICENSE stability:      experimental build-type:     Simple-cabal-version:  >= 1.14+cabal-version:  1.14 tested-with:    GHC==7.6  source-repository head@@ -25,30 +25,37 @@   exposed-modules:     System.Plugins.MultiStage -  build-depends: base              >= 4     && < 4.9+  build-depends: base              >= 4     && < 5.9+               , ghc+               , process+               , directory                , template-haskell                , th-desugar +  if impl(ghc >= 8.0.0)+      build-depends: ghci+   hs-source-dirs: src    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
src/System/Plugins/MultiStage.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}@@ -16,6 +17,7 @@   -- * Configuration   , Config(..)   , defaultConfig+  , defaultBuilder    -- * Calling Convention   , CallConv(..)@@ -33,19 +35,35 @@  import Debug.Trace +import BasicTypes (failed)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800+import GHCi.ObjLink (initObjLinker,loadObj,resolveObjs)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 802+import GHCi.ObjLink (ShouldRetainCAFs(..))+#endif+#else+import ObjLink (initObjLinker,loadObj,resolveObjs)+#endif+ 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 +72,7 @@                      , mkHSig       :: Type -> Q Type                      , mkCSig       :: Type -> Q Type                      , prefix       :: String+                     , suffix       :: String                      , wdir         :: String                      , opts         :: [String]                      , safety       :: Safety@@ -64,29 +83,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@@ -100,7 +143,11 @@ loadFunType name = do   info <- reify name   case info of+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800+    (VarI _ t _) -> return t+#else     (VarI _ t _ _) -> return t+#endif     _ -> error $ unwords ["loadFun:",show (nameBase name)                          ,"is not a function:",show info] @@ -109,16 +156,18 @@     [ declareImport conf factory csig     , sigD bname $ appT [t|Ptr|] csig     , funD bname [clause [] (builder conf name) []]+    , pragInlD bname NoInline FunLike AllPhases     , sigD rname csig     , funD rname [clause [] (normalB [|$(varE factory) $ castPtrToFunPtr $(varE bname)|]) []]     , sigD wname hsig     , funD wname [clause (map varP as) (worker rname as) []]+    , pragInlD wname NoInline FunLike AllPhases     ]   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 +201,44 @@     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+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 802+    initObjLinker RetainCAFs+#else+    initObjLinker+#endif+    _ <- loadObj oname+    res <- resolveObjs+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800+    when (not res) $ error $ "Symbols in " ++ oname ++ " could not be resolved"+#else+    when (failed res) $ error $ "Symbols in " ++ oname ++ " could not be resolved"+#endif++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
+ tests/RegressionTests.hs view
@@ -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