The Big INLINE Patch: totally reorganise way that INLINE pragmas work

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index cf29748..af99bc2 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -17,8 +17,6 @@ module TcSimplify (
        tcSimplifyDeriv, tcSimplifyDefault,
        bindInstsOfLocalFuns, 
        
-        tcSimplifyStagedExpr,
-
         misMatchMsg
     ) where
 
@@ -45,7 +43,6 @@ import Class
 import FunDeps
 import PrelInfo
 import PrelNames
-import Type
 import TysWiredIn
 import ErrUtils
 import BasicTypes
@@ -54,7 +51,6 @@ import VarEnv
 import FiniteMap
 import Bag
 import Outputable
-import Maybes
 import ListSetOps
 import Util
 import SrcLoc
@@ -1022,16 +1018,17 @@ makeImplicationBind loc all_tvs
                     <.> mkWpTyApps eq_cotvs
                     <.> mkWpTyApps (mkTyVarTys all_tvs)
              bind | [dict_irred_id] <- dict_irred_ids  
-                   = VarBind dict_irred_id rhs
+                   = mkVarBind dict_irred_id rhs
                   | otherwise        
-                   = PatBind { pat_lhs = lpat
+                   = L span $ 
+                     PatBind { pat_lhs = lpat
                             , pat_rhs = unguardedGRHSs rhs 
                             , pat_rhs_ty = hsLPatType lpat
                             , bind_fvs = placeHolderNames 
                              }
 
        ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
-       ; return ([implic_inst], unitBag (L span bind)) 
+       ; return ([implic_inst], unitBag bind) 
         }
 
 -----------------------------------------------------------
@@ -1589,13 +1586,23 @@ Simpler, maybe, but alas not simple (see Trac #2494)
 tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds)
 tcSimplifyRuleLhs wanteds
   = do { wanteds' <- zonkInsts wanteds
-       ; (irreds, binds) <- go [] emptyBag wanteds'
+       
+               -- Simplify equalities  
+               -- It's important to do this: Trac #3346 for example
+        ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds'
+        ; execTcTyVarBinds tybinds
+
+               -- Simplify other constraints
+       ; (irreds, binds2) <- go [] emptyBag wanteds''
+
+               -- Report anything that is left
        ; let (dicts, bad_irreds) = partition isDict irreds
        ; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds)
        ; addNoInstanceErrs (nub bad_irreds)
                -- The nub removes duplicates, which has
                -- not happened otherwise (see notes above)
-       ; return (dicts, binds) }
+
+       ; return (dicts, binds1 `unionBags` binds2) }
   where
     go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds)
     go irreds binds []
@@ -1637,7 +1644,7 @@ this bracket again at its usage site.
 \begin{code}
 tcSimplifyBracket :: [Inst] -> TcM ()
 tcSimplifyBracket wanteds
-  = do { tryHardCheckLoop doc wanteds
+  = do { _ <- tryHardCheckLoop doc wanteds
        ; return () }
   where
     doc = text "tcSimplifyBracket"
@@ -2375,11 +2382,7 @@ reduceImplication env
               eq_cotvs = map instToVar extra_eq_givens
              dict_ids = map instToId  extra_dict_givens 
 
-                        -- Note [Always inline implication constraints]
-              wrap_inline | null dict_ids = idHsWrapper
-                          | otherwise    = WpInline
-              co         = wrap_inline
-                           <.> mkWpTyLams tvs
+              co         = mkWpTyLams tvs
                            <.> mkWpTyLams eq_cotvs
                            <.> mkWpLams dict_ids
                            <.> WpLet (binds `unionBags` bind)
@@ -2391,12 +2394,15 @@ reduceImplication env
                            . filter (not . isEqInst) 
                            $ wanteds
               payload    = mkBigLHsTup dict_bndrs
-
        
        ; traceTc (vcat [text "reduceImplication" <+> ppr name,
                         ppr simpler_implic_insts,
                         text "->" <+> ppr rhs])
-       ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
+       ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
+                                         , var_rhs = rhs
+                                         , var_inline = notNull dict_ids }
+                               -- See Note [Always inline implication constraints]
+                         )),
                  simpler_implic_insts)
        } 
     }
@@ -2906,7 +2912,7 @@ disambigGroup default_tys dicts
   = do { mb_chosen_ty <- try_default default_tys
        ; case mb_chosen_ty of
             Nothing        -> return ()
-            Just chosen_ty -> do { unifyType chosen_ty (mkTyVarTy tyvar) 
+            Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) 
                                 ; warnDefault dicts chosen_ty } }
   where
     (_,_,tyvar) = ASSERT(not (null dicts)) head dicts  -- Should be non-empty
@@ -3049,25 +3055,6 @@ tcSimplifyDefault theta = do
     doc = ptext (sLit "default declaration")
 \end{code}
 
-@tcSimplifyStagedExpr@ performs a simplification but does so at a new
-stage. This is used when typechecking annotations and splices.
-
-\begin{code}
-
-tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds)
--- Type check an expression that runs at a top level stage as if
---   it were going to be spliced and then simplify it
-tcSimplifyStagedExpr stage tc_action
-  = setStage stage $ do { 
-        -- Typecheck the expression
-         (thing', lie) <- getLIE tc_action
-       
-       -- Solve the constraints
-       ; const_binds <- tcSimplifyTop lie
-       
-       ; return (thing', const_binds) }
-
-\end{code}
 
 
 %************************************************************************
@@ -3099,7 +3086,7 @@ groupErrs report_err (inst:insts)
    (friends, others) = partition is_friend insts
    loc_msg          = showSDoc (pprInstLoc (instLoc inst))
    is_friend friend  = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
-   do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
+   do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts)
                -- Add location and context information derived from the Insts
 
 -- Add the "arising from..." part to a message about bunch of dicts
@@ -3308,7 +3295,7 @@ monomorphism_fix dflags
 warnDefault :: [(Inst, Class, Var)] -> Type -> TcM ()
 warnDefault ups default_ty = do
     warn_flag <- doptM Opt_WarnTypeDefaults
-    addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
+    setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
   where
     dicts = [d | (d,_,_) <- ups]