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

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 @@
-- | Arity and eta expansion
module CoreArity (
manifestArity, exprArity, typeArity, exprBotStrictness_maybe,
manifestArity, joinRhsArity, exprArity, typeArity,
exprEtaExpandArity, findRhsArity, CheapFun, etaExpand,
etaExpandToJoinPoint, etaExpandToJoinPointRule
etaExpandToJoinPoint, etaExpandToJoinPointRule,
exprBotStrictness_maybe
) where
#include "HsVersions.h"
......@@ -77,6 +78,14 @@ manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e
manifestArity (Cast e _) = manifestArity e
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
-- ^ 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:
"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.
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
must also be join points.
......
......@@ -46,7 +46,7 @@ import DynFlags
import CoreSyn
import PprCore () -- Instances
import OccurAnal ( occurAnalyseExpr )
import CoreSubst hiding( substTy )
import CoreOpt
import CoreArity ( manifestArity )
import CoreUtils
import Id
......
......@@ -29,8 +29,8 @@ import InstEnv
import Class
import Avail
import CoreSyn
import CoreFVs( exprsSomeFreeVarsList )
import CoreSubst
import CoreFVs ( exprsSomeFreeVarsList )
import CoreOpt ( simpleOptPgm, simpleOptExpr )
import PprCore
import DsMonad
import DsExpr
......
......@@ -28,7 +28,7 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import Literal ( Literal(MachStr) )
import CoreSubst
import CoreOpt ( simpleOptExpr )
import OccurAnal ( occurAnalyseExpr )
import MkCore
import CoreUtils
......
......@@ -277,6 +277,7 @@ Library
CoreLint
CorePrep
CoreSubst
CoreOpt
CoreSyn
TrieMap
CoreTidy
......
......@@ -452,6 +452,7 @@ compiler_stage2_dll0_MODULES = \
CoreArity \
CoreFVs \
CoreSubst \
CoreOpt \
CoreSyn \
CoreTidy \
CoreUnfold \
......
......@@ -41,7 +41,8 @@ import DataCon
import CoreUtils
import MkCore
import CoreFVs
import CoreSubst
import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
-- These names are also exported by Type
-- Core "extras"
import Rules
......
......@@ -31,7 +31,7 @@ import CoreSyn
import MkCore
import Id
import Literal
import CoreSubst ( exprIsLiteral_maybe )
import CoreOpt ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
......
......@@ -35,7 +35,8 @@ import PprCore ( pprCoreExpr )
import CoreUnfold
import CoreUtils
import CoreArity
import CoreSubst ( pushCoTyArg, pushCoValArg )
import CoreOpt ( pushCoTyArg, pushCoValArg
, joinPointBinding_maybe, joinPointBindings_maybe )
--import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326
import Rules ( mkRuleInfo, lookupRule, getRules )
--import TysPrim ( intPrimTy ) -- temporalily commented out. See #8326
......@@ -1462,7 +1463,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
-> simplExprF (rhs_se `setFloats` env) rhs
(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)
[bndr'] cont
; (env1, bndr1) <- simplNonRecJoinBndr env
......@@ -1498,7 +1499,7 @@ simplRecE :: SimplEnv
-- simplRecE is used for
-- * non-top-level recursive lets in expressions
simplRecE env pairs body cont
| Just pairs' <- matchOrConvertToJoinPoints pairs
| Just pairs' <- joinPointBindings_maybe pairs
= do { let bndrs' = map fst pairs'
cont_dup_res_ty = resultTypeOfDupableCont (getMode env)
bndrs' cont
......@@ -1525,29 +1526,6 @@ simplRecE env pairs body cont
; env2 <- simplRecBind env1 NotTopLevel (Just cont) pairs
; 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 (
import CoreSyn -- All of it
import Module ( Module, ModuleSet, elemModuleSet )
import CoreSubst
import CoreOpt ( exprIsLambda_maybe )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars
, rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )
import CoreUtils ( exprType, eqExpr, mkTick, mkTicks,
......
......@@ -21,6 +21,7 @@ import VarSet
import VarEnv
import CoreSyn
import Rules
import CoreOpt ( collectBindersPushingCo )
import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast )
import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars, exprsFreeIdsList )
import CoreArity ( etaExpandToJoinPointRule )
......@@ -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
-- See Note [Inline specialisations]
(rhs_bndrs, rhs_body) = CoreSubst.collectBindersPushingCo rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
(rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs
(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'])
test('T13338', only_ways(['optasm']), compile, ['-dcore-lint'])
test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367'])
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