Mostly fix Trac #2431: make empty case acceptable to (most of) GHC

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

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 0633717..eed7f87 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -42,6 +42,7 @@ import TcType
 import Type
 import CoreSyn
 import CoreUtils
 import Type
 import CoreSyn
 import CoreUtils

+import MkCore

 
 import DynFlags
 import CostCentre
 
 import DynFlags
 import CostCentre

@@ -211,7 +212,7 @@ dsExpr (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 
 dsExpr (HsApp fun arg)
   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 
 dsExpr (HsApp fun arg)

-  = mkDsApp <$> dsLExpr fun <*>  dsLExpr arg
+  = mkCoreApp <$> dsLExpr fun <*>  dsLExpr arg

 \end{code}
 
 Operator sections.  At first it looks as if we can convert
 \end{code}
 
 Operator sections.  At first it looks as if we can convert

@@ -238,10 +239,10 @@ will sort it out.
 \begin{code}
 dsExpr (OpApp e1 op _ e2)
   = -- for the type of y, we need the type of op's 2nd argument
 \begin{code}
 dsExpr (OpApp e1 op _ e2)
   = -- for the type of y, we need the type of op's 2nd argument

-    mkDsApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+    mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]

     
 dsExpr (SectionL expr op)      -- Desugar (e !) to ((!) e)
     
 dsExpr (SectionL expr op)      -- Desugar (e !) to ((!) e)

-  = mkDsApp <$> dsLExpr op <*> dsLExpr expr
+  = mkCoreApp <$> dsLExpr op <*> dsLExpr expr

 
 -- dsLExpr (SectionR op expr)  -- \ x -> op x expr
 dsExpr (SectionR op expr) = do
 
 -- dsLExpr (SectionR op expr)  -- \ x -> op x expr
 dsExpr (SectionR op expr) = do

@@ -253,7 +254,7 @@ dsExpr (SectionR op expr) = do
     x_id <- newSysLocalDs x_ty
     y_id <- newSysLocalDs y_ty
     return (bindNonRec y_id y_core $
     x_id <- newSysLocalDs x_ty
     y_id <- newSysLocalDs y_ty
     return (bindNonRec y_id y_core $

-            Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
+            Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))

 
 dsExpr (HsSCC cc expr) = do
     mod_name <- getModuleDs
 
 dsExpr (HsSCC cc expr) = do
     mod_name <- getModuleDs

@@ -265,10 +266,15 @@ dsExpr (HsSCC cc expr) = do
 dsExpr (HsCoreAnn fs expr)
   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 
 dsExpr (HsCoreAnn fs expr)
   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 

-dsExpr (HsCase discrim matches) = do
-    core_discrim <- dsLExpr discrim
-    ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
-    return (scrungleMatch discrim_var core_discrim matching_code)
+dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
+  | isEmptyMatchGroup matches  -- A Core 'case' is always non-empty
+  =                            -- So desugar empty HsCase to error call
+    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case"
+
+  | otherwise
+  = do { core_discrim <- dsLExpr discrim
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+       ; return (scrungleMatch discrim_var core_discrim matching_code) }

 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints

@@ -505,10 +511,8 @@ dsExpr (HsBinTick ixT ixF e) = do
 
 \begin{code}
 
 
 \begin{code}
 

-#ifdef DEBUG

 -- HsSyn constructs that just shouldn't be here:
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 -- HsSyn constructs that just shouldn't be here:
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"

-#endif

 
 
 findField :: [HsRecField Id arg] -> Name -> [arg]
 
 
 findField :: [HsRecField Id arg] -> Name -> [arg]

@@ -541,13 +545,18 @@ fruitless allocations.  Essentially, whenever we see a list literal
    
    If fusion fails to occur then build will get inlined and (since we
    defined a RULE for foldr (:) []) we will get back exactly the
    
    If fusion fails to occur then build will get inlined and (since we
    defined a RULE for foldr (:) []) we will get back exactly the

-   normal desugaring for an explicit list! However, if it does occur
-   then we can potentially save quite a bit of allocation (up to 25\%
-   of the total in some nofib programs!)
+   normal desugaring for an explicit list.
+
+This optimisation can be worth a lot: up to 25% of the total
+allocation in some nofib programs. Specifically
+
+        Program           Size    Allocs   Runtime  CompTime
+        rewrite          +0.0%    -26.3%      0.02     -1.8%
+           ansi          -0.3%    -13.8%      0.00     +0.0%
+           lift          +0.0%     -8.7%      0.00     -2.3%

 
 Of course, if rules aren't turned on then there is pretty much no
 point doing this fancy stuff, and it may even be harmful.
 
 Of course, if rules aren't turned on then there is pretty much no
 point doing this fancy stuff, and it may even be harmful.

-

 \begin{code}
 
 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 \begin{code}
 
 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr