plugins-multistage 0.3 → 0.4
raw patch · 4 files changed
+43/−243 lines, 4 filesdep −QuickCheckdep −criteriondep −deepseqdep ~base
Dependencies removed: QuickCheck, criterion, deepseq, plugins-multistage, tasty, tasty-quickcheck, tasty-th
Dependency ranges changed: base
Files
- bench/Benchmark.hs +0/−53
- plugins-multistage.cabal +24/−24
- src/System/Plugins/MultiStage.hs +19/−123
- tests/RegressionTests.hs +0/−43
− bench/Benchmark.hs
@@ -1,53 +0,0 @@-{-# 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
@@ -1,5 +1,5 @@ name: plugins-multistage-version: 0.3+version: 0.4 synopsis: Dynamic linking for embedded DSLs with staged compilation description: Dynamic compilation, linking and loading of functions in staged languages.@@ -36,37 +36,37 @@ 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,+-- tasty >= 0.3,+-- tasty-th >= 0.1,+-- tasty-quickcheck >= 0.3,+-- QuickCheck >= 2.5 && < 3.0 -benchmark needforspeed- type: exitcode-stdio-1.0+-- benchmark needforspeed+-- type: exitcode-stdio-1.0 - hs-source-dirs: bench+-- hs-source-dirs: bench - main-is: Benchmark.hs+-- main-is: Benchmark.hs - default-language: Haskell2010+-- default-language: Haskell2010 - ghc-options: -O2+-- ghc-options: -O2 - build-depends:- plugins-multistage,- base,- deepseq,- criterion+-- build-depends:+-- plugins-multistage,+-- base,+-- deepseq,+-- criterion
src/System/Plugins/MultiStage.hs view
@@ -149,18 +149,8 @@ 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+applyTF tf typ = appT (conT tf) $ expandSyns typ -- | Expand type families expandTF :: Type -> Q Type@@ -177,14 +167,11 @@ 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+ [(p1,pt2)]+ | Just t2 <- substitute (matchP p1 t1) pt2+ -> down t2 _ -> return t _ -> return t- up (AppT t1 t2) = appT (return t1) (return t2) up t = return t projInst :: Dec -> Maybe (Type, Type)@@ -195,6 +182,21 @@ #endif projInst _ = Nothing +substitute :: [(Name,Type)] -> Type -> Maybe Type+substitute ss = go+ where+ go :: Type -> Maybe Type+ go (VarT v) = lookup v ss+ go (AppT a b) = AppT <$> go a <*> go b+ go t = pure t++matchP :: Type -> Type -> [(Name,Type)]+matchP = go+ where+ go (VarT p1) t1 = [(p1,t1)]+ go (AppT p1 p2) (AppT t1 t2) = go p1 t1 ++ go p2 t2+ go p t = []+ -- | Pack a value into its runtime representation -- -- > pack a = to a >>= ref@@ -240,43 +242,6 @@ 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@@ -304,72 +269,3 @@ 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
@@ -1,43 +0,0 @@-{-# 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