[commit: ghc] ghc-7.8: When desugaring Use the smart mkCoreConApps and friends (fea3853)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/fea3853ff2880ee22eb633bb90f949232679a1c7/ghc

>---------------------------------------------------------------

commit fea3853ff2880ee22eb633bb90f949232679a1c7
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Aug 1 16:56:10 2014 +0100

    When desugaring Use the smart mkCoreConApps and friends
    
    This is actually the bug that triggered Trac #9390.  We had
    an unboxed tuple (# writeArray# ..., () #), and that writeArray#
    argument isn't ok-for-speculation, so disobeys the invariant.
    
    The desugaring of unboxed tuples was to blame; the fix is easy.
    
    (cherry picked from commit 1fc60ea1f1fd89b90c2992d060aecb5b5a65f8c0)


>---------------------------------------------------------------

fea3853ff2880ee22eb633bb90f949232679a1c7
 compiler/deSugar/DsArrows.lhs | 4 ++--
 compiler/deSugar/DsCCall.lhs  | 6 +++---
 compiler/deSugar/DsExpr.lhs   | 6 +++---
 compiler/deSugar/DsMeta.hs    | 2 +-
 compiler/deSugar/MatchLit.lhs | 2 +-
 5 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index f878776..0ea18d1 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -465,8 +465,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
     left_con   <- dsLookupDataCon leftDataConName
     right_con  <- dsLookupDataCon rightDataConName
 
-    let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
-        mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1, Type ty2, e]
+        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e]
 
         in_ty = envStackType env_ids stack_ty
         then_ty = envStackType then_ids stack_ty
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index f3f0adc..69735f1 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -236,9 +236,9 @@ boxResult result_ty
 		     _ -> []
 
 	      return_result state anss
-		= mkConApp (tupleCon UnboxedTuple (2 + length extra_result_tys))
-	         	   (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
-			      ++ (state : anss)) 
+		= mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys))
+	         	        (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+			         ++ (state : anss)) 
 
 	; (ccall_res_ty, the_alt) <- mk_alt return_result res
 
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index a9b7003..5d8f34b 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -291,8 +291,8 @@ dsExpr (ExplicitTuple tup_args boxity)
                 -- The reverse is because foldM goes left-to-right
 
        ; return $ mkCoreLams lam_vars $
-                  mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
-                           (map (Type . exprType) args ++ args) }
+                  mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
+                                (map (Type . exprType) args ++ args) }
 
 dsExpr (HsSCC cc expr@(L loc _)) = do
     mod_name <- getModule
@@ -433,7 +433,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
                 then mapM unlabelled_bottom arg_tys
                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
     
-    return (mkApps con_expr' con_args)
+    return (mkCoreApps con_expr' con_args)
 \end{code}
 
 Record update is a little harder. Suppose we have the decl:
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 65bb935..8514325 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1490,7 +1490,7 @@ rep2 n xs = do { id <- dsLookupGlobalId n
 
 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
 dataCon' n args = do { id <- dsLookupDataCon n
-                     ; return $ MkC $ mkConApp id args }
+                     ; return $ MkC $ mkCoreConApps id args }
 
 dataCon :: Name -> DsM (Core a)
 dataCon n = dataCon' n []
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 9652bdf..ff834e6 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -90,7 +90,7 @@ dsLit (HsInt i)        = do dflags <- getDynFlags
 dsLit (HsRat r ty) = do
    num   <- mkIntegerExpr (numerator (fl_value r))
    denom <- mkIntegerExpr (denominator (fl_value r))
-   return (mkConApp ratio_data_con [Type integer_ty, num, denom])
+   return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
   where
     (ratio_data_con, integer_ty)
         = case tcSplitTyConApp ty of