summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-11-16 23:21:53 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-01-22 14:58:53 -0500
commit01ea56a22d7cf55f5285b130b357d3112c92de5b (patch)
treeb64719930d2c4aa35ee67d9f0913224e81d73a26
parentb4b2be610654d0b6a9bcdaa956261655eadd6b4d (diff)
downloadhaskell-01ea56a22d7cf55f5285b130b357d3112c92de5b.tar.gz
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
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs15
-rw-r--r--testsuite/tests/arrows/should_compile/T18950.hs87
-rw-r--r--testsuite/tests/arrows/should_compile/all.T1
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, [''])