diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-06-21 12:28:23 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-23 03:00:23 -0400 |
| commit | d8e5b274dd258f85867e874a35fa719922a758f0 (patch) | |
| tree | bd738328282dc7af4a597e68b4e6d7c6904448d8 | |
| parent | aa1d0eb3629bd9d8fda3605c0b7b4dd52ee3d583 (diff) | |
| download | haskell-d8e5b274dd258f85867e874a35fa719922a758f0.tar.gz | |
ghci: Correct free variable calculation in StgToByteCode
Fixes #20019
| -rw-r--r-- | compiler/GHC/Stg/Lift/Analysis.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/StgToByteCode.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/T20019.script | 1 | ||||
| -rwxr-xr-x | testsuite/tests/ghci/scripts/all.T | 1 |
5 files changed, 9 insertions, 8 deletions
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index d4e59a8d6e..5999104c9c 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -115,9 +115,6 @@ type instance XRhsClosure 'LiftLams = DIdSet type instance XLet 'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton -freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet -freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] -freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs -- | Captures details of the syntax tree relevant to the cost model, such as -- closures, multi-shot lambdas and case expressions. diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index a1a1084166..b0c32470f5 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -50,7 +50,7 @@ module GHC.Stg.Syntax ( StgOp(..), -- utils - stgRhsArity, + stgRhsArity, freeVarsOfRhs, isDllConApp, stgArgType, stripStgTicksTop, stripStgTicksTopE, @@ -504,6 +504,10 @@ stgRhsArity (StgRhsClosure _ _ _ bndrs _) -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon _ _ _ _ _) = 0 +freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet +freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] +freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs + {- ************************************************************************ * * diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index 7dad6a87da..37a6539fe6 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -567,10 +567,8 @@ fvsToEnv :: BCEnv -> CgStgRhs -> [Id] -- The code that constructs the thunk, and the code that executes -- it, have to agree about this layout -fvsToEnv p (StgRhsClosure fvs _ _ _ _) = - [v | v <- dVarSetElems fvs, - v `Map.member` p] -fvsToEnv _ _ = [] +fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs, + v `Map.member` p] -- ----------------------------------------------------------------------------- -- schemeE diff --git a/testsuite/tests/ghci/scripts/T20019.script b/testsuite/tests/ghci/scripts/T20019.script new file mode 100644 index 0000000000..949784e991 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T20019.script @@ -0,0 +1 @@ +x = () : x diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index e4fae93e6b..a265881501 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -339,3 +339,4 @@ test('T19650', ], ghci_script, ['T19650.script']) +test('T20019', normal, ghci_script, ['T20019.script']) |