X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=37dbecb446d79a5e4f10c9f2a412c03a2b36dd12;hb=02c988e586dedff6d252ef59ef487dd4a8f567aa;hp=a75514340d32288963b767d0ba02f506c8c33c64;hpb=112780e06ecd41c7469317a08187ea8335ee3c54;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index a755143..37dbecb 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -21,9 +21,9 @@ module VectUtils (
   buildClosure, buildClosures,
   mkClosureApp
 ) where
-
-import VectCore
 import VectMonad
+import Vectorise.Env
+import Vectorise.Vect
 
 import MkCore ( mkCoreTup, mkWildCase )
 import CoreSyn
@@ -41,6 +41,7 @@ import TysWiredIn
 import BasicTypes         ( Boxity(..), Arity )
 import Literal            ( Literal, mkMachInt )
 
+
 import Outputable
 import FastString
 
@@ -163,6 +164,7 @@ prDFunOfTyCon tycon
   . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
   $ lookupTyConPR tycon
 
+
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
   where
@@ -183,25 +185,39 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
 
     go _ _ = return Nothing
 
-paDictOfType :: Type -> VM CoreExpr
-paDictOfType ty = paDictOfTyApp ty_fn ty_args
+
+-- | Get the PA dictionary for some type, or `Nothing` if there isn't one.
+paDictOfType :: Type -> VM (Maybe CoreExpr)
+paDictOfType ty 
+  = paDictOfTyApp ty_fn ty_args
   where
     (ty_fn, ty_args) = splitAppTys ty
 
-paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
-paDictOfTyApp ty_fn ty_args
-  | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
-paDictOfTyApp (TyVarTy tv) ty_args
-  = do
-      dfun <- maybeV (lookupTyVarPA tv)
-      paDFunApply dfun ty_args
-paDictOfTyApp (TyConApp tc _) ty_args
-  = do
-      dfun <- maybeCantVectoriseM "No PA dictionary for tycon" (ppr tc)
-            $ lookupTyConPA tc
-      paDFunApply (Var dfun) ty_args
-paDictOfTyApp ty _
-  = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
+    paDictOfTyApp :: Type -> [Type] -> VM (Maybe CoreExpr)
+    paDictOfTyApp ty_fn ty_args
+        | Just ty_fn' <- coreView ty_fn 
+        = paDictOfTyApp ty_fn' ty_args
+
+    paDictOfTyApp (TyVarTy tv) ty_args
+     = do dfun <- maybeV (lookupTyVarPA tv)
+          liftM Just $ paDFunApply dfun ty_args
+
+    paDictOfTyApp (TyConApp tc _) ty_args
+     = do mdfun <- lookupTyConPA tc
+          case mdfun of
+	    Nothing	
+	     -> pprTrace "VectUtils.paDictOfType"
+	                 (vcat [ text "No PA dictionary"
+			       , text "for tycon: " <> ppr tc
+			       , text "in type:   " <> ppr ty])
+	     $ return Nothing
+
+	    Just dfun	-> liftM Just $ paDFunApply (Var dfun) ty_args
+
+    paDictOfTyApp ty _
+     = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
+
+
 
 paDFunType :: TyCon -> VM Type
 paDFunType tc
@@ -216,10 +232,10 @@ paDFunType tc
 
 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
 paDFunApply dfun tys
-  = do
-      dicts <- mapM paDictOfType tys
+ = do Just dicts <- liftM sequence $ mapM paDictOfType tys
       return $ mkApps (mkTyApps dfun tys) dicts
 
+
 paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr
 paMethod _ name ty
   | Just tycon <- splitPrimTyCon ty
@@ -229,8 +245,8 @@ paMethod _ name ty
 
 paMethod method _ ty
   = do
-      fn   <- builtin method
-      dict <- paDictOfType ty
+      fn        <- builtin method
+      Just dict <- paDictOfType ty
       return $ mkApps (Var fn) [Type ty, dict]
 
 prDictOfType :: Type -> VM CoreExpr
@@ -256,8 +272,8 @@ prDFunApply dfun tys
 wrapPR :: Type -> VM CoreExpr
 wrapPR ty
   = do
-      pa_dict <- paDictOfType ty
-      pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon
+      Just  pa_dict <- paDictOfType ty
+      pr_dfun       <- prDFunOfTyCon =<< builtin wrapTyCon
       return $ mkApps pr_dfun [Type ty, pa_dict]
 
 replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr
@@ -301,8 +317,8 @@ zipScalars arg_tys res_ty
 scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr
 scalarClosure arg_tys res_ty scalar_fun array_fun
   = do
-      ctr <- builtin (closureCtrFun $ length arg_tys)
-      pas <- mapM paDictOfType (init arg_tys)
+      ctr      <- builtin (closureCtrFun $ length arg_tys)
+      Just pas <- liftM sequence $ mapM paDictOfType (init arg_tys)
       return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty])
                        `mkApps`   (pas ++ [scalar_fun, array_fun])
 
@@ -338,24 +354,26 @@ polyArity tvs = do
 
 polyApply :: CoreExpr -> [Type] -> VM CoreExpr
 polyApply expr tys
-  = do
-      dicts <- mapM paDictOfType tys
+ = do Just dicts <- liftM sequence $ mapM paDictOfType tys
       return $ expr `mkTyApps` tys `mkApps` dicts
 
 polyVApply :: VExpr -> [Type] -> VM VExpr
 polyVApply expr tys
-  = do
-      dicts <- mapM paDictOfType tys
-      return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
+ = do Just dicts <- liftM sequence $ mapM paDictOfType tys
+      return     $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
 
+-- Inline ---------------------------------------------------------------------
+-- | Records whether we should inline a particular binding.
+data Inline 
+        = Inline Arity
+        | DontInline
 
-data Inline = Inline Arity
-            | DontInline
-
+-- | Add to the arity contained within an `Inline`, if any.
 addInlineArity :: Inline -> Int -> Inline
 addInlineArity (Inline m) n = Inline (m+n)
 addInlineArity DontInline _ = DontInline
 
+-- | Says to always inline a binding.
 inlineMe :: Inline
 inlineMe = Inline 0
 
@@ -424,6 +442,7 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
       return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv],
               Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
 
+
 mkClosureApp :: Type -> Type -> VExpr -> VExpr -> VM VExpr
 mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
  = do vapply <- builtin applyVar