NoSlow 0.1 → 0.1.1
raw patch · 18 files changed
+230/−163 lines, 18 filesdep ~criteriondep ~storablevectordep ~uvector
Dependency ranges changed: criterion, storablevector, uvector, vector
Files
- NoSlow.cabal +8/−5
- NoSlow/Backend/Interface.hs +1/−1
- NoSlow/Backend/TH.hs +151/−64
- NoSlow/Main/TH.hs +1/−1
- NoSlow/Micro/DPH/Prim/Seq.hs +5/−6
- NoSlow/Micro/DPH/Prim/Seq/Double.hs +5/−7
- NoSlow/Micro/List.hs +4/−7
- NoSlow/Micro/List/Double.hs +5/−7
- NoSlow/Micro/StorableVector.hs +5/−6
- NoSlow/Micro/StorableVector/Double.hs +5/−7
- NoSlow/Micro/Uvector.hs +5/−6
- NoSlow/Micro/Uvector/Double.hs +5/−7
- NoSlow/Micro/Vector/Boxed.hs +5/−6
- NoSlow/Micro/Vector/Boxed/Double.hs +5/−7
- NoSlow/Micro/Vector/Primitive.hs +5/−6
- NoSlow/Micro/Vector/Primitive/Double.hs +5/−7
- NoSlow/Micro/Vector/Storable.hs +5/−6
- NoSlow/Micro/Vector/Storable/Double.hs +5/−7
NoSlow.cabal view
@@ -1,5 +1,5 @@ Name: NoSlow-Version: 0.1+Version: 0.1.1 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy <rl@cse.unsw.edu.au>@@ -53,22 +53,25 @@ Build-Depends: base >= 3 && < 5, template-haskell,- criterion >= 0.2+ criterion >= 0.2 && < 0.3 + Extensions:+ MultiParamTypeClasses+ if flag(dph-prim-seq) build-depends: dph-prim-seq, dph-base cpp-options: -DUSE_DPH_PRIM_SEQ if flag(vector)- build-depends: vector+ build-depends: vector >= 0.4 cpp-options: -DUSE_VECTOR if flag(uvector)- build-depends: uvector+ build-depends: uvector >= 0.1 cpp-options: -DUSE_UVECTOR if flag(storablevector)- build-depends: storablevector+ build-depends: storablevector >= 0.2 cpp-options: -DUSE_STORABLEVECTOR Ghc-Options:
NoSlow/Backend/Interface.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, KindSignatures #-}+{-# LANGUAGE KindSignatures #-} module NoSlow.Backend.Interface where
NoSlow/Backend/TH.hs view
@@ -14,12 +14,94 @@ interface_module = case nameModule ''I.Vector of Just s -> s +type TySubst = [(Name, Type)]++class TypeLike a where+ substTy :: TySubst -> a -> a+ freeTyVars :: a -> [Name]++instance TypeLike Type where+ substTy s (ForallT vars cxt ty)+ = ForallT vars (substTy s cxt) (substTy s ty)++ substTy s (VarT var)+ | Just ty <- lookup var s = ty+ | otherwise = VarT var++ substTy s (ty1 `AppT` ty2) = substTy s ty1 `AppT` substTy s ty2++#if __GLASGOW_HASKELL__ > 610+ substTy s (ty `SigT` k) = substTy s ty `SigT` k+#endif++ substTy s ty = ty+++ freeTyVars (ForallT vars cxt ty)+ = [v | v <- freeTyVars cxt ++ freeTyVars ty+ , v `notElem` map tyVarBndrName vars]+ freeTyVars (VarT v) = [v]+ freeTyVars (ty1 `AppT` ty2) = freeTyVars ty1 ++ freeTyVars ty2+#if __GLASGOW_HASKELL__ > 610+ freeTyVars (ty `SigT` k) = freeTyVars ty+#endif+ freeTyVars ty = []+ +++instance TypeLike a => TypeLike [a] where+ substTy s as = map (substTy s) as+ freeTyVars as = concatMap freeTyVars as++#if __GLASGOW_HASKELL__ > 610+instance TypeLike Pred where+ substTy s (ClassP cls tys) = ClassP cls (substTy s tys)+ substTy s (ty1 `EqualP` ty2) = substTy s ty1 `EqualP` substTy s ty2++ freeTyVars (ClassP _ tys) = freeTyVars tys+ freeTyVars (ty1 `EqualP` ty2) = freeTyVars ty1 ++ freeTyVars ty2+#else+type Pred = Type+#endif++splitClsPred :: Pred -> Maybe (Name, [Type])+#if __GLASGOW_HASKELL__ > 610+splitClsPred (ClassP cls tys) = Just (cls, tys)+splitClsPred (EqualP _ _) = Nothing+#else+splitClsPred ty = go ty []+ where+ go (ty1 `AppT` ty2) tys = go ty1 (ty2 : tys)+ go (ConT cls) tys = Just (cls, tys)+ go _ _ = Nothing+#endif++#if __GLASGOW_HASKELL__ <= 610+type TyVarBndr = Name+#endif++tyVarBndrName :: TyVarBndr -> Name+#if __GLASGOW_HASKELL__ > 610+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name+#else+tyVarBndrName = id+#endif++tyVarBndr :: Name -> TyVarBndr+#if __GLASGOW_HASKELL__ > 610+tyVarBndr = PlainTV+#else+tyVarBndr = id+#endif++ type Context = (Name, [Type]) data Spec = Spec {- specModule :: String- , specContext :: Name -> Name -> [Context]- , specVars :: [(String, Type)]+ specVector :: ([Name], Type)+ , specElem :: ([Name], Type)+ , specContext :: Type -> Type -> Cxt } newtype SM a = SM { runSM :: Spec -> [Name] -> (a, [Name]) }@@ -37,38 +119,41 @@ getSpec :: SM Spec getSpec = SM $ \s ns -> (s,ns) +withSpec :: Spec -> SM a -> SM a+withSpec spec (SM p) = SM $ \_ -> p spec+ reference :: Name -> SM () reference name = SM $ \s ns -> ((), name : ns) -specialise :: Spec -> Q [Dec] -> Q [Dec]-specialise spec decsq+specialise :: Q [Dec] -> Q [Dec]+specialise decsq = do+ TyConI (TySynD _ spec_vector_vars spec_vector_ty)+ <- reify (mkName "Spec_Vector")+ TyConI (TySynD _ spec_elem_vars spec_elem_ty)+ <- reify (mkName "Spec_Elem")+ ClassI (ClassD spec_cxt _ [cxt_v, cxt_a] _ _)+ <- reify (mkName "Spec_Context")+ let spec = Spec {+ specVector = (map tyVarBndrName spec_vector_vars, spec_vector_ty)+ , specElem = (map tyVarBndrName spec_elem_vars, spec_elem_ty)+ , specContext = mk_context (tyVarBndrName cxt_v) (tyVarBndrName cxt_a) spec_cxt+ }++ decs <- decsq scs <- mapM (specialiseTopDec spec) decs let bad_names = [name | Right name <- scs] good_decs = [dec | Left dec <- scs , decName dec `notElem` bad_names] - return $ vector_type : good_decs+ return $ {- vector_type : -} good_decs ++ noinline good_decs ++ [SigD name (ConT ''Unsupported) | name <- bad_names] ++ [ValD (VarP name) (NormalB (ConE 'Unsupported)) [] | name <- bad_names] where- vector_type = TySynD (mkName "Vector_Type") ty_vars (ty_con `AppT` elem_ty)-- ty_con | Just ty <- lookup "v" (specVars spec) = ty-- (ty_vars, elem_ty)- | Just ty <- lookup "a" (specVars spec) = ([], ty)- | otherwise = ([binder a], VarT a)- where- a = mkName "a"-#if __GLASGOW_HASKELL__ > 610- binder = PlainTV-#else- binder = id-#endif+ mk_context v a cxt ty_v ty_a = substTy [(v,ty_v),(a,ty_a)] cxt #if __GLASGOW_HASKELL__ > 610 noinline decs = [PragmaD $ InlineP name $ InlineSpec False False Nothing@@ -115,65 +200,68 @@ spec <- getSpec return $ specialiseTy' spec ty +data SplitPred = VectorPred Type Type+ | OtherPred Pred+ specialiseTy' :: Spec -> Type -> Type-specialiseTy' spec pty- | ForallT vars cxt ty <- pty- = mk_forall (map rename_bndr $ filter keep_bndr vars)- (spec_cxt cxt)- (spec_ty ty)+specialiseTy' spec (ForallT vars cxt ty)+ = specialiseForall spec (map tyVarBndrName vars) cxt ty+specialiseTy' spec ty = ty - | otherwise = spec_ty pty+specialiseForall :: Spec -> [Name] -> Cxt -> Type -> Type+specialiseForall spec vars cxt ty+ = mk_forall (map tyVarBndr $ vs1 ++ vs2 ++ other_vars')+ (filter keep_pred+ $ concatMap (subst_split_pred subst) split_preds)+ (substTy subst ty) where-#if __GLASGOW_HASKELL__ > 610- rename_bndr (PlainTV v) = PlainTV (rename v)- rename_bndr (KindedTV v k) = KindedTV (rename v) k+ mk_forall [] _ ty = ty+ mk_forall vars cxt ty = ForallT vars cxt ty - keep_bndr (PlainTV v) = keep_var v- keep_bndr (KindedTV v _) = keep_var v-#else- rename_bndr = rename- keep_bndr = keep_var-#endif+ split_pred pred+ | Just (cls, [vect_ty, elem_ty]) <- splitClsPred pred+ , cls == ''I.Vector = VectorPred vect_ty elem_ty+ | otherwise = OtherPred pred - keep_var v = not $ isJust $ lookup (nameBase v) (specVars spec)- rename = mkName . nameBase+ split_preds = map split_pred cxt - mk_forall [] _ ty = ty- mk_forall vars cxt ty = ForallT vars cxt ty+ vector_vars = [v | VectorPred (VarT v) _ <- split_preds]+ elem_vars = [a | VectorPred _ (VarT a) <- split_preds]+ other_vars = filter (\v -> v `notElem` vector_vars+ && v `notElem` elem_vars) vars - spec_cxt = filter var_pred . concatMap spec_pred+ other_vars' = map rename other_vars -#if __GLASGOW_HASKELL__ > 610- spec_pred (ClassP cls [VarT v, VarT a])- | cls == ''I.Vector = map (uncurry ClassP)- $ specContext spec (rename v) (rename a)+ (vs1, s1) = subst_for_vars vector_vars (specVector spec)+ (vs2, s2) = subst_for_vars elem_vars (specElem spec) - spec_pred (ClassP cls tys) = [ClassP cls $ map spec_ty tys]+ vars' = vs1 ++ vs2 ++ other_vars'+ subst = s1 ++ s2 ++ zipWith (\v v' -> (v, VarT v')) other_vars other_vars' - var_pred (ClassP _ tys) = any var_ty tys-#else- spec_pred (AppT (AppT (ConT cls) (VarT v)) (VarT a))- | cls == ''I.Vector = map mk_pred- $ specContext spec (rename v) (rename a)+ - spec_pred pred = [spec_ty pred]+ subst_for_vars vs poly_ty + | (vs', s) <- unzip [subst_for_var v poly_ty | v <- vs]+ = (concat vs', s) - var_pred = var_ty+ subst_for_var v ([v'], VarT v'')+ | v' == v'' = ([rename v], (v, VarT (rename v))) - mk_pred (cls, tys) = foldl AppT (ConT cls) tys-#endif+ subst_for_var v (vars, ty)+ = (new_vars, (v, substTy (zip vars (map VarT new_vars)) ty))+ where+ new_vars = [mkName $ nameBase v ++ '_' : nameBase var | var <- vars] - spec_ty (VarT v)- | Just ty <- lookup (nameBase v) (specVars spec) = ty- | otherwise = VarT (rename v) - spec_ty (AppT t u) = spec_ty t `AppT` spec_ty u- spec_ty ty = ty+ rename = mkName . nameBase - var_ty (VarT v) = True- var_ty (AppT t u) = var_ty t || var_ty u- var_ty _ = False+ subst_split_pred s (VectorPred vect_ty elem_ty)+ = specContext spec (substTy s vect_ty) (substTy s elem_ty)+ subst_split_pred s (OtherPred pred)+ = [substTy s pred] + keep_pred = not . null . freeTyVars+ specialiseClause :: Clause -> SM Clause specialiseClause (Clause pats body decs) = liftM2 (Clause pats) (specialiseBody body)@@ -189,8 +277,7 @@ | Just mod <- nameModule v , mod == interface_module = do- mod <- specModule `fmap` getSpec- let name = qualify mod v+ let name = qualify "Impl" v reference name return $ VarE name
NoSlow/Main/TH.hs view
@@ -22,7 +22,7 @@ = mk_kgroup s (map (benchtree sort ty) ts) benchtree sort ty@(ConT c) (KModule s poly_mod) = do- TyConI (TySynD t [_] _) <- reify $ mkName $ poly_mod ++ ".Vector_Type"+ TyConI (TySynD t _ _) <- reify $ mkName $ poly_mod ++ ".Spec_Vector" let tag = case sort of Poly -> '*' : nameBase c
NoSlow/Micro/DPH/Prim/Seq.hs view
@@ -8,10 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ a -> [(''Impl.Elt, [VarT a])]- , specVars = [("v", ConT ''Impl.Array)]- })- K.kernels)+type Spec_Vector = Impl.Array+type Spec_Elem a = a+class Impl.Elt a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/DPH/Prim/Seq/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.Array),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = Impl.Array+type Spec_Elem = Double+class Impl.Elt a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/List.hs view
@@ -8,12 +8,9 @@ import Language.Haskell.TH -type V a = [a]+type Spec_Vector = []+type Spec_Elem a = a+class Spec_Context v a -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''[])]- })- K.kernels)+$(specialise K.kernels)
NoSlow/Micro/List/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''[]),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = []+type Spec_Elem = Double+class Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/StorableVector.hs view
@@ -9,10 +9,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ a -> [(''Storable, [VarT a])]- , specVars = [("v", ConT ''Impl.Vector)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Storable a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/StorableVector/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.Vector),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Uvector.hs view
@@ -8,10 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ a -> [(''Impl.UA, [VarT a])]- , specVars = [("v", ConT ''Impl.UArr)]- })- K.kernels)+type Spec_Vector = Impl.UArr+type Spec_Elem a = a+class Impl.UA a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Uvector/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.UArr),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = Impl.UArr+type Spec_Elem = Double+class Impl.UA a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Vector/Boxed.hs view
@@ -8,10 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.Vector)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Vector/Boxed/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.Vector),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Vector/Primitive.hs view
@@ -8,10 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ a -> [(''Impl.Prim, [VarT a])]- , specVars = [("v", ConT ''Impl.Vector)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Impl.Prim a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Vector/Primitive/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.Vector),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Impl.Prim a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Vector/Storable.hs view
@@ -8,10 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ a -> [(''Impl.Storable, [VarT a])]- , specVars = [("v", ConT ''Impl.Vector)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem a = a+class Impl.Storable a => Spec_Context v a++$(specialise K.kernels)
NoSlow/Micro/Vector/Storable/Double.hs view
@@ -8,11 +8,9 @@ import Language.Haskell.TH -$(specialise (Spec {- specModule = "Impl"- , specContext = \_ _ -> []- , specVars = [("v", ConT ''Impl.Vector),- ("a", ConT ''Double)]- })- K.kernels)+type Spec_Vector = Impl.Vector+type Spec_Elem = Double+class Impl.Storable a => Spec_Context v a++$(specialise K.kernels)