X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=7f752f88c2e65b60693ffa4ee8ba2c470e8a35da;hb=c5dbdf06b92472ef64b66a01f107ba30b65c3708;hp=020b7b4fa3acf7f3c44686633cb238b2372c3d4f;hpb=7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 020b7b4..7f752f8 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -36,11 +36,11 @@ import TcType
 import CostCentre
 import Module
 import Id
+import MkId	( seqId )
 import Var	( Var, TyVar )
 import VarSet
 import Rules
 import VarEnv
-import Type
 import Outputable
 import SrcLoc
 import Maybes
@@ -163,14 +163,16 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
   where B is the *non-recursive* binding
 	fl = fg a b
 	gl = gg b
-	h  = h a b 
+	h  = h a b    -- See (b); note shadowing!
   
   Notice (a) g has a different number of type variables to f, so we must
 	     use the mkArbitraryType thing to fill in the gaps.  
 	     We use a type-let to do that.
 
 	 (b) The local variable h isn't in the exports, and rather than
-	     clone a fresh copy we simply replace h by (h a b).  
+	     clone a fresh copy we simply replace h by (h a b), where
+	     the two h's have different types!  Shadowing happens here,
+	     which looks confusing but works fine.
 
 	 (c) The result is *still* quadratic-sized if there are a lot of
 	     small bindings.  So if there are more than some small
@@ -260,22 +262,22 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 
 	; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
 
-	; let dict_args = map Var dicts
-
-	      mk_bind ((tyvars, global, local, prags), n)	-- locals !! n == local
-	        = 	-- Need to make fresh locals to bind in the selector, because
-		      	-- some of the tyvars will be bound to 'Any'
+	; let mk_bind ((tyvars, global, local, prags), n)  -- locals!!n == local
+	        = 	-- Need to make fresh locals to bind in the selector,
+		      	-- because some of the tyvars will be bound to 'Any'
 		  do { ty_args <- mapM mk_ty_arg all_tyvars
 		     ; let substitute = substTyWith all_tyvars ty_args
 		     ; locals' <- newSysLocalsDs (map substitute local_tys)
 		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
-		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
+		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global
+		 			 local core_bind) 
 				      	 prags
 		     ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
 			   global' = addIdSpecialisations global rules
 	                   rhs = mkLams tyvars $ mkLams dicts $
 	      	     		 mkTupleSelector locals' (locals' !! n) tup_id $
-			         mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
+			         mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
+			 		   dicts
 		     ; return ((global', rhs) : spec_binds) }
 	        where
 	          mk_ty_arg all_tyvar
@@ -474,6 +476,12 @@ decomposeRuleLhs lhs
         -- a LHS:       let f71 = M.f Int in f71
     decomp env (Let (NonRec dict rhs) body) 
         = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
+
+    decomp env (Case scrut bndr ty [(DEFAULT, _, body)])
+        | isDeadBinder bndr	-- Note [Matching seqId]
+        = Just (seqId, [Type (idType bndr), Type ty, 
+                        simpleSubst env scrut, simpleSubst env body])
+
     decomp env body 
         = case collectArgs (simpleSubst env body) of
             (Var fn, args) -> Just (fn, args)
@@ -514,17 +522,23 @@ addInlinePrags prags bndr rhs
 	(inl:_) -> addInlineInfo inl bndr rhs
 
 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
-addInlineInfo (Inline phase is_inline) bndr rhs
-  = (attach_phase bndr phase, wrap_inline is_inline rhs)
+addInlineInfo (Inline prag is_inline) bndr rhs
+  = (attach_pragma bndr prag, wrap_inline is_inline rhs)
   where
-    attach_phase bndr phase 
-	| isAlwaysActive phase = bndr	-- Default phase
-	| otherwise  	       = bndr `setInlinePragma` phase
+    attach_pragma bndr prag
+        | isDefaultInlinePragma prag = bndr
+        | otherwise                  = bndr `setInlinePragma` prag
 
     wrap_inline True  body = mkInlineMe body
     wrap_inline False body = body
 \end{code}
 
+Note [Matching seq]
+~~~~~~~~~~~~~~~~~~~
+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
+and this code turns it back into an application of seq!  
+See Note [Rules for seq] in MkId for the details.
+
 
 %************************************************************************
 %*									*