[Git][ghc/ghc][wip/dougwilson/noupdate] 2 commits: WIP add noupdate magic function
Douglas Wilson (@duog)
gitlab at gitlab.haskell.org
Tue Oct 4 20:22:57 UTC 2022
Douglas Wilson pushed to branch wip/dougwilson/noupdate at Glasgow Haskell Compiler / GHC
Commits:
a3218584 by Douglas Wilson at 2022-10-04T20:45:13+01:00
WIP add noupdate magic function
- - - - -
4bd0a3cd by Douglas Wilson at 2022-10-04T20:45:13+01:00
wip
- - - - -
9 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Driver/Config/Stg/Pipeline.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/ghc-prim/GHC/Magic.hs
- + noupdate.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -2322,12 +2322,13 @@ rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
runMainKey = mkPreludeMiscIdUnique 102
-thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique
+thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, noupdateKey :: Unique
thenIOIdKey = mkPreludeMiscIdUnique 103
lazyIdKey = mkPreludeMiscIdUnique 104
assertErrorIdKey = mkPreludeMiscIdUnique 105
oneShotKey = mkPreludeMiscIdUnique 106
runRWKey = mkPreludeMiscIdUnique 107
+noupdateKey = mkPreludeMiscIdUnique 119
traceKey :: Unique
traceKey = mkPreludeMiscIdUnique 108
=====================================
compiler/GHC/Driver/Config/Stg/Pipeline.hs
=====================================
@@ -36,6 +36,7 @@ getStgToDo for_bytecode dflags =
-- See Note [StgCse after unarisation] in GHC.Stg.CSE
, optional Opt_StgCSE StgCSE
, optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags
+ , mandatory StgNoupdate
, runWhen for_bytecode StgBcPrep
, optional Opt_StgStats StgStats
] where
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -543,7 +543,7 @@ mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg
_ -> mkWildValBinder Many ty1
mkCoreAppDs _ (Var f `App` Type _r) arg
- | f `hasKey` noinlineIdKey -- See Note [noinlineId magic] in GHC.Types.Id.Make
+ | f `hasKey` noinlineIdKey || f `hasKey` noupdateKey -- See Note [noinlineId magic] in GHC.Types.Id.Make
, (fun, args) <- collectArgs arg
, not (null args)
= (Var f `App` Type (exprType fun) `App` fun)
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -7,7 +7,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, ViewPatterns, LambdaCase, NamedFieldPuns #-}
module GHC.Stg.Pipeline
( StgPipelineOpts (..)
@@ -20,7 +20,6 @@ import GHC.Prelude
import GHC.Driver.Flags
import GHC.Stg.Syntax
-
import GHC.Stg.Lint ( lintStgTopBindings )
import GHC.Stg.Stats ( showStgStats )
import GHC.Stg.FVs ( depSortWithAnnotStgPgm )
@@ -32,6 +31,7 @@ import GHC.Unit.Module ( Module )
import GHC.Utils.Error
import GHC.Types.Var
+import GHC.Types.Id.Make
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Logger
@@ -131,6 +131,11 @@ stg2stg logger extra_vars opts this_mod binds
liftIO (stg_linter True "Unarise" binds')
return binds'
+ StgNoupdate -> do
+ let binds' = do_noupdate <$> binds
+ return binds'
+
+
ppr_opts = stgPipeline_pprOpts opts
dump_when flag header binds
= putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds)
@@ -159,4 +164,34 @@ data StgToDo
-- ^ Mandatory when compiling to bytecode
| StgDoNothing
-- ^ Useful for building up 'getStgToDo'
+ | StgNoupdate
deriving (Show, Read, Eq, Ord)
+
+
+do_noupdate :: StgTopBinding -> StgTopBinding
+do_noupdate (StgTopLifted x) = StgTopLifted (do_noupdate_bind x)
+do_noupdate x = x
+
+
+do_noupdate_bind :: StgBinding -> StgBinding
+do_noupdate_bind (StgNonRec i rhs) = StgNonRec i (do_noupdate_rhs rhs)
+do_noupdate_bind (StgRec bs) = StgRec [ (i, do_noupdate_rhs rhs) | (i,rhs) <- bs]
+
+do_noupdate_rhs :: StgRhs -> StgRhs
+do_noupdate_rhs (StgRhsClosure x y Updatable [] body) = case do_noupdate_expr body of
+ (True, r) -> StgRhsClosure x y ReEntrant [] r
+ (_, r) -> (StgRhsClosure x y Updatable [] r)
+do_noupdate_rhs (StgRhsClosure x y upd_flag args body) = StgRhsClosure x y upd_flag args (snd $ do_noupdate_expr body)
+do_noupdate_rhs x = x
+
+do_noupdate_expr :: StgExpr -> (Bool, StgExpr)
+do_noupdate_expr = \case
+ StgApp (( == noupdateId) -> True) (StgVarArg i : rest) -> (True, StgApp i rest)
+ StgLet x binds body -> StgLet x (do_noupdate_bind binds) <$> (do_noupdate_expr body)
+ StgTick ticks x -> StgTick ticks <$> do_noupdate_expr x
+ StgCase scrut y z alts -> (False, StgCase (snd $ do_noupdate_expr scrut) y z (do_noupdate_alt <$> alts))
+ StgLetNoEscape x binds body -> StgLetNoEscape x (do_noupdate_bind binds) <$> (do_noupdate_expr body)
+ x -> (False, x)
+
+do_noupdate_alt :: StgAlt -> StgAlt
+do_noupdate_alt x at GenStgAlt{alt_rhs} = x{ alt_rhs = snd $ do_noupdate_expr alt_rhs }
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -20,6 +20,8 @@ import GHC.Core.Opt.Arity( isOneShotBndr )
import GHC.Runtime.Heap.Layout
import GHC.Unit.Module
+import GHC.Types.Id.Make
+
import GHC.Stg.Syntax
import GHC.Platform
@@ -59,6 +61,7 @@ import GHC.Types.Tickish ( tickishIsCode )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Trace
import GHC.Data.FastString
import GHC.Data.List.SetOps
@@ -230,6 +233,9 @@ cgRhs id (StgRhsClosure fvs cc upd_flag args body)
-- Non-constructor right hand sides
------------------------------------------------------------------------
+strip_ticks :: CgStgExpr -> CgStgExpr
+strip_ticks = stripStgTicksTopE (not . tickishIsCode)
+
mkRhsClosure :: Profile
-> Bool -- Omit AP Thunks to improve profiling
-> Bool -- Lint tag inference checks
@@ -281,14 +287,13 @@ mkRhsClosure profile _ _check_tags bndr _cc
upd_flag -- Updatable thunk
[] -- A thunk
expr
- | let strip = stripStgTicksTopE (not . tickishIsCode)
- , StgCase (StgApp scrutinee [{-no args-}])
+ | StgCase (StgApp scrutinee [{-no args-}])
_ -- ignore bndr
(AlgAlt _)
[GenStgAlt{ alt_con = DataAlt _
, alt_bndrs = params
- , alt_rhs = sel_expr}] <- strip expr
- , StgApp selectee [{-no args-}] <- strip sel_expr
+ , alt_rhs = sel_expr}] <- strip_ticks expr
+ , StgApp selectee [{-no args-}] <- strip_ticks sel_expr
, the_fv == scrutinee -- Scrutinee is the only free variable
, let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -1,7 +1,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, ViewPatterns #-}
-----------------------------------------------------------------------------
--
@@ -17,6 +17,7 @@ import GHC.Prelude hiding ((<*>))
import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )
+import GHC.Types.Id.Make
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Env
@@ -74,6 +75,9 @@ cgExpr (StgApp fun args) = cgIdApp fun args
cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
cgIdApp a []
+cgExpr (StgApp ((== noupdateId) -> True) [StgVarArg a]) =
+ cgIdApp a []
+
-- dataToTag# :: a -> Int#
-- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold
-- TODO: There are some more optimization ideas for this code path
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -33,7 +33,7 @@ module GHC.Types.Id.Make (
voidPrimId, voidArgId,
nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, coerceId,
- proxyHashId, noinlineId, noinlineIdName, nospecId, nospecIdName,
+ proxyHashId, noinlineId, noupdateId, noinlineIdName, nospecId, nospecIdName,
coerceName, leftSectionName, rightSectionName,
) where
@@ -160,7 +160,7 @@ wiredInIds
++ errorIds -- Defined in GHC.Core.Make
magicIds :: [Id] -- See Note [magicIds]
-magicIds = [lazyId, oneShotId, noinlineId, nospecId]
+magicIds = [lazyId, oneShotId, noinlineId, nospecId, noupdateId]
ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)]
ghcPrimIds
@@ -1402,9 +1402,10 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti
rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId
-- Names listed in magicIds; see Note [magicIds]
-lazyIdName, oneShotName, noinlineIdName, nospecIdName :: Name
+lazyIdName, oneShotName, noinlineIdName, nospecIdName, noupdateName :: Name
lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId
oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId
+noupdateName = mkWiredInIdName gHC_MAGIC (fsLit "noupdate") noupdateKey noupdateId
noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId
nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId
@@ -1480,6 +1481,12 @@ nospecId = pcMiscPrelId nospecIdName ty info
info = noCafIdInfo
ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)
+noupdateId :: Id
+noupdateId = pcMiscPrelId noupdateName ty info
+ where
+ info = noCafIdInfo
+ ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)
+
oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info
where
=====================================
libraries/ghc-prim/GHC/Magic.hs
=====================================
@@ -23,7 +23,7 @@
--
-----------------------------------------------------------------------------
-module GHC.Magic ( inline, noinline, lazy, oneShot, runRW# ) where
+module GHC.Magic ( inline, noinline, noupdate, lazy, oneShot, runRW# ) where
--------------------------------------------------
-- See Note [magicIds] in GHC.Types.Id.Make
@@ -61,6 +61,10 @@ inline x = x
noinline :: a -> a
noinline x = x
+{-# NOINLINE noupdate #-}
+noupdate :: a -> a
+noupdate x = x
+
-- | The 'lazy' function restrains strictness analysis a little. The
-- call @lazy e@ means the same as @e@, but 'lazy' has a magical
-- property so far as strictness analysis is concerned: it is lazy in
=====================================
noupdate.hs
=====================================
@@ -0,0 +1,47 @@
+{-# OPTIONS_GHC -O2 -ddump-cmm -ddump-stg-final #-}
+import Debug.Trace
+import Control.Monad
+import GHC.Magic
+import Data.Time
+import GHC.IO.Unsafe
+
+main :: IO ()
+main = do
+ putStrLn "evaluating a top level updating thunk 2 times:"
+ replicateM_ 2 $ updatingThunk
+ putStrLn "evaluating a top level reentrant thunk 2 times:"
+ replicateM_ 2 $ reentrantThunk
+ x <- show <$> getCurrentTime
+ let
+ updating_local = trace "updating local thunk" $ pure x
+ reentrant_local = noupdate (trace "reentrant local thunk" (pure x))
+ putStrLn "evaluating a top level updating thunk 2 times:"
+ replicateM_ 2 $ updating_local
+ putStrLn "evaluating a top level reentrant thunk 2 times:"
+ replicateM_ 2 $ reentrant_local
+ let y = bar "dougrulz"
+ replicateM_ 2 $ print y
+
+
+
+
+
+
+
+{-# noinline updatingThunk #-}
+updatingThunk :: IO Int
+updatingThunk = trace "updatingThunk" $ length . show <$> getCurrentTime
+
+{-# noinline foo #-}
+foo () = (trace "reentrantThunk" $ length . show <$> getCurrentTime)
+
+{-# noinline reentrantThunk #-}
+reentrantThunk :: IO Int
+reentrantThunk = noupdate foo ()
+
+
+{-# noinline bar #-}
+bar :: String -> Int
+bar s = let
+ x = noupdate (length s)
+ in x
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53f74370bee1c4affebcfafc4c4cd10d236fa401...4bd0a3cdc19c46206a2e10ab7af934c934b9d119
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53f74370bee1c4affebcfafc4c4cd10d236fa401...4bd0a3cdc19c46206a2e10ab7af934c934b9d119
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221004/bf49438d/attachment-0001.html>
More information about the ghc-commits
mailing list