Merge remote-tracking branch 'origin/master' into type-nats

3 files changed, 101 insertions, 10 deletions

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index dfc9991aa5..b9054f43db 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -190,6 +190,12 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        ; checkL (not (isStrictId binder)
             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
            (mkStrictMsg binder)
+        -- Check that if the binder is local, it is not marked as exported
+       ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
+           (mkNonTopExportedMsg binder)
+        -- Check that if the binder is local, it does not have an external name
+       ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
+           (mkNonTopExternalNameMsg binder)
         -- Check whether binder's specialisations contain any out-of-scope variables
        ; mapM_ (checkBndrIdInScope binder) bndr_vars 
 
@@ -1030,7 +1036,7 @@ lookupIdInScope id
 		Nothing -> do { addErrL out_of_scope
 			      ; return id } }
   where
-    out_of_scope = ppr id <+> ptext (sLit "is out of scope")
+    out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope")
 
 
 oneTupleDataConId :: Id	-- Should not happen
@@ -1050,7 +1056,7 @@ checkInScope :: SDoc -> Var -> LintM ()
 checkInScope loc_msg var =
  do { subst <- getTvSubst
     ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
-             (hsep [ppr var, loc_msg]) }
+             (hsep [pprBndr LetBind var, loc_msg]) }
 
 checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
 -- check ty2 is subtype of ty1 (ie, has same structure but usage
@@ -1230,6 +1236,13 @@ mkStrictMsg binder
 	      hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
 	     ]
 
+mkNonTopExportedMsg :: Id -> MsgDoc
+mkNonTopExportedMsg binder
+  = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder]
+
+mkNonTopExternalNameMsg :: Id -> MsgDoc
+mkNonTopExternalNameMsg binder
+  = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder]
 
 mkKindErrMsg :: TyVar -> Type -> MsgDoc
 mkKindErrMsg tyvar arg_ty
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index d7296e3e25..4faad7fc25 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -917,10 +917,10 @@ instance Outputable AltCon where
 instance Show AltCon where
   showsPrec p con = showsPrecSDoc p (ppr con)
 
-cmpAlt :: Alt b -> Alt b -> Ordering
+cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering
 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 
-ltAlt :: Alt b -> Alt b -> Bool
+ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool
 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 
 cmpAltCon :: AltCon -> AltCon -> Ordering
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 198ac7e610..44aebb8169 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -15,7 +15,8 @@ module CoreUtils (
         mkAltExpr,
 
         -- * Taking expressions apart
-        findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
+        findDefault, findAlt, isDefaultAlt,
+        mergeAlts, trimConArgs, filterAlts,
 
         -- * Properties of expressions
         exprType, coreAltType, coreAltsType,
@@ -69,7 +70,7 @@ import Util
 import Pair
 import Data.Word
 import Data.Bits
-import Data.List ( mapAccumL )
+import Data.List
 \end{code}
 
 
@@ -342,18 +343,18 @@ This makes it easy to find, though it makes matching marginally harder.
 
 \begin{code}
 -- | Extract the default case alternative
-findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
+findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 findDefault alts                        =                     (alts, Nothing)
 
-isDefaultAlt :: CoreAlt -> Bool
+isDefaultAlt :: (AltCon, a, b) -> Bool
 isDefaultAlt (DEFAULT, _, _) = True
 isDefaultAlt _               = False
 
 
 -- | Find the case alternative corresponding to a particular
 -- constructor: panics if no such constructor exists
-findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
+findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
     -- A "Nothing" result *is* legitmiate
     -- See Note [Unreachable code]
 findAlt con alts
@@ -369,7 +370,7 @@ findAlt con alts
           GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 
 ---------------------------------
-mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
+mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
 -- ^ Merge alternatives preserving order; alternatives in
 -- the first argument shadow ones in the second
 mergeAlts [] as2 = as2
@@ -396,6 +397,83 @@ trimConArgs (LitAlt _)   args = ASSERT( null args ) []
 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 \end{code}
 
+\begin{code}
+filterAlts :: [Unique]             -- ^ Supply of uniques used in case we have to manufacture a new AltCon
+           -> Type                 -- ^ Type of scrutinee (used to prune possibilities)
+           -> [AltCon]             -- ^ Constructors known to be impossible due to the form of the scrutinee
+           -> [(AltCon, [Var], a)] -- ^ Alternatives
+           -> ([AltCon], Bool, [(AltCon, [Var], a)])
+             -- Returns:
+             --  1. Constructors that will never be encountered by the *default* case (if any)
+             --  2. Whether we managed to refine the default alternative into a specific constructor (for statistcs only)
+             --  3. The new alternatives
+             --
+             -- NB: the final list of alternatives may be empty:
+             -- This is a tricky corner case.  If the data type has no constructors,
+             -- which GHC allows, then the case expression will have at most a default
+             -- alternative.
+             --
+             -- If callers need to preserve the invariant that there is always at least one branch
+             -- in a "case" statement then they will need to manually add a dummy case branch that just
+             -- calls "error" or similar.
+filterAlts us ty imposs_cons alts = (imposs_deflt_cons, refined_deflt, merged_alts)
+  where
+    (alts_wo_default, maybe_deflt) = findDefault alts
+    alt_cons = [con | (con,_,_) <- alts_wo_default]
+    imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
+      -- "imposs_deflt_cons" are handled 
+      --   EITHER by the context, 
+      --   OR by a non-DEFAULT branch in this case expression.
+
+    trimmed_alts = filterOut impossible_alt alts_wo_default
+    merged_alts  = mergeAlts trimmed_alts (maybeToList maybe_deflt')
+      -- We need the mergeAlts in case the new default_alt 
+      -- has turned into a constructor alternative.
+      -- The merge keeps the inner DEFAULT at the front, if there is one
+      -- and interleaves the alternatives in the right order
+
+    (refined_deflt, maybe_deflt') = case maybe_deflt of
+      Just deflt_rhs -> case mb_tc_app of
+        Just (tycon, inst_tys)
+          |     -- This branch handles the case where we are 
+                -- scrutinisng an algebraic data type
+            isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.  
+          , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:
+                                        --      case x of { DEFAULT -> e }
+                                        -- and we don't want to fill in a default for them!
+          , Just all_cons <- tyConDataCons_maybe tycon
+          , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type 
+                impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
+          -> case filterOut impossible all_cons of
+               -- Eliminate the default alternative
+               -- altogether if it can't match:
+               []    -> (False, Nothing)
+               -- It matches exactly one constructor, so fill it in:
+               [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs))
+                 where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
+               _     -> (False, Just (DEFAULT, [], deflt_rhs))
+
+          | debugIsOn, isAlgTyCon tycon
+          , null (tyConDataCons tycon)
+          , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
+                -- Check for no data constructors
+                -- This can legitimately happen for abstract types and type families,
+                -- so don't report that
+          -> pprTrace "prepareDefault" (ppr tycon)
+             (False, Just (DEFAULT, [], deflt_rhs))
+
+        _ -> (False, Just (DEFAULT, [], deflt_rhs))
+      Nothing -> (False, Nothing)
+  
+    mb_tc_app = splitTyConApp_maybe ty
+    Just (_, inst_tys) = mb_tc_app
+
+    impossible_alt :: (AltCon, a, b) -> Bool
+    impossible_alt (con, _, _) | con `elem` imposs_cons = True
+    impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
+    impossible_alt _                   = False
+\end{code}
+
 Note [Unreachable code]
 ~~~~~~~~~~~~~~~~~~~~~~~
 It is possible (although unusual) for GHC to find a case expression