Make record selectors into ordinary functions

[ghc-hetmet.git] / compiler / vectorise / VectUtils.hs

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 84d978f..7aef39b 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -18,12 +18,10 @@ module VectUtils (
   mkClosureApp
 ) where
 
-#include "HsVersions.h"
-
 import VectCore
 import VectMonad
 
-import DsUtils
+import MkCore
 import CoreSyn
 import CoreUtils
 import Coercion
@@ -32,7 +30,6 @@ import TypeRep
 import TyCon
 import DataCon
 import Var
-import Id                 ( mkWildId )
 import MkId               ( unwrapFamInstScrut )
 import TysWiredIn
 import BasicTypes         ( Boxity(..) )
@@ -126,9 +123,10 @@ mkPArrayType :: Type -> VM Type
 mkPArrayType ty
   | Just tycon <- splitPrimTyCon ty
   = do
-      arr <- traceMaybeV "mkPArrayType" (ppr tycon)
-           $ lookupPrimPArray tycon
-      return $ mkTyConApp arr []
+      r <- lookupPrimPArray tycon
+      case r of
+        Just arr -> return $ mkTyConApp arr []
+        Nothing  -> cantVectorise "Primitive tycon not vectorised" (ppr tycon)
 mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
 
 mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
@@ -155,7 +153,9 @@ mkVScrut (ve, le)
 
 prDFunOfTyCon :: TyCon -> VM CoreExpr
 prDFunOfTyCon tycon
-  = liftM Var (traceMaybeV "prDictOfTyCon" (ppr tycon) (lookupTyConPR tycon))
+  = liftM Var
+  . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
+  $ lookupTyConPR tycon
 
 paDictArgType :: TyVar -> VM (Maybe Type)
 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
@@ -163,7 +163,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
     go ty k | Just k' <- kindView k = go ty k'
     go ty (FunTy k1 k2)
       = do
-          tv   <- newTyVar FSLIT("a") k1
+          tv   <- newTyVar (fsLit "a") k1
           mty1 <- go (TyVarTy tv) k1
           case mty1 of
             Just ty1 -> do
@@ -191,9 +191,11 @@ paDictOfTyApp (TyVarTy tv) ty_args
       paDFunApply dfun ty_args
 paDictOfTyApp (TyConApp tc _) ty_args
   = do
-      dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc)
+      dfun <- maybeCantVectoriseM "No PA dictionary for tycon" (ppr tc)
+            $ lookupTyConPA tc
       paDFunApply (Var dfun) ty_args
-paDictOfTyApp ty _ = pprPanic "paDictOfTyApp" (ppr ty)
+paDictOfTyApp ty _
+  = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
 
 paDFunType :: TyCon -> VM Type
 paDFunType tc
@@ -223,10 +225,9 @@ pa_pack      = (packPAVar,      "packPA")
 paMethod :: PAMethod -> Type -> VM CoreExpr
 paMethod (_method, name) ty
   | Just tycon <- splitPrimTyCon ty
-  = do
-      fn <- traceMaybeV "paMethod" (ppr tycon <+> text name)
-          $ lookupPrimMethod tycon name
-      return (Var fn)
+  = liftM Var
+  . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon)
+  $ lookupPrimMethod tycon name
 
 paMethod (method, _name) ty
   = do
@@ -288,7 +289,7 @@ polyAbstract tvs p
     mk_dict_var tv = do
                        r <- paDictArgType tv
                        case r of
-                         Just ty -> liftM Just (newLocalVar FSLIT("dPA") ty)
+                         Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)
                          Nothing -> return Nothing
 
     mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
@@ -378,7 +379,7 @@ buildClosures tvs vars [arg_ty] res_ty mk_body
 buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body
   = do
       res_ty' <- mkClosureTypes arg_tys res_ty
-      arg <- newLocalVVar FSLIT("x") arg_ty
+      arg <- newLocalVVar (fsLit "x") arg_ty
       buildClosure tvs vars arg_ty res_ty'
         . hoistPolyVExpr tvs
         $ do
@@ -395,8 +396,8 @@ buildClosure :: [TyVar] -> [VVar] -> Type -> Type -> VM VExpr -> VM VExpr
 buildClosure tvs vars arg_ty res_ty mk_body
   = do
       (env_ty, env, bind) <- buildEnv vars
-      env_bndr <- newLocalVVar FSLIT("env") env_ty
-      arg_bndr <- newLocalVVar FSLIT("arg") arg_ty
+      env_bndr <- newLocalVVar (fsLit "env") env_ty
+      arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
 
       fn <- hoistPolyVExpr tvs
           $ do
@@ -422,13 +423,13 @@ buildEnv vvs
                 return (vbody', lbody'))
   where
     (vs,ls) = unzip vvs
-    tys     = map idType vs
+    tys     = map varType vs
 
 mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExpr)
 mkVectEnv []   []  = (unitTy, Var unitDataConId, \_ body -> body)
 mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body)
 mkVectEnv tys  vs  = (ty, mkCoreTup (map Var vs),
-                        \env body -> Case env (mkWildId ty) (exprType body)
+                        \env body -> mkWildCase env ty (exprType body)
                                        [(DataAlt (tupleCon Boxed (length vs)), vs, body)])
   where
     ty = mkCoreTupTy tys
@@ -458,7 +459,7 @@ mkLiftEnv lc tys vs
 
           bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env
                           in
-                          return $ Case scrut (mkWildId (exprType scrut))
+                          return $ mkWildCase scrut (exprType scrut)
                                         (exprType body)
                                         [(DataAlt env_con, lc : bndrs, body)]
       return (env, bind)