Get evaluated-ness right in the back end
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 3 Jan 2018 10:48:26 +0000 (10:48 +0000)
committerGabor Greif <ggreif@gmail.com>
Fri, 23 Aug 2019 17:53:07 +0000 (19:53 +0200)
See Trac #14626, comment:4.  We want to maintain evaluted-ness
info on Ids into the code generateor for two reasons
(see Note [Preserve evaluated-ness in CorePrep] in CorePrep)

- DataToTag magic
- Potentially using it in the codegen (this is Gabor's
  current work)

But it was all being done very inconsistently, and actually
outright wrong -- the DataToTag magic hasn't been working for
years.

This patch tidies it all up, with Notes to match.

Conflicts:
testsuite/tests/codeGen/should_compile/all.T

compiler/coreSyn/CorePrep.hs
compiler/main/TidyPgm.hs
testsuite/tests/codeGen/should_compile/Makefile
testsuite/tests/codeGen/should_compile/T14626.hs [new file with mode: 0644]
testsuite/tests/codeGen/should_compile/T14626.stdout
testsuite/tests/codeGen/should_compile/all.T
testsuite/tests/deSugar/should_compile/T2431.stderr
testsuite/tests/simplCore/should_compile/T13143.stderr
testsuite/tests/simplCore/should_compile/T3772.stdout
testsuite/tests/simplCore/should_compile/T4930.stderr
testsuite/tests/simplCore/should_compile/spec-inline.stderr

index 6be5346..8758f91 100644 (file)
@@ -1092,6 +1092,52 @@ maybeSaturate fn expr n_args
     excess_arity = fn_arity - n_args
     sat_expr     = cpeEtaExpand excess_arity expr
 
