packages feed

plugins-multistage 0.5.3 → 0.6

raw patch · 3 files changed

+140/−24 lines, 3 filesdep +QuickCheckdep +directorydep +ghcdep ~base

Dependencies added: QuickCheck, directory, ghc, plugins-multistage, process, tasty, tasty-quickcheck, tasty-th

Dependency ranges changed: base

Files

plugins-multistage.cabal view
@@ -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
src/System/Plugins/MultiStage.hs view
@@ -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
+ 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