diff --git a/NoSlow.cabal b/NoSlow.cabal --- a/NoSlow.cabal +++ b/NoSlow.cabal @@ -1,5 +1,5 @@ Name: NoSlow -Version: 0.1 +Version: 0.1.1 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy @@ -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: diff --git a/NoSlow/Backend/Interface.hs b/NoSlow/Backend/Interface.hs --- a/NoSlow/Backend/Interface.hs +++ b/NoSlow/Backend/Interface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module NoSlow.Backend.Interface where diff --git a/NoSlow/Backend/TH.hs b/NoSlow/Backend/TH.hs --- a/NoSlow/Backend/TH.hs +++ b/NoSlow/Backend/TH.hs @@ -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 diff --git a/NoSlow/Main/TH.hs b/NoSlow/Main/TH.hs --- a/NoSlow/Main/TH.hs +++ b/NoSlow/Main/TH.hs @@ -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 diff --git a/NoSlow/Micro/DPH/Prim/Seq.hs b/NoSlow/Micro/DPH/Prim/Seq.hs --- a/NoSlow/Micro/DPH/Prim/Seq.hs +++ b/NoSlow/Micro/DPH/Prim/Seq.hs @@ -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) diff --git a/NoSlow/Micro/DPH/Prim/Seq/Double.hs b/NoSlow/Micro/DPH/Prim/Seq/Double.hs --- a/NoSlow/Micro/DPH/Prim/Seq/Double.hs +++ b/NoSlow/Micro/DPH/Prim/Seq/Double.hs @@ -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) diff --git a/NoSlow/Micro/List.hs b/NoSlow/Micro/List.hs --- a/NoSlow/Micro/List.hs +++ b/NoSlow/Micro/List.hs @@ -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) diff --git a/NoSlow/Micro/List/Double.hs b/NoSlow/Micro/List/Double.hs --- a/NoSlow/Micro/List/Double.hs +++ b/NoSlow/Micro/List/Double.hs @@ -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) diff --git a/NoSlow/Micro/StorableVector.hs b/NoSlow/Micro/StorableVector.hs --- a/NoSlow/Micro/StorableVector.hs +++ b/NoSlow/Micro/StorableVector.hs @@ -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) diff --git a/NoSlow/Micro/StorableVector/Double.hs b/NoSlow/Micro/StorableVector/Double.hs --- a/NoSlow/Micro/StorableVector/Double.hs +++ b/NoSlow/Micro/StorableVector/Double.hs @@ -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) diff --git a/NoSlow/Micro/Uvector.hs b/NoSlow/Micro/Uvector.hs --- a/NoSlow/Micro/Uvector.hs +++ b/NoSlow/Micro/Uvector.hs @@ -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) diff --git a/NoSlow/Micro/Uvector/Double.hs b/NoSlow/Micro/Uvector/Double.hs --- a/NoSlow/Micro/Uvector/Double.hs +++ b/NoSlow/Micro/Uvector/Double.hs @@ -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) diff --git a/NoSlow/Micro/Vector/Boxed.hs b/NoSlow/Micro/Vector/Boxed.hs --- a/NoSlow/Micro/Vector/Boxed.hs +++ b/NoSlow/Micro/Vector/Boxed.hs @@ -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) diff --git a/NoSlow/Micro/Vector/Boxed/Double.hs b/NoSlow/Micro/Vector/Boxed/Double.hs --- a/NoSlow/Micro/Vector/Boxed/Double.hs +++ b/NoSlow/Micro/Vector/Boxed/Double.hs @@ -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) diff --git a/NoSlow/Micro/Vector/Primitive.hs b/NoSlow/Micro/Vector/Primitive.hs --- a/NoSlow/Micro/Vector/Primitive.hs +++ b/NoSlow/Micro/Vector/Primitive.hs @@ -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) diff --git a/NoSlow/Micro/Vector/Primitive/Double.hs b/NoSlow/Micro/Vector/Primitive/Double.hs --- a/NoSlow/Micro/Vector/Primitive/Double.hs +++ b/NoSlow/Micro/Vector/Primitive/Double.hs @@ -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) diff --git a/NoSlow/Micro/Vector/Storable.hs b/NoSlow/Micro/Vector/Storable.hs --- a/NoSlow/Micro/Vector/Storable.hs +++ b/NoSlow/Micro/Vector/Storable.hs @@ -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) diff --git a/NoSlow/Micro/Vector/Storable/Double.hs b/NoSlow/Micro/Vector/Storable/Double.hs --- a/NoSlow/Micro/Vector/Storable/Double.hs +++ b/NoSlow/Micro/Vector/Storable/Double.hs @@ -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)