When desugaring Use the smart mkCoreConApps and friends
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 1 Aug 2014 15:56:10 +0000 (16:56 +0100)
committerAustin Seipp <austin@well-typed.com>
Mon, 15 Dec 2014 15:03:18 +0000 (09:03 -0600)
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)

compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/MatchLit.lhs

index f878776..0ea18d1 100644 (file)
@@ -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
index f3f0adc..69735f1 100644 (file)
@@ -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
 
index a9b7003..5d8f34b 100644 (file)
@@ -290,9 +290,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
@@ -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:
index 65bb935..8514325 100644 (file)
@@ -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 []
index 9652bdf..ff834e6 100644 (file)
@@ -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