X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FMkCore.lhs;h=f7c0f9ab6f427a33b1c1c3ec995333a58fef5b3d;hp=0844a0a8ccee79724607463221907d8000e4bfb4;hb=fb6d198f498d4e325a540f28aaa6e1d1530839c3;hpb=393f26621b762225b204b3dc78b05a3ecf08871e

diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 0844a0a..f7c0f9a 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -4,7 +4,7 @@ module MkCore (
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
-        mkCoreLams,
+        mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -18,8 +18,7 @@ module MkCore (
         mkChunkified,
         
         -- * Constructing small tuples
-        mkCoreVarTup, mkCoreVarTupTy,
-        mkCoreTup, mkCoreTupTy,
+        mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, 
         
         -- * Constructing big tuples
         mkBigCoreVarTup, mkBigCoreVarTupTy,
@@ -48,15 +47,14 @@ import HscTypes
 
 import TysWiredIn
 import PrelNames
-import MkId             ( seqId )
 
 import Type
-import TypeRep
 import TysPrim          ( alphaTyVar )
 import DataCon          ( DataCon, dataConWorkId )
 
 import FastString
 import UniqSupply
+import Unique		( mkBuiltinUnique )
 import BasicTypes
 import Util             ( notNull, zipEqual )
 import Panic
@@ -120,88 +118,49 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
 
 -----------
 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
-mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
-  | f == seqId                -- Note [Desugaring seq (1), (2)]
-  = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
-  where
-    case_bndr = case arg1 of
-                   Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
-                   _                            -> mkWildId ty1
-
 mk_val_app fun arg arg_ty _        -- See Note [CoreSyn let/app invariant]
   | not (needsCaseBinding arg_ty arg)
   = App fun arg                -- The vastly common case
 
 mk_val_app fun arg arg_ty res_ty
-  = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
+  = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
   where
-    arg_id = mkWildId arg_ty        -- Lots of shadowing, but it doesn't matter,
-                                -- because 'fun ' should not have a free wild-id
+    arg_id = mkWildBinder arg_ty    
+	-- Lots of shadowing, but it doesn't matter,
+        -- because 'fun ' should not have a free wild-id
+	--
+	-- This is Dangerous.  But this is the only place we play this 
+	-- game, mk_val_app returns an expression that does not have
+	-- have a free wild-id.  So the only thing that can go wrong
+	-- is if you take apart this case expression, and pass a 
+	-- fragmet of it as the fun part of a 'mk_val_app'.
+
+
+-- | Make a /wildcard binder/. This is typically used when you need a binder 
+-- that you expect to use only at a *binding* site.  Do not use it at
+-- occurrence sites because it has a single, fixed unique, and it's very
+-- easy to get into difficulties with shadowing.  That's why it is used so little.
+mkWildBinder :: Type -> Id
+mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
+
+mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
+-- Make a case expression whose case binder is unused
+-- The alts should not have any occurrences of WildId
+mkWildCase scrut scrut_ty res_ty alts 
+  = Case scrut (mkWildBinder scrut_ty) res_ty alts
+
+mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+mkIfThenElse guard then_expr else_expr
+-- Not going to be refining, so okay to take the type of the "then" clause
+  = mkWildCase guard boolTy (exprType then_expr) 
+	 [ (DataAlt falseDataCon, [], else_expr),	-- Increasing order of tag!
+    	   (DataAlt trueDataCon,  [], then_expr) ]
 \end{code}
 
-Note [Desugaring seq (1)]  cf Trac #1031
-~~~~~~~~~~~~~~~~~~~~~~~~~
-   f x y = x `seq` (y `seq` (# x,y #))
-
-The [CoreSyn let/app invariant] means that, other things being equal, because 
-the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
-
-   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
-
-But that is bad for two reasons: 
-  (a) we now evaluate y before x, and 
-  (b) we can't bind v to an unboxed pair
-
-Seq is very, very special!  So we recognise it right here, and desugar to
-        case x of _ -> case y of _ -> (# x,y #)
-
-Note [Desugaring seq (2)]  cf Trac #2231
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   let chp = case b of { True -> fst x; False -> 0 }
-   in chp `seq` ...chp...
-Here the seq is designed to plug the space leak of retaining (snd x)
-for too long.
-
-If we rely on the ordinary inlining of seq, we'll get
-   let chp = case b of { True -> fst x; False -> 0 }
-   case chp of _ { I# -> ...chp... }
-
-But since chp is cheap, and the case is an alluring contet, we'll
-inline chp into the case scrutinee.  Now there is only one use of chp,
-so we'll inline a second copy.  Alas, we've now ruined the purpose of
-the seq, by re-introducing the space leak:
-    case (case b of {True -> fst x; False -> 0}) of
-      I# _ -> ...case b of {True -> fst x; False -> 0}...
-
-We can try to avoid doing this by ensuring that the binder-swap in the
-case happens, so we get his at an early stage:
-   case chp of chp2 { I# -> ...chp2... }
-But this is fragile.  The real culprit is the source program.  Perhaps we
-should have said explicitly
-   let !chp2 = chp in ...chp2...
-
-But that's painful.  So the code here does a little hack to make seq
-more robust: a saturated application of 'seq' is turned *directly* into
-the case expression. So we desugar to:
-   let chp = case b of { True -> fst x; False -> 0 }
-   case chp of chp { I# -> ...chp... }
-Notice the shadowing of the case binder! And now all is well.
-
-The reason it's a hack is because if you define mySeq=seq, the hack
-won't work on mySeq.  
-
-Note [Desugaring seq (3)] cf Trac #2409
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The isLocalId ensures that we don't turn 
-        True `seq` e
-into
-        case True of True { ... }
-which stupidly tries to bind the datacon 'True'. 
-\begin{code}
--- The functions from this point don't really do anything cleverer than
--- their counterparts in CoreSyn, but they are here for consistency
+The functions from this point don't really do anything cleverer than
+their counterparts in CoreSyn, but they are here for consistency
 
+\begin{code}
 -- | Create a lambda where the given expression has a number of variables
 -- bound over it. The leftmost binder is that bound by the outermost
 -- lambda in the result
@@ -377,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
@@ -386,12 +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 [ty] = ty
-mkCoreTupTy tys  = mkTupleTy Boxed (length tys) tys
-
-
 -- | Build a big tuple holding the specified variables
 mkBigCoreVarTup :: [Id] -> CoreExpr
 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
@@ -406,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}
 
 %************************************************************************
@@ -450,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 ]
@@ -511,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}