Skip to content
Permalink
Browse files

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
https://ghc.haskell.org/trac/ghc/wiki/OneShot

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: https://phabricator.haskell.org/D392
  • Loading branch information
nomeata committed Jan 26, 2014
1 parent c001bde commit c271e32eac65ee95ba1aacc72ed1b24b58ef17ad
@@ -119,7 +119,7 @@ is right here.
\begin{code}
wiredInIds :: [Id]
wiredInIds
= [lazyId, dollarId]
= [lazyId, dollarId, oneShotId]
++ errorIds -- Defined in MkCore
++ ghcPrimIds
@@ -1016,7 +1016,7 @@ another gun with which to shoot yourself in the foot.
\begin{code}
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
\end{code}

\begin{code}
@@ -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
where
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
https://ghc.haskell.org/trac/ghc/wiki/OneShot.


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 =<< IT.new 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*_inplace_bin_ghc-stage2.exe.mk
/tests/safeHaskell/safeLanguage/SafeLang13
/tests/safeHaskell/safeLanguage/SafeLang15
/tests/safeHaskell/unsafeLibs/BadImport02
/tests/simplCore/prog003/simplCore.oneShot
/tests/simplCore/should_compile/T3055.simpl
/tests/simplCore/should_compile/T4138.simpl
/tests/simplCore/should_compile/T7702plugin/pkg.T7702/
@@ -0,0 +1,3 @@
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
@@ -0,0 +1,21 @@
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)

@@ -0,0 +1,24 @@
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

@@ -0,0 +1,21 @@
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
@@ -0,0 +1 @@
195
@@ -0,0 +1,7 @@
test('simplCore.oneShot',
[ only_ways(['optasm']),
extra_clean(['OneShot1.hi', 'OneShot1.o',
'OneShot2.hi', 'OneShot2.o']),
],
multimod_compile_and_run,
['OneShot2', '-v0'])

0 comments on commit c271e32

Please sign in to comment.
You can’t perform that action at this time.