Magnus pushed to branch wip/mangoiv/9.12.5-rc4 at Glasgow Haskell Compiler / GHC Commits: 3508dbe9 by mangoiv at 2026-09-17T16:49:35+02:00 Fix a scoping error in Specialise This small patch fixes #26329, which triggered a scoping error. Test is in T21391, with -fpolymorphic-specialisation enabled mangoiv(backported): Another test added for #27766 (T27766) (cherry picked from commit b62491405ae851ae514afe18d51f0fe7fbefebf3) - - - - - 4 changed files: - + Repro019_minimal.hs - compiler/GHC/Core/Opt/Specialise.hs - + testsuite/tests/simplCore/should_compile/T27766.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== Repro019_minimal.hs ===================================== @@ -0,0 +1,37 @@ +module Repro019_minimal where + +unpack :: Int -> [Int] +unpack b = unpackGo b +{-# NOINLINE unpack #-} + +unpackGo :: Int -> [Int] +unpackGo len = go len + where go i = if i == 0 then [] else i : go (i - 1) +{-# INLINE unpackGo #-} + +{-# RULES "unpack/late" [0] forall b. unpack b = unpackGo b #-} + +conv :: [Int] -> Int +conv input = case unpack (length input) of + [] -> undefined + _ -> 0 + +opaque :: Int -> Bool +opaque x = x > 0 +{-# NOINLINE opaque #-} + +getUnchecked :: Int -> IO (Int, Maybe Int) +getUnchecked x = get x >>= maybe undefined pure + +get :: Int -> IO (Maybe (Int, Maybe Int)) +get x = do + a <- ((if opaque x then pure Nothing else pure (Just 0)) >>= \r -> case r of + Just _ -> pure (Just (1 :: Int)) + _ -> pure Nothing) + b <- (if opaque x then pure Nothing else pure (Just 0)) + pure ((,) <$> a <*> Just (fmap (conv . unpack) b)) +{-# INLINE get #-} + +top :: IO () +top = () <$ getUnchecked (undefined :: Int) + ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1211,14 +1211,21 @@ specExpr env (Tick tickish body) ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1252,16 +1259,17 @@ specExpr env (Let bind body) -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f) , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 - , (fun, args) <- collectArgs expr' - = fireRewriteRules env fun (args++rest_args) + , (fun', args') <- collectArgs expr' + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1736,6 +1744,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs do { -- Run the specialiser on the specialised RHS -- The "1" suffix is before we maybe add the void arg ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body + +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} -- Add the { d1' = dx1; d2' = dx2 } usage stuff -- to the rhs_uds; see Note [Specialising Calls] ; let rhs_uds_w_dx = dx_binds `consDictBinds` rhs_uds ===================================== testsuite/tests/simplCore/should_compile/T27766.hs ===================================== @@ -0,0 +1,37 @@ +module Repro019_minimal where + +unpack :: Int -> [Int] +unpack b = unpackGo b +{-# NOINLINE unpack #-} + +unpackGo :: Int -> [Int] +unpackGo len = go len + where go i = if i == 0 then [] else i : go (i - 1) +{-# INLINE unpackGo #-} + +{-# RULES "unpack/late" [0] forall b. unpack b = unpackGo b #-} + +conv :: [Int] -> Int +conv input = case unpack (length input) of + [] -> undefined + _ -> 0 + +opaque :: Int -> Bool +opaque x = x > 0 +{-# NOINLINE opaque #-} + +getUnchecked :: Int -> IO (Int, Maybe Int) +getUnchecked x = get x >>= maybe undefined pure + +get :: Int -> IO (Maybe (Int, Maybe Int)) +get x = do + a <- ((if opaque x then pure Nothing else pure (Just 0)) >>= \r -> case r of + Just _ -> pure (Just (1 :: Int)) + _ -> pure Nothing) + b <- (if opaque x then pure Nothing else pure (Just 0)) + pure ((,) <$> a <*> Just (fmap (conv . unpack) b)) +{-# INLINE get #-} + +top :: IO () +top = () <$ getUnchecked (undefined :: Int) + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -542,3 +542,4 @@ test('T26681', normal, compile, ['-O']) test('T26903', [grep_errmsg(r'reverse')], compile, ['-O -dno-typeable-binds -ddump-simpl -dsuppress-uniques -dsuppress-all']) test('T26682', normal, multimod_compile, ['T26682', '-O -v0']) test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) +test('T27766', normal, compile, ['-O2 -flate-specialise']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3508dbe9be2710b32ae42c9c3c8b54f7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3508dbe9be2710b32ae42c9c3c8b54f7... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help