Arrows: collect evidence binders

Evidence binders were not collected by
GHC.HsToCore.Arrows.collectStmtBinders, hence bindings for dictionaries
were not taken into account while computing local variables in
statements. As a consequence we had a transformation similar to this:

    data Point a where Point :: RealFloat a => a -> Point a

    do
        p -< ...
        returnA -< ... (Point 0)

===> { Type-checking }

    do
        let $dRealFloat_xyz = GHC.Float.$fRealFloatFloat
        p -< ...
        returnA -< ... (Point $dRealFloat_xyz 0)

===> { Arrows HsToCore }

    first ...
    >>> arr (\(p, ()) -> case p of ... ->
            let $dRealFloat_xyz = GHC.Float.$fRealFloatFloat
            in case .. of () -> ())
    >>> \((),()) -> ... (Point $dRealFloat_xyz 0) -- dictionary not in scope

Now evidences are passed in the environment if necessary and we get:

===> { Arrows HsToCore }

    first ...
    >>> arr (\(p, ()) -> case p of ... ->
            let $dRealFloat_xyz = GHC.Float.$fRealFloatFloat
            in case .. of () -> $dRealFloat_xyz)
    >>> \(ds,()) ->
            let $dRealFloat_xyz = ds
            in ... (Point $dRealFloat_xyz 0) -- dictionary in scope

Note that collectStmtBinders has been copy-pasted from GHC.Hs.Utils.
This ought to be factorized but Note [Dictionary binders in ConPatOut]
claims that:

    Do *not* gather (a) dictionary and (b) dictionary bindings as
    binders of a ConPatOut pattern.  For most calls it doesn't matter,
    because it's pre-typechecker and there are no ConPatOuts.  But it
    does matter more in the desugarer; for example,
    GHC.HsToCore.Utils.mkSelectorBinds uses collectPatBinders.  In a
    lazy pattern, for example f ~(C x y) = ..., we want to generate
    bindings for x,y but not for dictionaries bound by C.  (The type
    checker ensures they would not be used.)

    Desugaring of arrow case expressions needs these bindings (see
    GHC.HsToCore.Arrows and arrowcase1), but SPJ (Jan 2007) says it's
    safer for it to use its own pat-binder-collector:

Accordingly to the last sentence, this patch doesn't make any attempt at
factorizing both codes.

Fix #18950

3 files changed, 100 insertions, 3 deletions

diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 52de5f6fb5..60e3346ee7 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -25,7 +25,6 @@ import GHC.Hs   hiding (collectPatBinders, collectPatsBinders,
                         collectLStmtsBinders, collectLStmtBinders,
                         collectStmtBinders )
 import GHC.Tc.Utils.Zonk
-import qualified GHC.Hs.Utils as HsUtils
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types (newtypes etc), and sometimes not
@@ -1280,5 +1279,15 @@ collectLStmtBinders :: LStmt GhcTc body -> [Id]
 collectLStmtBinders = collectStmtBinders . unLoc
 
 collectStmtBinders :: Stmt GhcTc body -> [Id]
-collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
-collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
+collectStmtBinders (BindStmt _ pat _)      = collectPatBinders pat
+collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)
+collectStmtBinders (BodyStmt {})           = []
+collectStmtBinders (LastStmt {})           = []
+collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders
+                                    $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
+collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
+ where
+  collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
+  collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
diff --git a/testsuite/tests/arrows/should_compile/T18950.hs b/testsuite/tests/arrows/should_compile/T18950.hs
new file mode 100644
index 0000000000..326022207d
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T18950.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE GADTs #-}
+-- NOTE: use ExistentialQuantification for non-GADT 'data Point' declaration
+-- {-# LANGUAGE ExistentialQuantification #-}
+{--
+Issue: Compiling `Example.hs` causes ghc to panic (happens in 8.8.x, 8.10.x, and 9.0.x)
+
+Reproduce:
+```bash
+nix-shell -I nixpkgs=https://nixos.org/channels/nixos-unstable/nixexprs.tar.xz -p haskell.compiler.ghc901
+ghc Example.hs
+```
+
+Results:
+
+ghc: panic! (the 'impossible' happened)
+  (GHC version 9.0.0.20200925:
+    GHC.StgToCmm.Env: variable not found
+  $dRealFloat_a1tn
+  local binds for:
+  pos
+  Point
+  Obj
+  $dArrow_s1xr
+  ds_s1xs
+  ds1_s1xt
+  ds2_s1ya
+  ds3_s1yb
+  ds4_s1yc
+  ds6_s1ye
+  sat_s1yf
+  sat_s1yg
+  sat_s1yh
+  sat_s1yi
+  sat_s1yj
+  sat_s1yk
+  sat_s1yl
+  sat_s1ym
+  sat_s1yn
+  Call stack:
+      CallStack (from HasCallStack):
+        callStackDoc, called at compiler/GHC/Utils/Outputable.hs:1230:37 in ghc:GHC.Utils.Outputable
+        pprPanic, called at compiler/GHC/StgToCmm/Env.hs:152:9 in ghc:GHC.StgToCmm.Env
+
+Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug
+--}
+{--
+```bash
+ghc -dcore-lint Example.hs
+```
+--}
+module Example (
+-- NOTE: no error if `step` not exported
+  step,
+) where
+
+import Control.Arrow
+
+-- NOTE: existentially qualified declaration of Point,
+--       mirrors definition of 'Point2' in package 'simple-affine-space'
+-- import Data.Point2
+
+-- NOTE: no error without 'RealFloat a` context; both examples fail
+--data Point a = RealFloat a => Point !a
+data Point a where Point :: RealFloat a => a -> Point a
+
+type Position = Point Float
+
+ptrPos :: Arrow a => a Obj Position
+ptrPos = arr pos
+
+data Obj = Obj { pos :: !Position }
+
+step :: Arrow a => a Obj Obj
+step = proc gi -> do
+  -- NOTE: no error without this arrow line; no error if not deconstructed.
+  (Point _) <- ptrPos -< gi
+  {--
+  -- NOTE: this code does work (in place of `(Point _) <- ptrPos -< gi` above)
+  pt <- ptrPos -< gi
+  let (Point _) = pt
+  --}
+  returnA -< Obj {
+               -- NOTE: no error without this 'pos' field
+               pos = (Point 0)
+             }
+
diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T
index b47cea0538..a399006aae 100644
--- a/testsuite/tests/arrows/should_compile/all.T
+++ b/testsuite/tests/arrows/should_compile/all.T
@@ -17,3 +17,4 @@ test('T5267', expect_broken(5267), compile, [''])
 test('T5022', normalise_fun(normalise_errmsg), compile, [''])
 test('T5333', normal, compile, [''])
 test('T17423', normal, compile, [''])
+test('T18950', normal, compile, [''])