[Git][ghc/ghc][wip/con-info] 3 commits: Add whereFrom# primop
Matthew Pickering
gitlab at gitlab.haskell.org
Tue Nov 3 09:21:30 UTC 2020
Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC
Commits:
0d8d3cd7 by Matthew Pickering at 2020-11-03T08:49:51+00:00
Add whereFrom# primop
- - - - -
e92f46d9 by Matthew Pickering at 2020-11-03T09:11:24+00:00
Add simple test for whereFrom primop
- - - - -
d98f44c8 by Matthew Pickering at 2020-11-03T09:21:14+00:00
Fix warnings
- - - - -
16 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/StgToCmm/Prim.hs
- includes/rts/Profiling.h
- includes/stg/MiscClosures.h
- libraries/base/GHC/Stack/CCS.hsc
- rts/PrimOps.cmm
- rts/Profiling.c
- rts/RtsSymbols.c
- testsuite/tests/profiling/should_run/all.T
- + testsuite/tests/profiling/should_run/staticcallstack001.hs
- + testsuite/tests/profiling/should_run/staticcallstack001.stdout
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3004,6 +3004,15 @@ primop ClearCCSOp "clearCCS#" GenPrimOp
with
out_of_line = True
+------------------------------------------------------------------------
+section "Info Table Origin"
+------------------------------------------------------------------------
+primop WhereFromOp "whereFrom#" GenPrimOp
+ a -> State# s -> (# State# s, Addr# #)
+ { TODO }
+ with
+ out_of_line = True
+
------------------------------------------------------------------------
section "Etc"
{Miscellaneous built-ins}
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -47,16 +47,12 @@ import GHC.Platform.Ways
import GHC.Driver.Ppr
import GHC.Types.ForeignCall
import GHC.Types.Demand ( isUsedOnce )
-import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
+import GHC.Builtin.PrimOps ( PrimCall(..) )
import GHC.Builtin.Names ( unsafeEqualityProofName )
import GHC.Data.Maybe
import Data.List.NonEmpty (nonEmpty, toList)
import Control.Monad (ap)
-import Data.List.NonEmpty (nonEmpty, toList)
-import Data.Maybe (fromMaybe)
-import Data.Tuple (swap)
import qualified Data.Set as Set
import Control.Monad.Trans.RWS
import GHC.Types.Unique.Map
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -67,7 +67,6 @@ import GHCi.RemoteTypes
import GHC.Data.Stream
import GHC.Data.Bag
-import GHC.Hs.Extension
import Data.IORef
import Data.Maybe
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -163,7 +163,6 @@ import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
-import GHC.Driver.Session
import GHC.Utils.Error
import Data.IORef
@@ -187,7 +186,6 @@ import GHC.Types.HpcInfo
import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
-import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception
import GHC.Utils.Misc
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -59,7 +59,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.SysTools.FileCleanup
-import GHC.Types.Unique.FM
import GHC.Data.Stream
import GHC.Data.OrdList
@@ -70,7 +69,6 @@ import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
import GHC.Types.Unique.Map
-import GHC.Driver.Ppr
codeGen :: DynFlags
@@ -246,8 +244,7 @@ cgDataCon :: Maybe (Module, Int) -> DataCon -> FCode ()
cgDataCon _ data_con | isUnboxedTupleDataCon data_con = return ()
cgDataCon _ data_con | isUnboxedSumDataCon data_con = return ()
cgDataCon mn data_con
- = do { dflags <- getDynFlags
- ; profile <- getProfile
+ = do { profile <- getProfile
; platform <- getPlatform
; let
(tot_wds, -- #ptr_wds + #nonptr_wds
=====================================
compiler/GHC/StgToCmm/Heap.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Data.FastString( mkFastString, fsLit )
import Control.Monad (when)
import Data.Maybe (isJust)
-import GHC.Utils.Outputable
import GHC.Utils.Panic( sorry )
-----------------------------------------------------------
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1515,6 +1515,7 @@ emitPrimOp dflags primop = case primop of
NewBCOOp -> alwaysExternal
UnpackClosureOp -> alwaysExternal
ClosureSizeOp -> alwaysExternal
+ WhereFromOp -> alwaysExternal
GetApStackValOp -> alwaysExternal
ClearCCSOp -> alwaysExternal
TraceEventOp -> alwaysExternal
=====================================
includes/rts/Profiling.h
=====================================
@@ -16,3 +16,4 @@
void registerCcList(CostCentre **cc_list);
void registerInfoProvList(InfoProvEnt **cc_list);
void registerCcsList(CostCentreStack **cc_list);
+InfoProvEnt * lookupIPE(StgClosure *info);
\ No newline at end of file
=====================================
includes/stg/MiscClosures.h
=====================================
@@ -479,6 +479,7 @@ RTS_FUN_DECL(stg_writeTVarzh);
RTS_FUN_DECL(stg_unpackClosurezh);
RTS_FUN_DECL(stg_closureSizzezh);
+RTS_FUN_DECL(stg_whereFromzh);
RTS_FUN_DECL(stg_getApStackValzh);
RTS_FUN_DECL(stg_getSparkzh);
RTS_FUN_DECL(stg_numSparkszh);
=====================================
libraries/base/GHC/Stack/CCS.hsc
=====================================
@@ -20,6 +20,7 @@ module GHC.Stack.CCS (
-- * Call stacks
currentCallStack,
whoCreated,
+ whereFrom,
-- * Internals
CostCentreStack,
@@ -44,6 +45,7 @@ import GHC.Ptr
import GHC.Foreign as GHC
import GHC.IO.Encoding
import GHC.List ( concatMap, reverse )
+import Prelude (putStrLn, print)
#define PROFILING
#include "Rts.h"
@@ -135,3 +137,47 @@ whoCreated obj = do
renderStack :: [String] -> String
renderStack strs =
"CallStack (from -prof):" ++ concatMap ("\n "++) (reverse strs)
+
+-- Static Closure Information
+
+data InfoProv
+data InfoProvEnt
+
+-- | Get the 'InfoProvEnv' associated with the given value.
+getIPE :: a -> IO (Ptr InfoProvEnt)
+getIPE obj = IO $ \s ->
+ case whereFrom## obj s of
+ (## s', addr ##) -> (## s', Ptr addr ##)
+
+ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
+ipeProv p = p `plusPtr` 8 --(#offsetof InfoProvEnt, prov) -- TODO, offset is to the "prov" field but not sure how to express this
+ -- (# sizeOf * StgInfoTable)
+
+ipName, ipDesc, ipLabel, ipModule, ipSrcLoc :: Ptr InfoProv -> IO CString
+ipName p = (# peek InfoProv, table_name) p
+ipDesc p = (# peek InfoProv, closure_desc) p
+ipLabel p = (# peek InfoProv, label) p
+ipModule p = (# peek InfoProv, module) p
+ipSrcLoc p = (# peek InfoProv, srcloc) p
+
+infoProvToStrings :: Ptr InfoProv -> IO [String]
+infoProvToStrings ip = do
+ name <- GHC.peekCString utf8 =<< ipName ip
+ desc <- GHC.peekCString utf8 =<< ipDesc ip
+ label <- GHC.peekCString utf8 =<< ipLabel ip
+ mod <- GHC.peekCString utf8 =<< ipModule ip
+ loc <- GHC.peekCString utf8 =<< ipSrcLoc ip
+ return [name, desc, label, mod, loc]
+
+-- TODO: Add structured output of whereFrom
+
+whereFrom :: a -> IO [String]
+whereFrom obj = do
+ ipe <- getIPE obj
+ -- The primop returns the null pointer in two situations at the moment
+ -- 1. The lookup fails for whatever reason
+ -- 2. Profiling is not enabled.
+ -- It would be good to distinguish between these two cases somehow.
+ if ipe == nullPtr
+ then return []
+ else infoProvToStrings (ipeProv ipe)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2409,6 +2409,13 @@ stg_closureSizzezh (P_ clos)
return (len);
}
+stg_whereFromzh (P_ clos)
+{
+ P_ ipe;
+ (ipe) = foreign "C" lookupIPE(UNTAG(clos) "ptr");
+ return (ipe);
+}
+
/* -----------------------------------------------------------------------------
Thread I/O blocking primitives
-------------------------------------------------------------------------- */
=====================================
rts/Profiling.c
=====================================
@@ -6,7 +6,6 @@
*
* ---------------------------------------------------------------------------*/
-#if defined(PROFILING)
#include "PosixSource.h"
#include "Rts.h"
@@ -24,6 +23,9 @@
#include <fs_rts.h>
#include <string.h>
+// TODO: These above includes are only used for lookupIPE when profiling is
+// not enabled.
+#if defined(PROFILING)
#if defined(DEBUG) || defined(PROFILING)
#include "Trace.h"
@@ -1054,3 +1056,28 @@ debugCCS( CostCentreStack *ccs )
#endif /* DEBUG */
#endif /* PROFILING */
+
+// MP: TODO: This should not be a linear search, need to improve
+// the IPE_LIST structure
+#if defined(PROFILING)
+InfoProvEnt * lookupIPE(StgClosure *clos)
+{
+ StgInfoTable * info;
+ info = GET_INFO(clos);
+ InfoProvEnt *ip, *next;
+ //printf("%p\n", info);
+ //printf("%p\n\n", clos);
+ for (ip = IPE_LIST; ip != NULL; ip = next) {
+ if (ip->info == info) {
+ //printf("Found %p\n", ip->info);
+ return ip;
+ }
+ next = ip->link;
+ }
+}
+#else
+InfoProvEnt * lookupIPE(StgClosure *info STG_UNUSED)
+{
+ return ;
+}
+#endif
\ No newline at end of file
=====================================
rts/RtsSymbols.c
=====================================
@@ -546,6 +546,7 @@
SymI_HasProto(registerCcList) \
SymI_HasProto(registerInfoProvList) \
SymI_HasProto(registerCcsList) \
+ SymI_HasProto(lookupIPE) \
SymI_HasProto(era)
#else
#define RTS_PROF_SYMBOLS /* empty */
@@ -680,6 +681,7 @@
SymI_HasProto(initLinker_) \
SymI_HasProto(stg_unpackClosurezh) \
SymI_HasProto(stg_closureSizzezh) \
+ SymI_HasProto(stg_whereFromzh) \
SymI_HasProto(stg_getApStackValzh) \
SymI_HasProto(stg_getSparkzh) \
SymI_HasProto(stg_numSparkszh) \
=====================================
testsuite/tests/profiling/should_run/all.T
=====================================
@@ -150,3 +150,9 @@ test('T15897',
makefile_test, ['T15897'])
test('T17572', [], compile_and_run, [''])
+
+test('staticcallstack001',
+ # unoptimised results are different w.r.t. CAF attribution
+ [ omit_ways(['ghci-ext-prof']), # produces a different stack
+ ], compile_and_run,
+ ['-O0 -g3'])
=====================================
testsuite/tests/profiling/should_run/staticcallstack001.hs
=====================================
@@ -0,0 +1,19 @@
+module Main where
+
+import GHC.Stack.CCS
+
+data D = D Int deriving Show
+
+ff = id (D 5)
+{-# NOINLINE ff #-}
+{-# NOINLINE qq #-}
+
+qq x = D x
+
+caf = D 5
+
+main = do
+ print =<< whereFrom (D 5)
+ print =<< whereFrom caf
+ print =<< whereFrom (id (D 5))
+
=====================================
testsuite/tests/profiling/should_run/staticcallstack001.stdout
=====================================
@@ -0,0 +1,3 @@
+["D_Main_4_con_info","0","main","Main","staticcallstack001.hs:16:13-27"]
+["caf_info","21","caf","Main","staticcallstack001.hs:13:1-3"]
+["sat_sYR_info","15","main","Main","staticcallstack001.hs:18:13-32"]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ba64ae7d3536b2e09fa1f2aca8e8ce1aec2af6d...d98f44c87c7b566e6ba2d499b30f8fbc8bbc9feb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ba64ae7d3536b2e09fa1f2aca8e8ce1aec2af6d...d98f44c87c7b566e6ba2d499b30f8fbc8bbc9feb
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/20201103/ecd8b58c/attachment-0001.html>
More information about the ghc-commits
mailing list