diff options
| -rw-r--r-- | compiler/GHC/HsToCore/Arrows.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/arrows/should_compile/T18950.hs | 87 | ||||
| -rw-r--r-- | testsuite/tests/arrows/should_compile/all.T | 1 |
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, ['']) |