plugins-multistage (empty) → 0.3
raw patch · 6 files changed
+571/−0 lines, 6 filesdep +QuickCheckdep +basedep +criterionsetup-changed
Dependencies added: QuickCheck, base, criterion, deepseq, plugins, plugins-multistage, storable-record, storable-tuple, tasty, tasty-quickcheck, tasty-th, template-haskell, th-expand-syns
Files
- LICENSE +25/−0
- Setup.hs +3/−0
- bench/Benchmark.hs +53/−0
- plugins-multistage.cabal +72/−0
- src/System/Plugins/MultiStage.hs +375/−0
- tests/RegressionTests.hs +43/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2012-2014, Anders Persson+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the author nor the names of contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ bench/Benchmark.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TemplateHaskell #-}++import Feldspar hiding (force)+import Feldspar.Vector+import Feldspar.Compiler.Plugin+import Feldspar.Algorithm.CRC++import Foreign.Marshal (alloca)++import Control.DeepSeq (force)+import Control.Exception (evaluate)++import Criterion.Main++testdata :: [Word8]+testdata = Prelude.take (16*1024) $ cycle [1,2,3,4]++naive :: Vector1 Word8 -> Data Word16+naive = crcNaive 0x8005 0++normal :: Vector1 Word8 -> Data Word16+normal v = share (makeCrcTable 0x8005) $ \t -> crcNormal t 0 v++h_naive :: [Word8] -> Word16+h_naive = eval naive+loadFun 'naive++h_normal :: [Word8] -> Word16+h_normal = eval normal+loadFun 'normal++main :: IO ()+main = alloca $ \out -> do+ d <- evaluate $ force testdata+ pd <- pack d >>= evaluate+ _ <- evaluate c_naive_builder+ _ <- evaluate c_normal_builder+ defaultMain+ [+ bgroup "evaluated"+ [ bench "h_naive" $ nf h_naive (Prelude.take 1024 d)+ , bench "h_normal" $ nf h_normal (Prelude.take 1024 d)+ ]+ , bgroup "compiled marshal"+ [ bench "c_naive" $ c_naive_worker d+ , bench "c_normal" $ c_normal_worker d+ ]+ , bgroup "compiled"+ [ bench "c_naive" $ c_naive_raw pd out+ , bench "c_normal" $ c_normal_raw pd out+ ]+ ]+
+ plugins-multistage.cabal view
@@ -0,0 +1,72 @@+name: plugins-multistage+version: 0.3+synopsis: Dynamic linking for embedded DSLs with staged compilation+description: Dynamic compilation, linking and loading of functions in+ staged languages.++category: System+copyright: Copyright (c) 2012-2014, Anders Persson+author: Anders Persson <anders.cj.persson@gmail.com>+maintainer: Anders Persson <anders.cj.persson@gmail.com>+license: BSD3+license-file: LICENSE+stability: experimental+build-type: Simple+cabal-version: >= 1.14+tested-with: GHC==7.6++source-repository head+ type: git+ location: https://github.com/emwap/plugins-multistage++library+ default-language: Haskell2010++ exposed-modules:+ System.Plugins.MultiStage++ build-depends: base >= 4 && < 4.8+ , plugins >= 1.5.3 && < 2+ , template-haskell+ , th-expand-syns >= 0.3+ , storable-record < 0.1+ , storable-tuple < 0.1++ hs-source-dirs: src++ ghc-options: -fcontext-stack=100++test-suite regression+ type: exitcode-stdio-1.0++ hs-source-dirs: tests++ main-is: RegressionTests.hs++ default-language: Haskell2010++ build-depends:+ plugins-multistage,+ base,+ tasty >= 0.3,+ tasty-th >= 0.1,+ tasty-quickcheck >= 0.3,+ QuickCheck >= 2.5 && < 3.0++benchmark needforspeed+ type: exitcode-stdio-1.0++ hs-source-dirs: bench++ main-is: Benchmark.hs++ default-language: Haskell2010++ ghc-options: -O2++ build-depends:+ plugins-multistage,+ base,+ deepseq,+ criterion+
+ src/System/Plugins/MultiStage.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Generic components+module System.Plugins.MultiStage+ (+ -- * Loading+ loadFunWithConfig+ , loadFunType++ -- * Configuration+ , Config(..)+ , defaultConfig++ -- * Calling Convention+ , CallConv(..)+ , buildType+ , applyTF+ , expandTF++ -- * Marshaling+ , pack+ , unpack+ , Reference(..)+ , Marshal(..)+ )+where++import Language.Haskell.TH+import Language.Haskell.TH.ExpandSyns++import Data.Int+import Data.Word+import Data.Maybe (mapMaybe)+import Control.Applicative++import Foreign.Ptr+import Foreign.Marshal (new)+import Foreign.Marshal.Unsafe (unsafeLocalState)+import Foreign.Storable++-- | Configuration parameters for the function loader+data Config = Config { declWorker :: Config -> Name -> Name -> [Name] -> Type -> [DecQ]+ , builder :: Config -> Name -> Q Body+ , worker :: Name -> [Name] -> Q Body+ , typeFromName :: Name -> Q Type+ , mkHSig :: Type -> Q Type+ , mkCSig :: Type -> Q Type+ , prefix :: String+ , wdir :: String+ , opts :: [String]+ }++defaultConfig :: Config+defaultConfig = Config { declWorker = declareWorker+ , builder = noBuilder+ , worker = noWorker+ , typeFromName = loadFunType+ , mkHSig = return+ , mkCSig = return+ , prefix = "c_"+ , wdir = "tmp"+ , opts = []+ }++noBuilder :: Config -> Name -> Q Body+noBuilder _ _ = normalB [| return nullPtr |]++noWorker :: Name -> [Name] -> Q Body+noWorker fun as = normalB $ appsE $ map varE $ fun:as++-- | Generic function compiler and loader+loadFunWithConfig :: Config -> Name -> Q [Dec]+loadFunWithConfig conf@Config{..} name = do+ typ <- typeFromName name+ let base = nameBase name+ let cname = mkName $ prefix ++ base+ let wname = mkName $ prefix ++ base ++ "_worker"+ let args = [mkName $ 'v' : show i | i <- [1..(arity typ)]]+ sequence $ declWorker conf wname name args typ+ ++ declareWrapper cname wname args typ+ where+ arity :: Type -> Int+ arity (AppT (AppT ArrowT _) r) = 1 + arity r+ arity _ = 0++-- | Extract the type of the supplied function name+loadFunType :: Name -> Q Type+loadFunType name = do+ info <- reify name+ case info of+ (VarI _ t _ _) -> return t+ _ -> error $ unwords ["loadFun:",show (nameBase name)+ ,"is not a function:",show info]++declareWorker :: Config -> Name -> Name -> [Name] -> Type -> [DecQ]+declareWorker conf@Config{..} wname name as typ =+ [ declareImport factory csig+ , sigD bname $ appT [t|Ptr|] csig+ , funD bname [clause [] (builder conf name) []]+ , sigD rname csig+ , funD rname [clause [] (normalB [|$(varE factory) $ castPtrToFunPtr $(varE bname)|]) []]+ , sigD wname hsig+ , 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"+ hsig = mkHSig typ+ csig = mkCSig typ++declareWrapper :: Name -> Name -> [Name] -> Type -> [DecQ]+declareWrapper cname wname as typ =+ [ sigD cname (return typ)+ , funD cname [clause (map varP as) (wrapper wname as) [] ]+ ]++declareImport :: Name -> TypeQ -> DecQ+declareImport name csig =+ forImpD cCall safe "dynamic" name [t|FunPtr $(csig) -> $(csig)|]++wrapper :: Name -> [Name] -> Q Body+wrapper workername args = normalB+ [|unsafeLocalState $(appsE $ map varE $ workername : args) |]+++-- | The Calling Convention specifies how a type should be converted+data CallConv = CallConv { arg :: Type -> Q Type+ -- ^ Convert an argument+ , res :: Type -> Q Type+ -- ^ Convert the result+ }++-- | Convert a type using the supplied calling convention+buildType :: CallConv -> Type -> Q Type+buildType CallConv{..} typ = go typ >>= expandTF+ where+ go (AppT (AppT ArrowT t) r) = arg t `arrT` go r+ go r = res r++ arrT t = appT (appT arrowT t)++-- | Apply a type family+-- Walk the type and apply the type family to every element that is an+-- instance of @tf@+applyTF :: Name -> Type -> Q Type+applyTF tf typ = expandSyns typ >>= go+ where+ go t@(AppT c@(ConT _) x) = do+ inst <- isInstance tf [t]+ if inst+ then appT (conT tf) (return t)+ else appT (return c) (go x)+ go (AppT t1 t2) = appT (go t1) (go t2)+ go t = return t++-- | Expand type families+expandTF :: Type -> Q Type+expandTF = down+ where+ down :: Type -> Q Type+ down (AppT t1 t2) = appT (down t1) (down t2) >>= up+ down t = up t++ up :: Type -> Q Type+ up t@(AppT (ConT fam) t1) = do+ info <- reify fam+ case info of+ FamilyI{} -> do+ is <- reifyInstances fam [t1]+ case mapMaybe projInst is of+ [(AppT p1 (VarT pv1),pt2)]+ | AppT p2 et <- t1+ , p1 == p2 -> down $ substInType (pv1,et) pt2+ [(p1,value)]+ | p1 == value -> up value+ _ -> return t+ _ -> return t+ up (AppT t1 t2) = appT (return t1) (return t2)+ up t = return t++ projInst :: Dec -> Maybe (Type, Type)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+ projInst (TySynInstD _ (TySynEqn [pattern] typ)) = Just (pattern,typ)+#else+ projInst (TySynInstD _ [pattern] typ) = Just (pattern,typ)+#endif+ projInst _ = Nothing++-- | Pack a value into its runtime representation+--+-- > pack a = to a >>= ref+--+pack :: (Reference (Rep a), Marshal a) => a -> IO (Ref (Rep a))+pack a = to a >>= ref++-- | Unpack a value from its runtime representation+--+-- > unpack a = deref a >>= from+--+unpack :: (Reference (Rep a), Marshal a) => Ref (Rep a) -> IO a+unpack a = deref a >>= from++-- | Optionally make a refrence of a value+class Reference a+ where+ -- | The type of a referenced value+ type Ref a :: *++ -- | Convert to a referenced value+ ref :: a -> IO (Ref a)+ default ref :: (a ~ Ref a) => a -> IO (Ref a)+ {-# INLINE ref #-}+ ref a = return a++ -- | Convert from a referenced value+ -- In the IO monad to allow @peek@ing through the reference.+ deref :: Ref a -> IO a+ default deref :: (a ~ Ref a) => Ref a -> IO a+ {-# INLINE deref #-}+ deref a = return a++instance Reference Bool where type Ref Bool = Bool+instance Reference Int8 where type Ref Int8 = Int8+instance Reference Int16 where type Ref Int16 = Int16+instance Reference Int32 where type Ref Int32 = Int32+instance Reference Int64 where type Ref Int64 = Int64+instance Reference Word8 where type Ref Word8 = Word8+instance Reference Word16 where type Ref Word16 = Word16+instance Reference Word32 where type Ref Word32 = Word32+instance Reference Word64 where type Ref Word64 = Word64+instance Reference Float where type Ref Float = Float+instance Reference Double where type Ref Double = Double++instance (Storable (a,b)) => Reference (a,b)+ where+ type Ref (a,b) = Ptr (a,b)+ ref = new+ deref = peek++instance (Storable (a,b,c)) => Reference (a,b,c)+ where+ type Ref (a,b,c) = Ptr (a,b,c)+ ref = new+ deref = peek++instance (Storable (a,b,c,d)) => Reference (a,b,c,d)+ where+ type Ref (a,b,c,d) = Ptr (a,b,c,d)+ ref = new+ deref = peek++instance (Storable (a,b,c,d,e)) => Reference (a,b,c,d,e)+ where+ type Ref (a,b,c,d,e) = Ptr (a,b,c,d,e)+ ref = new+ deref = peek++instance (Storable (a,b,c,d,e,f)) => Reference (a,b,c,d,e,f)+ where+ type Ref (a,b,c,d,e,f) = Ptr (a,b,c,d,e,f)+ ref = new+ deref = peek++instance (Storable (a,b,c,d,e,f,g)) => Reference (a,b,c,d,e,f,g)+ where+ type Ref (a,b,c,d,e,f,g) = Ptr (a,b,c,d,e,f,g)+ ref = new+ deref = peek+++-- | Convert between Haskell and representation types+class Marshal a+ where+ type Rep a :: *++ to :: a -> IO (Rep a)+ default to :: (a ~ Rep a) => a -> IO (Rep a)+ {-# INLINE to #-}+ to a = return a++ from :: Rep a -> IO a+ default from :: (a ~ Rep a) => Rep a -> IO a+ {-# INLINE from #-}+ from a = return a++instance Marshal Bool where type Rep Bool = Bool+instance Marshal Int8 where type Rep Int8 = Int8+instance Marshal Int16 where type Rep Int16 = Int16+instance Marshal Int32 where type Rep Int32 = Int32+instance Marshal Int64 where type Rep Int64 = Int64+instance Marshal Word8 where type Rep Word8 = Word8+instance Marshal Word16 where type Rep Word16 = Word16+instance Marshal Word32 where type Rep Word32 = Word32+instance Marshal Word64 where type Rep Word64 = Word64+instance Marshal Float where type Rep Float = Float+instance Marshal Double where type Rep Double = Double+++instance (Marshal a, Marshal b) => Marshal (a,b)+ where+ type Rep (a,b) = (Rep a,Rep b)+ to (a,b) = (,) <$> to a <*> to b+ from (a,b) = (,) <$> from a <*> from b++instance ( Marshal a+ , Marshal b+ , Marshal c+ ) => Marshal (a,b,c)+ where+ type Rep (a,b,c) = (Rep a,Rep b,Rep c)+ to (a,b,c) = (,,) <$> to a <*> to b <*> to c+ from (a,b,c) = (,,) <$> from a <*> from b <*> from c++instance ( Marshal a+ , Marshal b+ , Marshal c+ , Marshal d+ ) => Marshal (a,b,c,d)+ where+ type Rep (a,b,c,d) = (Rep a,Rep b,Rep c,Rep d)+ to (a,b,c,d) =+ (,,,) <$> to a <*> to b <*> to c <*> to d+ from (a,b,c,d) =+ (,,,) <$> from a <*> from b <*> from c <*> from d++instance ( Marshal a+ , Marshal b+ , Marshal c+ , Marshal d+ , Marshal e+ ) => Marshal (a,b,c,d,e)+ where+ type Rep (a,b,c,d,e) = (Rep a,Rep b,Rep c,Rep d,Rep e)+ to (a,b,c,d,e) =+ (,,,,) <$> to a <*> to b <*> to c <*> to d <*> to e+ from (a,b,c,d,e) =+ (,,,,) <$> from a <*> from b <*> from c <*> from d <*> from e++instance ( Marshal a+ , Marshal b+ , Marshal c+ , Marshal d+ , Marshal e+ , Marshal f+ ) => Marshal (a,b,c,d,e,f)+ where+ type Rep (a,b,c,d,e,f) = (Rep a,Rep b,Rep c,Rep d,Rep e,Rep f)+ to (a,b,c,d,e,f) =+ (,,,,,) <$> to a <*> to b <*> to c <*> to d <*> to e <*> to f+ from (a,b,c,d,e,f) =+ (,,,,,) <$> from a <*> from b <*> from c <*> from d <*> from e <*> from f++instance ( Marshal a+ , Marshal b+ , Marshal c+ , Marshal d+ , Marshal e+ , Marshal f+ , Marshal g+ ) => Marshal (a,b,c,d,e,f,g)+ where+ type Rep (a,b,c,d,e,f,g) = (Rep a,Rep b,Rep c,Rep d,Rep e,Rep f,Rep g)+ to (a,b,c,d,e,f,g) =+ (,,,,,,) <$> to a <*> to b <*> to c <*> to d <*> to e <*> to f <*> to g+ from (a,b,c,d,e,f,g) =+ (,,,,,,) <$> from a <*> from b <*> from c <*> from d <*> from e <*> from f <*> from g
+ tests/RegressionTests.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Test.Tasty+import Test.Tasty.TH+import Test.Tasty.QuickCheck++import Feldspar+import Feldspar.Vector+import Feldspar.Vector.Push as PV+import Feldspar.Compiler.Plugin+++prog0 :: Data Index -> Data Index -> Data Index+prog0 = (+)++loadFun 'prog0++prog1 :: Vector1 Index -> Vector1 Index+prog1 = id++loadFun 'prog1++prog2 :: Vector1 Index -> PushVector1 Index+prog2 v = let pv = toPush v in pv PV.++ pv++loadFun 'prog2++prop_prog0 :: Property+prop_prog0 = eval prog0 === c_prog0++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