+-------------
+saturateDataToTag :: CpeApp -> UniqSM CpeApp
+-- See Note [dataToTag magic]
+saturateDataToTag sat_expr
+  = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
+       ; eta_body' <- eval_data2tag_arg eta_body
+       ; return (mkLams eta_bndrs eta_body') }
+  where
+    eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
+    eval_data2tag_arg app@(fun `App` arg)
+        | exprIsHNF arg         -- Includes nullary constructors
+        = return app            -- The arg is evaluated
+        | otherwise                     -- Arg not evaluated, so evaluate it
+        = do { arg_id <- newVar (exprType arg)
+             ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
+             ; return (Case arg arg_id1 (exprType app)
+                            [(DEFAULT, [], fun `App` Var arg_id1)]) }
+
+    eval_data2tag_arg (Tick t app)    -- Scc notes can appear
+        = do { app' <- eval_data2tag_arg app
+             ; return (Tick t app') }
+
+    eval_data2tag_arg other     -- Should not happen
+        = pprPanic "eval_data2tag" (ppr other)
+
+{- Note [dataToTag magic]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We must ensure that the arg of data2TagOp is evaluated. So
+in general CorePrep does this transformation:
+  data2tag e   -->   case e of y -> data2tag y
+(yuk yuk) take into account the lambdas we've now introduced
+
+How might it not be evaluated?  Well, we might have floated it out
+of the scope of a `seq`, or dropped the `seq` altogether.
+
+We only do this if 'e' is not a WHNF.  But if it's a simple
+variable (common case) we need to know it's evaluated-ness flag.
+Example:
+   data T = MkT !Bool
+   f v = case v of
+           MkT y -> dataToTag# y
+Here we don't want to generate an extra case on 'y', because it's
+already evaluated.  So we want to keep the evaluated-ness flag
+on y.  See Note [Preserve evaluated-ness in CorePrep].
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1592,7 +1638,7 @@ cpCloneBndr env bndr
 
        -- Drop (now-useless) rules/unfoldings
        -- See Note [Drop unfoldings and rules]
-       -- and Note [Preserve evaluatedness] in CoreTidy
+       -- and Note [Preserve evaluated-ness in CorePrep]
        ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
                           -- Simplifier will set the Id's unfolding
 
@@ -1624,8 +1670,21 @@ We want to drop the unfolding/rules on every Id:
   - We are changing uniques, so if we didn't discard unfoldings/rules
     we'd have to substitute in them
 
-HOWEVER, we want to preserve evaluated-ness;
-see Note [Preserve evaluatedness] in CoreTidy.
+HOWEVER, we want to preserve evaluated-ness; see
+Note [Preserve evaluated-ness in CorePrep]
+
+Note [Preserve evaluated-ness in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to preserve the evaluated-ness of each binder (via
+evaldUnfolding) for two reasons
+
+* In the code generator if we have
+     case x of y { Red -> e1; DEFAULT -> y }
+  we can return 'y' rather than entering it, if we know
+  it is evaluated (Trac #14626)
+
+* In the DataToTag magic (in CorePrep itself) we rely on
+  evaluated-ness.  See Note Note [dataToTag magic].
 -}
 
 ------------------------------------------------------------------------------
index c0c6ffc..171a445 100644 (file)
@@ -232,11 +232,19 @@ Plan B: include pragmas, make interfaces
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * Step 1: Figure out which Ids are externally visible
           See Note [Choosing external Ids]
+<<<<<<< HEAD
 
 * Step 2: Gather the externally visible rules, separately from
           the top-level bindings.
           See Note [Finding external rules]
 
+=======
+
+* Step 2: Gather the extenally visible rules, separately from
+          the top-level bindings.
+          See Note [Finding external rules]
+
+>>>>>>> Get evaluated-ness right in the back end
 * Step 3: Tidy the bindings, externalising appropriate Ids
           See Note [Tidy the top-level bindings]
 
index bcdefcb..0b9cdb2 100644 (file)
@@ -5,6 +5,9 @@ include $(TOP)/mk/test.mk
 T2578:
        '$(TEST_HC)' $(TEST_HC_OPTS) --make T2578 -fforce-recomp -v0
 
+T14626:
+       '$(TEST_HC)' $(TEST_HC_OPTS) -c -O -ddump-prep -dsuppress-uniques T14626.hs | grep case
+
 debug:
        # Without optimisations, we should get annotations for basically
        # all expressions in the example program.
diff --git a/testsuite/tests/codeGen/should_compile/T14626.hs b/testsuite/tests/codeGen/should_compile/T14626.hs
new file mode 100644 (file)
index 0000000..a665694
--- /dev/null
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+
+module T14626 where
+
+import GHC.Prim
+
+data T = MkT !Bool
+
+f v = case v of
+         MkT y -> dataToTag# y
+
+-- This should /not/ produce an inner case on the y, thus:
+--    f v = case v of
+--            MkT y -> case y of z -> dataToTag# z
+-- But it was!  See Trac #14626 comment:4
index 389d3e7..8bb46af 100644 (file)
@@ -1,2 +1,6 @@
+<<<<<<< HEAD
       case dt of dt [Occ=Once] { __DEFAULT -> T14626.MkT dt }
+=======
+      case dt of dt { __DEFAULT -> T14626.MkT dt }
+>>>>>>> Get evaluated-ness right in the back end
       case v of { T14626.MkT y [Occ=Once] ->
index a9dacec..053fa10 100644 (file)
@@ -70,3 +70,6 @@ test('T14373a', [],
      multimod_compile, ['T14373a', '-fasm -O2 -ddump-cmm-from-stg -dsuppress-uniques'])
 test('T14373b', [],
      multimod_compile, ['T14373b', '-fasm -O2 -ddump-cmm-from-stg -dsuppress-uniques'])
+test('T14626',
+     normal,
+     run_command, ['$MAKE -s --no-print-directory T14626'])
index 30b5f8c..ca6c63e 100644 (file)
@@ -17,7 +17,11 @@ T2431.$WRefl
 
 -- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0}
 absurd :: forall a. (Int :~: Bool) -> a
+<<<<<<< HEAD
 [GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>b, Unf=OtherCon []]
+=======
+[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x, Unf=OtherCon []]
+>>>>>>> Get evaluated-ness right in the back end
 absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { }
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
index ddc8b11..c573f65 100644 (file)
@@ -76,7 +76,11 @@ Rec {
 -- RHS size: {terms: 28, types: 7, coercions: 0, joins: 0/0}
 T13143.$wg [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker]
   :: Bool -> Bool -> GHC.Prim.Int# -> GHC.Prim.Int#
+<<<<<<< HEAD
 [GblId, Arity=3, Str=<S,1*U><S,1*U><L,U>, Unf=OtherCon []]
+=======
+[GblId, Arity=3, Str=<S,1*U><S,1*U><S,U>, Unf=OtherCon []]
+>>>>>>> Get evaluated-ness right in the back end
 T13143.$wg
   = \ (w :: Bool) (w1 :: Bool) (ww :: GHC.Prim.Int#) ->
       case w of {
index b19e5d0..6df0b90 100644 (file)
@@ -61,7 +61,11 @@ end Rec }
 
 -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0}
 T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> ()
+<<<<<<< HEAD
 [GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>, Unf=OtherCon []]
+=======
+[GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>, Unf=OtherCon []]
+>>>>>>> Get evaluated-ness right in the back end
 T3772.$wfoo
   = \ (ww :: GHC.Prim.Int#) ->
       case GHC.Prim.<# 0# ww of {
index 07c2cee..1f3cc60 100644 (file)
@@ -51,7 +51,11 @@ Rec {
 -- RHS size: {terms: 17, types: 3, coercions: 0, joins: 0/0}
 T4930.$wfoo [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker]
   :: GHC.Prim.Int# -> GHC.Prim.Int#
+<<<<<<< HEAD
 [GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>, Unf=OtherCon []]
+=======
+[GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>, Unf=OtherCon []]
+>>>>>>> Get evaluated-ness right in the back end
 T4930.$wfoo
   = \ (ww :: GHC.Prim.Int#) ->
       case GHC.Prim.<# ww 5# of {
index 07b04c2..7fe5d92 100644 (file)
@@ -62,7 +62,11 @@ Rec {
 -- RHS size: {terms: 40, types: 5, coercions: 0, joins: 0/0}
 Roman.foo_$s$wgo [Occ=LoopBreaker]
   :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
+<<<<<<< HEAD
 [GblId, Arity=2, Caf=NoCafRefs, Str=<L,A><L,U>, Unf=OtherCon []]
+=======
+[GblId, Arity=2, Caf=NoCafRefs, Str=<S,U><S,U>, Unf=OtherCon []]
+>>>>>>> Get evaluated-ness right in the back end
 Roman.foo_$s$wgo
   = \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) ->
       case GHC.Prim.<=# sc1 0# of {