Normalize types when dropping absent arguments from workers

fixes #17852

4 files changed, 21 insertions, 7 deletions

diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
index fd78b56fe0..f74243282f 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -580,7 +580,7 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg
   = return (False, [arg],  nop_fn, nop_fn)
 
   | isAbsDmd dmd
-  , Just work_fn <- mk_absent_let dflags arg
+  , Just work_fn <- mk_absent_let dflags fam_envs arg
      -- Absent case.  We can't always handle absence for arbitrary
      -- unlifted types, so we need to choose just the cases we can
      -- (that's what mk_absent_let does)
@@ -1153,8 +1153,8 @@ So absentError is only used for lifted types.
 -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
 -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
 -- found (currently only happens for bindings of 'VecRep' representation).
-mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
-mk_absent_let dflags arg
+mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let dflags fam_envs arg
   -- The lifted case: Bind 'absentError'
   -- See Note [Absent errors]
   | not (isUnliftedType arg_ty)
@@ -1165,11 +1165,11 @@ mk_absent_let dflags arg
   = Just (Let (NonRec arg unlifted_rhs))
   -- The monomorphic unlifted cases: Bind to some literal, if possible
   -- See Note [Absent errors]
-  | Just tc <- tyConAppTyCon_maybe arg_ty
+  | Just tc <- tyConAppTyCon_maybe nty
   , Just lit <- absentLiteralOf tc
-  = Just (Let (NonRec arg (Lit lit)))
-  | arg_ty `eqType` voidPrimTy
-  = Just (Let (NonRec arg (Var voidPrimId)))
+  = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))
+  | nty `eqType` voidPrimTy
+  = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))
   | otherwise
   = WARN( True, text "No absent value for" <+> ppr arg_ty )
     Nothing -- Can happen for 'State#' and things of 'VecRep'
@@ -1179,6 +1179,8 @@ mk_absent_let dflags arg
               -- (for the sake of the "empty case scrutinee not known to
               -- diverge for sure lint" warning)
     arg_ty       = idType arg
+    (co, nty)    = topNormaliseType_maybe fam_envs arg_ty
+                   `orElse` (mkRepReflCo arg_ty, arg_ty)
     abs_rhs      = mkAbsentErrorApp arg_ty msg
     msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)
                           (ppr arg <+> ppr (idType arg))
diff --git a/testsuite/tests/stranal/should_compile/T17852.hs b/testsuite/tests/stranal/should_compile/T17852.hs
new file mode 100644
index 0000000000..d2a684d379
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T17852.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash, UnliftedNewtypes #-}
+module T17852 where
+import GHC.Exts (Int#)
+
+newtype T = T Int#
+
+f :: T -> Int# -> T -> T
+f a _ _ = a
+{-# NOINLINE f #-} -- to force worker/wrappering
diff --git a/testsuite/tests/stranal/should_compile/T17852.stdout b/testsuite/tests/stranal/should_compile/T17852.stdout
new file mode 100644
index 0000000000..d6c8b9b461
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T17852.stdout
@@ -0,0 +1 @@
+$wf :: T -> T
diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T
index c47a0cbd7b..012d3170e2 100644
--- a/testsuite/tests/stranal/should_compile/all.T
+++ b/testsuite/tests/stranal/should_compile/all.T
@@ -46,6 +46,8 @@ test('T13077a', normal, compile, [''])
 #   The idea is to check that both $wmutVar and $warray
 #   don't mention MutVar# and Array# anymore.
 test('T15627',  [ grep_errmsg(r'(wmutVar|warray).*Int#') ], compile, ['-dppr-cols=200 -ddump-simpl'])
+# Absent bindings of unlifted newtypes are WW’ed away.
+test('T17852',  [ grep_errmsg(r'\\$wf ::') ], compile, ['-ddump-worker-wrapper -dsuppress-idinfo'])
 
 test('T16029', normal, makefile_test, [])
 test('T10069',  [ grep_errmsg(r'(wc1).*Int#$') ], compile, ['-dppr-cols=200 -ddump-simpl'])