From: simonpj@microsoft.com Date: Fri, 30 Oct 2009 17:59:07 +0000 (+0000) Subject: Minor refactoring X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=fb6d198f498d4e325a540f28aaa6e1d1530839c3 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 --- 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 3ffda53..48700f6 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 94009fd..11fddf5 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 16ebf58..3689479 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 37b8cbe..3457f32 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 9faa0ed..6207acd 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