[commit: ghc] wip/oneShot: Add GHC.Prim.oneShot (d27eb19)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/oneShot
Link       : http://ghc.haskell.org/trac/ghc/changeset/d27eb195223dbdd9de3248be903b6b2dc44422b1/ghc

>---------------------------------------------------------------

commit d27eb195223dbdd9de3248be903b6b2dc44422b1
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sun Jan 26 11:36:23 2014 +0000

    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


>---------------------------------------------------------------

d27eb195223dbdd9de3248be903b6b2dc44422b1
 compiler/basicTypes/MkId.lhs        | 31 +++++++++++++++++++++++++++++--
 compiler/prelude/PrelNames.lhs      |  3 ++-
 libraries/base/GHC/Event/Manager.hs |  6 +++---
 3 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index bf1c199..34045db 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -135,7 +135,8 @@ ghcPrimIds
     seqId,
     magicDictId,
     coerceId,
-    proxyHashId
+    proxyHashId,
+    oneShotId
     ]
 \end{code}
 
@@ -1016,7 +1017,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 +1029,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_PRIM (fsLit "oneShot")       oneShotKey         oneShotId
 \end{code}
 
 \begin{code}
@@ -1119,6 +1121,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 +1266,20 @@ 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. It uses `setOneShotLambda` on the lambdas
+binder, that is the whole magic. 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 4e98739..73d1cf3 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -1686,10 +1686,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,
diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index 2041379..29edd97 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -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