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.

5 files changed, 11 insertions, 11 deletions

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 1bbcc05e40..35a2477fd5 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -466,8 +466,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 217a4ce7c9..a47b9ea4dd 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -238,9 +238,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 4eadef69b8..2a2d733995 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -292,9 +292,9 @@ dsExpr (ExplicitTuple tup_args boxity)
        ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
                 -- 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) }
+       ; return $ mkCoreLams lam_vars $
+                  mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
+                                (map (Type . exprType) args ++ args) }
 
 dsExpr (HsSCC cc expr@(L loc _)) = do
     mod_name <- getModule
@@ -435,7 +435,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 2713f95ab6..28e6feffec 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1476,7 +1476,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 350ed22d69..71a5e10636 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -92,7 +92,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