Commit a7dbafe9 authored by Simon Peyton Jones's avatar Simon Peyton Jones

No join-point from an INLINE function with wrong arity

The main payload of this patch is NOT to make a join-point
from a function with an INLINE pragma and the wrong arity;
see Note [Join points and INLINE pragmas] in CoreOpt.
This is what caused Trac #13413.

But we must do the exact same thing in simpleOptExpr,
which drove me to the following refactoring:

* Move simpleOptExpr and simpleOptPgm from CoreSubst to a new
  module CoreOpt along with a few others (exprIsConApp_maybe,
  pushCoArg, etc)

  This eliminates a module loop altogether (delete
  CoreArity.hs-boot), and stops CoreSubst getting too huge.

* Rename Simplify.matchOrConvertToJoinPoint
     to joinPointBinding_maybe
  Move it to the new CoreOpt
  Use it in simpleOptExpr as well as in Simplify

* Define CoreArity.joinRhsArity and use it
parent 567bc6bd
...@@ -10,9 +10,10 @@ ...@@ -10,9 +10,10 @@
-- | Arity and eta expansion -- | Arity and eta expansion
module CoreArity ( module CoreArity (
manifestArity, exprArity, typeArity, exprBotStrictness_maybe, manifestArity, joinRhsArity, exprArity, typeArity,
exprEtaExpandArity, findRhsArity, CheapFun, etaExpand, exprEtaExpandArity, findRhsArity, CheapFun, etaExpand,
etaExpandToJoinPoint, etaExpandToJoinPointRule etaExpandToJoinPoint, etaExpandToJoinPointRule,
exprBotStrictness_maybe
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -77,6 +78,14 @@ manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e ...@@ -77,6 +78,14 @@ manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e
manifestArity (Cast e _) = manifestArity e manifestArity (Cast e _) = manifestArity e
manifestArity _ = 0 manifestArity _ = 0
joinRhsArity :: CoreExpr -> JoinArity
-- Join points are supposed to have manifestly-visible
-- lambdas at the top: no ticks, no casts, nothing
-- Moreover, type lambdas count in JoinArity
joinRhsArity (Lam _ e) = 1 + joinRhsArity e
joinRhsArity _ = 0
--------------- ---------------
exprArity :: CoreExpr -> Arity exprArity :: CoreExpr -> Arity
-- ^ An approximate, fast, version of 'exprEtaExpandArity' -- ^ An approximate, fast, version of 'exprEtaExpandArity'
......
module CoreArity where
import BasicTypes
import CoreSyn
etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)
This diff is collapsed.
This diff is collapsed.
...@@ -589,6 +589,11 @@ Join points must follow these invariants: ...@@ -589,6 +589,11 @@ Join points must follow these invariants:
"join arity" (to distinguish from regular arity, which only counts values). "join arity" (to distinguish from regular arity, which only counts values).
2. For join arity n, the right-hand side must begin with at least n lambdas. 2. For join arity n, the right-hand side must begin with at least n lambdas.
No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity.
2a. Moreover, this same constraint applies to any unfolding of the binder.
Reason: if we want to push a continuation into the RHS we must push it
into the unfolding as well.
3. If the binding is recursive, then all other bindings in the recursive group 3. If the binding is recursive, then all other bindings in the recursive group
must also be join points. must also be join points.
......
...@@ -46,7 +46,7 @@ import DynFlags ...@@ -46,7 +46,7 @@ import DynFlags
import CoreSyn import CoreSyn
import PprCore () -- Instances import PprCore () -- Instances
import OccurAnal ( occurAnalyseExpr ) import OccurAnal ( occurAnalyseExpr )
import CoreSubst hiding( substTy ) import CoreOpt
import CoreArity ( manifestArity ) import CoreArity ( manifestArity )
import CoreUtils import CoreUtils
import Id import Id
......
...@@ -29,8 +29,8 @@ import InstEnv ...@@ -29,8 +29,8 @@ import InstEnv
import Class import Class
import Avail import Avail
import CoreSyn import CoreSyn
import CoreFVs( exprsSomeFreeVarsList ) import CoreFVs ( exprsSomeFreeVarsList )
import CoreSubst import CoreOpt ( simpleOptPgm, simpleOptExpr )
import PprCore import PprCore
import DsMonad import DsMonad
import DsExpr import DsExpr
......
...@@ -28,7 +28,7 @@ import DsUtils ...@@ -28,7 +28,7 @@ import DsUtils
import HsSyn -- lots of things import HsSyn -- lots of things
import CoreSyn -- lots of things import CoreSyn -- lots of things
import Literal ( Literal(MachStr) ) import Literal ( Literal(MachStr) )
import CoreSubst import CoreOpt ( simpleOptExpr )
import OccurAnal ( occurAnalyseExpr ) import OccurAnal ( occurAnalyseExpr )
import MkCore import MkCore
import CoreUtils import CoreUtils
......
...@@ -277,6 +277,7 @@ Library ...@@ -277,6 +277,7 @@ Library
CoreLint CoreLint
CorePrep CorePrep
CoreSubst CoreSubst
CoreOpt
CoreSyn CoreSyn
TrieMap TrieMap
CoreTidy CoreTidy
......
...@@ -452,6 +452,7 @@ compiler_stage2_dll0_MODULES = \ ...@@ -452,6 +452,7 @@ compiler_stage2_dll0_MODULES = \
CoreArity \ CoreArity \
CoreFVs \ CoreFVs \
CoreSubst \ CoreSubst \
CoreOpt \
CoreSyn \ CoreSyn \
CoreTidy \ CoreTidy \
CoreUnfold \ CoreUnfold \
......
...@@ -41,7 +41,8 @@ import DataCon ...@@ -41,7 +41,8 @@ import DataCon
import CoreUtils import CoreUtils
import MkCore import MkCore
import CoreFVs import CoreFVs
import CoreSubst import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
-- These names are also exported by Type
-- Core "extras" -- Core "extras"
import Rules import Rules
......
...@@ -31,7 +31,7 @@ import CoreSyn ...@@ -31,7 +31,7 @@ import CoreSyn
import MkCore import MkCore
import Id import Id
import Literal import Literal
import CoreSubst ( exprIsLiteral_maybe ) import CoreOpt ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey ) import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn import TysWiredIn
import TysPrim import TysPrim
......
...@@ -35,7 +35,8 @@ import PprCore ( pprCoreExpr ) ...@@ -35,7 +35,8 @@ import PprCore ( pprCoreExpr )
import CoreUnfold import CoreUnfold
import CoreUtils import CoreUtils
import CoreArity import CoreArity
import CoreSubst ( pushCoTyArg, pushCoValArg ) import CoreOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
--import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326 --import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326
import Rules ( mkRuleInfo, lookupRule, getRules ) import Rules ( mkRuleInfo, lookupRule, getRules )
--import TysPrim ( intPrimTy ) -- temporalily commented out. See #8326 --import TysPrim ( intPrimTy ) -- temporalily commented out. See #8326
...@@ -1462,7 +1463,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont ...@@ -1462,7 +1463,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
-> simplExprF (rhs_se `setFloats` env) rhs -> simplExprF (rhs_se `setFloats` env) rhs
(StrictBind bndr bndrs body env cont) (StrictBind bndr bndrs body env cont)
| Just (bndr', rhs') <- matchOrConvertToJoinPoint bndr rhs | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
-> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env) -> do { let cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
[bndr'] cont [bndr'] cont
; (env1, bndr1) <- simplNonRecJoinBndr env ; (env1, bndr1) <- simplNonRecJoinBndr env
...@@ -1498,7 +1499,7 @@ simplRecE :: SimplEnv ...@@ -1498,7 +1499,7 @@ simplRecE :: SimplEnv
-- simplRecE is used for -- simplRecE is used for
-- * non-top-level recursive lets in expressions -- * non-top-level recursive lets in expressions
simplRecE env pairs body cont simplRecE env pairs body cont
| Just pairs' <- matchOrConvertToJoinPoints pairs | Just pairs' <- joinPointBindings_maybe pairs
= do { let bndrs' = map fst pairs' = do { let bndrs' = map fst pairs'
cont_dup_res_ty = resultTypeOfDupableCont (getMode env) cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
bndrs' cont bndrs' cont
...@@ -1525,29 +1526,6 @@ simplRecE env pairs body cont ...@@ -1525,29 +1526,6 @@ simplRecE env pairs body cont
; env2 <- simplRecBind env1 NotTopLevel (Just cont) pairs ; env2 <- simplRecBind env1 NotTopLevel (Just cont) pairs
; simplExprF env2 body cont } ; simplExprF env2 body cont }
-- | Returns Just (bndr,rhs) if the binding is a join point:
-- If it's a JoinId, just return it
-- If it's not yet a JoinId but is always tail-called,
-- make it into a JoinId and return it.
matchOrConvertToJoinPoint :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
matchOrConvertToJoinPoint bndr rhs
| not (isId bndr)
= Nothing
| isJoinId bndr
= -- No point in keeping tailCallInfo around; very fragile
Just (bndr, rhs)
| AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
, (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
= Just (bndr `asJoinId` join_arity, mkLams bndrs body)
| otherwise
= Nothing
matchOrConvertToJoinPoints :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
matchOrConvertToJoinPoints bndrs
= mapM (uncurry matchOrConvertToJoinPoint) bndrs
{- {-
************************************************************************ ************************************************************************
......
...@@ -31,6 +31,7 @@ module Rules ( ...@@ -31,6 +31,7 @@ module Rules (
import CoreSyn -- All of it import CoreSyn -- All of it
import Module ( Module, ModuleSet, elemModuleSet ) import Module ( Module, ModuleSet, elemModuleSet )
import CoreSubst import CoreSubst
import CoreOpt ( exprIsLambda_maybe )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, import CoreUtils ( exprType, eqExpr, mkTick, mkTicks,
......
...@@ -21,6 +21,7 @@ import VarSet ...@@ -21,6 +21,7 @@ import VarSet
import VarEnv import VarEnv
import CoreSyn import CoreSyn
import Rules import Rules
import CoreOpt ( collectBindersPushingCo )
import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast )
import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList )
import CoreArity ( etaExpandToJoinPointRule ) import CoreArity ( etaExpandToJoinPointRule )
...@@ -1194,7 +1195,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs ...@@ -1194,7 +1195,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
-- Figure out whether the function has an INLINE pragma -- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations] -- See Note [Inline specialisations]
(rhs_bndrs, rhs_body) = CoreSubst.collectBindersPushingCo rhs (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding] -- See Note [Account for casts in binding]
(rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs (rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs
(rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1 (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1
......
{-# LANGUAGE MagicHash #-}
module T13413 where
import GHC.Exts
fillBlock2 :: (Int# -> Int# -> IO ())
-> Int# -> Int# -> IO ()
fillBlock2 write x0 y0
= fillBlock y0 x0
where
{-# INLINE fillBlock #-}
fillBlock y ix
| 1# <- y >=# y0
= return ()
| otherwise
= do write ix x0
fillBlock (y +# 1#) ix
...@@ -251,3 +251,4 @@ test('T13340', normal, run_command, ['$MAKE -s --no-print-directory T13340']) ...@@ -251,3 +251,4 @@ test('T13340', normal, run_command, ['$MAKE -s --no-print-directory T13340'])
test('T13338', only_ways(['optasm']), compile, ['-dcore-lint']) test('T13338', only_ways(['optasm']), compile, ['-dcore-lint'])
test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367']) test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367'])
test('T13417', normal, compile, ['-O']) test('T13417', normal, compile, ['-O'])
test('T13413', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment