Robustify the treatement of DFunUnfolding

[ghc-hetmet.git] / compiler / deSugar / DsBinds.lhs

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 31cb75d..2c6f361 100644 (file)
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -38,6 +38,7 @@ import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
 import Id
+import Name    ( localiseName )
 import MkId    ( seqId )
 import Var     ( Var, TyVar, tyVarKind )
 import IdInfo  ( vanillaIdInfo )
@@ -260,9 +261,10 @@ makeCorePair gbl_id is_default_method dict_arity rhs
   | Just arity <- inlinePragmaSat inline_prag
        -- Add an Unfolding for an INLINE (but not for NOINLINE)
        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
-  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just (dict_arity + arity)),
-           -- NB: The arity in the InlineRule takes account of the dictionaries
-     etaExpand arity rhs)
+  , let real_arity = dict_arity + arity
+        -- NB: The arity in the InlineRule takes account of the dictionaries
+  = (gbl_id `setIdUnfolding` mkInlineRule rhs (Just real_arity),
+     etaExpand real_arity rhs)
 
   | otherwise
   = (gbl_id `setIdUnfolding` mkInlineRule rhs Nothing, rhs)
@@ -460,6 +462,7 @@ dsSpecs poly_id poly_rhs prags
           ; spec_name <- newLocalName poly_name
           ; wrap_fn   <- dsCoercion spec_co
            ; let ds_spec_expr = wrap_fn (Var poly_id)
+                 spec_ty = exprType ds_spec_expr
           ; case decomposeRuleLhs ds_spec_expr of {
               Nothing -> do { warnDs (decomp_msg spec_co)
                              ; return Nothing } ;
@@ -471,10 +474,9 @@ dsSpecs poly_id poly_rhs prags
                bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
                   | otherwise -> do
 
-          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
+          { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
 
-          ; let spec_ty = exprType ds_spec_expr
-                spec_id  = mkLocalId spec_name spec_ty 
+          ; let spec_id  = mkLocalId spec_name spec_ty 
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
                 inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
@@ -482,10 +484,10 @@ dsSpecs poly_id poly_rhs prags
                      -- Get the INLINE pragma from SPECIALISE declaration, or,
                       -- failing that, from the original Id
 
-                extra_dict_bndrs = [ localiseId d  -- See Note [Constant rule dicts]
+                extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
+                                            -- See Note [Constant rule dicts]
                                    | d <- varSetElems (exprFreeVars ds_spec_expr)
                                    , isDictId d]
-                               -- Note [Const rule dicts]
 
                 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
                                AlwaysActive poly_name
@@ -509,12 +511,13 @@ dsSpecs poly_id poly_rhs prags
             2 (pprHsWrapper (ppr poly_id) spec_co)
             
 
-specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
-specUnfolding wrap_fn (DFunUnfolding con ops)
+specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
+              -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
-       ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) }
-specUnfolding _ _
+       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
+specUnfolding _ _ _
   = return (noUnfolding, [])
 
 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
@@ -552,7 +555,7 @@ the constraint is unused.  We could bind 'd' to (error "unused")
 but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
 
-Note [Const rule dicts]
+Note [Constant rule dicts]
 ~~~~~~~~~~~~~~~~~~~~~~~
 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
 which is presumably in scope at the function definition site, we can quantify 
@@ -573,8 +576,9 @@ And from that we want the rule
 
 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
 Name, and you can't bind them in a lambda or forall without getting things
-confused. Hence the use of 'localiseId' to make it Internal.
-
+confused.   Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.
 
 %************************************************************************
 %*                                                                     *
@@ -631,6 +635,7 @@ See Note [Rules for seq] in MkId for the details.
 data AutoScc = NoSccs 
             | AddSccs Module (Id -> Bool)
 -- The (Id->Bool) says which Ids to add SCCs to 
+-- But we never add a SCC to function marked INLINE
 
 addAutoScc :: AutoScc  
           -> Id        -- Binder
@@ -639,6 +644,8 @@ addAutoScc :: AutoScc
 
 addAutoScc NoSccs _ rhs
   = rhs
+addAutoScc _ id rhs | isInlinePragma (idInlinePragma id)
+  = rhs
 addAutoScc (AddSccs mod add_scc) id rhs
   | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
   | otherwise  = rhs