Minor refactoring

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

diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 789abe4..f7c0f9a 100644 (file)
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -18,8 +18,7 @@ module MkCore (
         mkChunkified,
         
         -- * Constructing small tuples
         mkChunkified,
         
         -- * Constructing small tuples

-        mkCoreVarTup, mkCoreVarTupTy,
-        mkCoreTup, mkCoreTupTy,
+        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, 

         
         -- * Constructing big tuples
         mkBigCoreVarTup, mkBigCoreVarTupTy,
         
         -- * 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
 
 -- | 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
 
 -- | 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)
 
 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)
 -- | 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
 
 -- | 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}
 
 %************************************************************************
 \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
     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 ]
           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)
     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}
             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 3ffda53..48700f6 100644 (file)
--- 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
 
 \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]
 
 mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
 mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 94009fd..11fddf5 100644 (file)
--- 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
         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
 
     -- 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
        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)
 
        return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
                              (mkLHsTupleExpr rets)

diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 16ebf58..3689479 100644 (file)
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -38,7 +38,7 @@ module TysWiredIn (
        mkListTy,
 
        -- * Tuples
        mkListTy,
 
        -- * Tuples

-       mkTupleTy,
+       mkTupleTy, mkBoxedTupleTy,

        tupleTyCon, tupleCon, 
        unitTyCon, unitDataCon, unitDataConId, pairTyCon, 
        unboxedSingletonTyCon, unboxedSingletonDataCon,
        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
 
 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}
 unitTy :: Type
 unitTy = mkTupleTy Boxed []
 \end{code}

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 37b8cbe..3457f32 100644 (file)
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -25,7 +25,6 @@ import TcType
 import TcBinds
 import TcUnify
 import TcSimplify
 import TcBinds
 import TcUnify
 import TcSimplify

-import MkCore

 import Name
 import TysWiredIn
 import PrelNames
 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
   = 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)
 
         ; tcExtendIdEnv tup_ids $ do
         { ((stmts', (ret_op', tup_rets)), stmts_ty)

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 9faa0ed..6207acd 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -25,7 +25,7 @@ module VectUtils (
 import VectCore
 import VectMonad
 
 import VectCore
 import VectMonad
 

-import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase )
+import MkCore ( mkCoreTup, mkWildCase )

 import CoreSyn
 import CoreUtils
 import CoreUnfold         ( mkInlineRule )
 import CoreSyn
 import CoreUtils
 import CoreUnfold         ( mkInlineRule )

@@ -514,5 +514,5 @@ buildEnv vs
   where
     (vvs, lvs) = unzip vs
     tys        = map vVarType vs
   where
     (vvs, lvs) = unzip vs
     tys        = map vVarType vs

-    ty         = mkCoreTupTy tys
+    ty         = mkBoxedTupleTy tys