Minor refactoring

MkCore.mkCoreTupTy moves to TysWiredIn, where it is called mkBoxedTupleTy

6 files changed, 16 insertions, 20 deletions

diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 789abe48c0..f7c0f9ab6f 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -18,8 +18,7 @@ module MkCore (
         mkChunkified,
         
         -- * Constructing small tuples
-        mkCoreVarTup, mkCoreVarTupTy,
-        mkCoreTup, mkCoreTupTy,
+        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, 
         
         -- * Constructing big tuples
         mkBigCoreVarTup, mkBigCoreVarTupTy,
@@ -337,7 +336,7 @@ mkCoreVarTup ids = mkCoreTup (map Var ids)
 
 -- | Bulid the type of a small tuple that holds the specified variables
 mkCoreVarTupTy :: [Id] -> Type
-mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
+mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
 
 -- | Build a small tuple holding the specified expressions
 mkCoreTup :: [CoreExpr] -> CoreExpr
@@ -346,10 +345,6 @@ mkCoreTup [c] = c
 mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
                          (map (Type . exprType) cs ++ cs)
 
--- | Build the type of a small tuple that holds the specified type of thing
-mkCoreTupTy :: [Type] -> Type
-mkCoreTupTy tys  = mkTupleTy Boxed tys
-
 -- | Build a big tuple holding the specified variables
 mkBigCoreVarTup :: [Id] -> CoreExpr
 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
@@ -364,7 +359,7 @@ mkBigCoreTup = mkChunkified mkCoreTup
 
 -- | Build the type of a big tuple that holds the specified type of thing
 mkBigCoreTupTy :: [Type] -> Type
-mkBigCoreTupTy = mkChunkified mkCoreTupTy
+mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
 \end{code}
 
 %************************************************************************
@@ -408,7 +403,7 @@ mkTupleSelector vars the_var scrut_var scrut
     mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $
                                 mk_tup_sel (chunkify tpl_vs) tpl_v
         where
-          tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
+          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]
           tpl_vs  = mkTemplateLocals tpl_tys
           [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
                                          the_var `elem` gp ]
@@ -469,7 +464,7 @@ mkTupleCase uniqs vars body scrut_var scrut
     one_tuple_case chunk_vars (us, vs, body)
       = let (us1, us2) = splitUniqSupply us
             scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
-              (mkCoreTupTy (map idType chunk_vars))
+              (mkBoxedTupleTy (map idType chunk_vars))
             body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
         in (us2, scrut_var:vs, body')
 \end{code}
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 3ffda53c87..48700f6773 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -142,7 +142,7 @@ coreCasePair scrut_var var1 var2 body
 
 \begin{code}
 mkCorePairTy :: Type -> Type -> Type
-mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
 
 mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
 mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 94009fd1fa..11fddf57af 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -749,8 +749,7 @@ dsDo stmts body result_ty
         body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
         return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
 	body_ty    = mkAppTy m_ty tup_ty
-        tup_ty     = mkCoreTupTy (map idType tup_ids)
-                  -- mkCoreTupTy deals with singleton case
+        tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
 
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
@@ -848,8 +847,7 @@ dsMDo tbl stmts body result_ty
 	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 	body_ty = mkAppTy m_ty tup_ty
-	tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
-		  -- mkCoreTupTy deals with singleton case
+	tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
 
 	return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
 			      (mkLHsTupleExpr rets)
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 16ebf58e51..3689479341 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -38,7 +38,7 @@ module TysWiredIn (
 	mkListTy,
 
 	-- * Tuples
-	mkTupleTy,
+	mkTupleTy, mkBoxedTupleTy,
 	tupleTyCon, tupleCon, 
 	unitTyCon, unitDataCon, unitDataConId, pairTyCon, 
 	unboxedSingletonTyCon, unboxedSingletonDataCon,
@@ -539,6 +539,10 @@ mkTupleTy :: Boxity -> [Type] -> Type
 mkTupleTy boxity [ty] | Boxed <- boxity = ty
 mkTupleTy boxity tys = mkTyConApp (tupleTyCon boxity (length tys)) tys
 
+-- | Build the type of a small tuple that holds the specified type of thing
+mkBoxedTupleTy :: [Type] -> Type
+mkBoxedTupleTy tys = mkTupleTy Boxed tys
+
 unitTy :: Type
 unitTy = mkTupleTy Boxed []
 \end{code}
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 37b8cbe3b0..3457f32ce0 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -25,7 +25,6 @@ import TcType
 import TcBinds
 import TcUnify
 import TcSimplify
-import MkCore
 import Name
 import TysWiredIn
 import PrelNames
@@ -524,7 +523,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
         ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
-	      tup_ty  = mkCoreTupTy tup_elt_tys
+	      tup_ty  = mkBoxedTupleTy tup_elt_tys
 
         ; tcExtendIdEnv tup_ids $ do
         { ((stmts', (ret_op', tup_rets)), stmts_ty)
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 9faa0edf73..6207acdc11 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -25,7 +25,7 @@ module VectUtils (
 import VectCore
 import VectMonad
 
-import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase )
+import MkCore ( mkCoreTup, mkWildCase )
 import CoreSyn
 import CoreUtils
 import CoreUnfold         ( mkInlineRule )
@@ -514,5 +514,5 @@ buildEnv vs
   where
     (vvs, lvs) = unzip vs
     tys        = map vVarType vs
-    ty         = mkCoreTupTy tys
+    ty         = mkBoxedTupleTy tys