Commit c271e32e authored by Joachim Breitner's avatar Joachim Breitner

Add GHC.Prim.oneShot

to allow the programer to explictitly set the oneShot flag. This helps
with #7994 and will be used in left folds. Also see

This commit touches libraries/base/GHC/Event/Manager.hs (which used to
have a local definition of the name oneShot) to avoid a shadowing error.

Differential Revision:
parent c001bde7
......@@ -119,7 +119,7 @@ is right here.
wiredInIds :: [Id]
= [lazyId, dollarId]
= [lazyId, dollarId, oneShotId]
++ errorIds -- Defined in MkCore
++ ghcPrimIds
......@@ -1016,7 +1016,7 @@ another gun with which to shoot yourself in the foot.
lazyIdName, unsafeCoerceName, nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
magicDictName, coerceName, proxyName, dollarName :: Name
magicDictName, coerceName, proxyName, dollarName, oneShotName :: Name
unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
......@@ -1028,6 +1028,7 @@ magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDict
coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId
proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId
dollarName = mkWiredInIdName gHC_BASE (fsLit "$") dollarIdKey dollarId
oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId
......@@ -1119,6 +1120,17 @@ lazyId = pcMiscPrelId lazyIdName ty info
info = noCafIdInfo
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [alphaTyVar, betaTyVar] (mkFunTy fun_ty fun_ty)
fun_ty = mkFunTy alphaTy betaTy
[body, x] = mkTemplateLocals [fun_ty, alphaTy]
x' = setOneShotLambda x
rhs = mkLams [alphaTyVar, betaTyVar, body, x'] $ Var body `App` Var x
magicDictId :: Id -- See Note [magicDictId magic]
......@@ -1253,6 +1265,32 @@ See Trac #3259 for a real world example.
lazyId is defined in GHC.Base, so we don't *have* to inline it. If it
appears un-applied, we'll end up just calling it.
Note [The oneShot function]
In the context of making left-folds fuse somewhat okish (see ticket #7994
and Note [Left folds via right fold]) it was determined that it would be useful
if library authors could explicitly tell the compiler that a certain lambda is
called at most once. The oneShot function allows that.
Like most magic functions it has a compulsary unfolding, so there is no need
for a real definition somewhere. We have one in GHC.Magic for the convenience
of putting the documentation there.
It uses `setOneShotLambda` on the lambda's binder. That is the whole magic:
A typical call looks like
oneShot (\y. e)
after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get
(\f \x[oneshot]. f x) (\y. e)
--> \x[oneshot]. ((\y.e) x)
--> \x[oneshot] e[x/y]
which is what we want.
It is only effective if this bits survives as long as possible and makes it into
the interface in unfoldings (See Note [Preserve OneShotInfo]). Also see
Note [magicDictId magic]
......@@ -1666,10 +1666,11 @@ rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
runMainKey = mkPreludeMiscIdUnique 102
thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique
thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey :: Unique
thenIOIdKey = mkPreludeMiscIdUnique 103
lazyIdKey = mkPreludeMiscIdUnique 104
assertErrorIdKey = mkPreludeMiscIdUnique 105
oneShotKey = mkPreludeMiscIdUnique 106
breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
breakpointJumpIdKey, breakpointCondJumpIdKey,
......@@ -167,10 +167,10 @@ newDefaultBackend = error "no back end for this platform"
-- | Create a new event manager.
new :: Bool -> IO EventManager
new oneShot = newWith oneShot =<< newDefaultBackend
new isOneShot = newWith isOneShot =<< newDefaultBackend
newWith :: Bool -> Backend -> IO EventManager
newWith oneShot be = do
newWith isOneShot be = do
iofds <- fmap (listArray (0, callbackArraySize-1)) $
replicateM callbackArraySize (newMVar =<< 8)
ctrl <- newControl False
......@@ -187,7 +187,7 @@ newWith oneShot be = do
, emState = state
, emUniqueSource = us
, emControl = ctrl
, emOneShot = oneShot
, emOneShot = isOneShot
, emLock = lockVar
registerControlFd mgr (controlReadFd ctrl) evtRead
......@@ -17,7 +17,7 @@
module GHC.Magic ( inline, lazy ) where
module GHC.Magic ( inline, lazy, oneShot ) where
-- | The call @inline f@ arranges that 'f' is inlined, regardless of
-- its size. More precisely, the call @inline f@ rewrites to the
......@@ -64,3 +64,12 @@ lazy x = x
-- sees it as lazy. Then the worker/wrapper phase inlines it.
-- Result: happiness
-- | The 'oneShot' function can be used to give a hint to the compiler that its
-- argument will be called at most once, which may (or may not) enable certain
-- optimizations. It can be useful to improve the performance of code in continuation
-- passing style.
oneShot :: (a -> b) -> (a -> b)
oneShot f = f
-- Implementation note: This is wired in in MkId.lhs, so the code here is
-- mostly there to have a place for the documentation.
......@@ -1368,6 +1368,7 @@ mk/ghcconfig*
include $(TOP)/mk/
include $(TOP)/mk/
module OneShot1 where
import GHC.Base
-- This oneShot is a lie, and together with unsafePerformIO (in the form of
-- trace) in OneShot2, we can observe the difference.
-- Two modules to ensure that oneShot annotations surive interface files, both
-- in explicits unfoldings (foo) and in unannotated functions (baz)
foo :: Int -> Int -> Int
foo y = oneShot (\x -> x+y)
{-# INLINE foo #-}
bar :: Int -> Int -> Int
bar y = (\x -> y+x)
{-# INLINE bar #-}
baz :: Int -> Int -> Int
baz y = oneShot (\x -> x+y)
import OneShot1
import System.Environment
import Debug.Trace
p n = trace "p evaluated" (n > 0)
{-# NOINLINE p #-}
summap :: (Int -> Int) -> (Int -> Int)
summap f n = sum $ map f [1..10]
{-# NOINLINE summap #-}
foo' n = if p n then foo n else foo (n+1)
{-# NOINLINE foo' #-}
bar' n = if p n then bar n else bar (n+1)
{-# NOINLINE bar' #-}
baz' n = if p n then baz n else baz (n+1)
{-# NOINLINE baz' #-}
main = do
n <- length `fmap` getArgs
print $ summap (foo' n) n + summap (bar' n) n + summap (baz' n) n
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
p evaluated
[ only_ways(['optasm']),
extra_clean(['OneShot1.hi', 'OneShot1.o',
'OneShot2.hi', 'OneShot2.o']),
['OneShot2', '-v0'])
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