X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=eed7f87d8f304c49d989ff832729f5325d368fb0;hp=0633717d09538b9f0f1077a42729eb7efa4e3731;hb=27de38efce6d73d2a0209f803cfa98c82773e773;hpb=6febb616f1ff46942434e9df39c6e4977b07cc6f

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 0633717..eed7f87 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -42,6 +42,7 @@ import TcType
 import Type
 import CoreSyn
 import CoreUtils
+import MkCore
 
 import DynFlags
 import CostCentre
@@ -211,7 +212,7 @@ dsExpr (HsLam a_Match)
   = 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
@@ -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
-    mkDsApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
+    mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
     
 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
@@ -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 $
-            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
@@ -265,10 +266,15 @@ dsExpr (HsSCC cc expr) = do
 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
@@ -505,10 +511,8 @@ dsExpr (HsBinTick ixT ixF e) = do
 
 \begin{code}
 
-#ifdef DEBUG
 -- HsSyn constructs that just shouldn't be here:
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
-#endif
 
 
 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
-   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.
-
 \begin{code}
 
 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr