%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.45 2001/03/06 10:13:35 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.46 2001/03/22 03:51:08 hwloidl Exp $
%
\section[CgClosure]{Code generation for closures}
--
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
- other -> trace ("*** closureCodeBody:arg_regs " ++ (pprHWL entry_conv) ++ "(HWL ignored; no args passed in regs)") []
-
- pprHWL :: EntryConvention -> String
- pprHWL (ViaNode) = "ViaNode"
- pprHWL (StdEntry cl) = "StdEntry"
- pprHWL (DirectEntry cl i l) = "DirectEntry"
+ other -> [] -- "(HWL ignored; no args passed in regs)"
num_arg_regs = length arg_regs
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.55 2001/03/15 11:26:27 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.56 2001/03/22 03:51:08 hwloidl Exp $
--
-- GHC Driver
--
| otherwise = [ ] -- just pass this file through to the linker
-- ToDo: this is somewhat cryptic
+
not_valid = throwDyn (OtherError ("invalid option combination"))
----------- ----- ---- --- -- -- - - -
StopBefore phase -> phase
DoMkDependHS -> Ln
DoLink -> Ln
- annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
+
+ annotated_pipeline = annotatePipeline (pipeline ++ [Ln]) stop_phase
phase_ne p (p1,_,_) = (p1 /= p)
----------- ----- ---- --- -- -- - - -
return True
-----------------------------------------------------------------------------
+-- MoveBinary sort-of-phase
+-- After having produced a binary, move it somewhere else and generate a
+-- wrapper script calling the binary. Currently, we need this only in
+-- a parallel way (i.e. in GUM), because PVM expects the binary in a
+-- central directory.
+-- This is called from doLink below, after linking. I haven't made it
+-- a separate phase to minimise interfering with other modules, and
+-- we don't need the generality of a phase (MoveBinary is always
+-- done after linking and makes only sense in a parallel setup) -- HWL
+
+run_phase_MoveBinary input_fn
+ = do
+ top_dir <- readIORef v_TopDir
+ pvm_root <- getEnv "PVM_ROOT"
+ pvm_arch <- getEnv "PVM_ARCH"
+ let
+ pvm_executable_base = "=" ++ input_fn
+ pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
+ sysMan = top_dir ++ "/ghc/rts/parallel/SysMan";
+ -- nuke old binary; maybe use configur'ed names for cp and rm?
+ system ("rm -f " ++ pvm_executable)
+ -- move the newly created binary into PVM land
+ system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
+ -- generate a wrapper script for running a parallel prg under PVM
+ writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
+ return True
+
+-- generates a Perl skript starting a parallel prg under PVM
+mk_pvm_wrapper_script :: String -> String -> String -> String
+mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
+ [
+ "eval 'exec perl -S $0 ${1+\"$@\"}'",
+ " if $running_under_some_shell;",
+ "# =!=!=!=!=!=!=!=!=!=!=!",
+ "# This script is automatically generated: DO NOT EDIT!!!",
+ "# Generated by Glasgow Haskell Compiler",
+ "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
+ "#",
+ "$pvm_executable = '" ++ pvm_executable ++ "';",
+ "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
+ "$SysMan = '" ++ sysMan ++ "';",
+ "",
+ {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
+ "# first, some magical shortcuts to run "commands" on the binary",
+ "# (which is hidden)",
+ "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
+ " local($cmd) = $1;",
+ " system("$cmd $pvm_executable");",
+ " exit(0); # all done",
+ "}", -}
+ "",
+ "# Now, run the real binary; process the args first",
+ "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base,
+ "$debug = '';",
+ "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
+ "@nonPVM_args = ();",
+ "$in_RTS_args = 0;",
+ "",
+ "args: while ($a = shift(@ARGV)) {",
+ " if ( $a eq '+RTS' ) {",
+ " $in_RTS_args = 1;",
+ " } elsif ( $a eq '-RTS' ) {",
+ " $in_RTS_args = 0;",
+ " }",
+ " if ( $a eq '-d' && $in_RTS_args ) {",
+ " $debug = '-';",
+ " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
+ " $nprocessors = $1;",
+ " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
+ " $nprocessors = $1;",
+ " } else {",
+ " push(@nonPVM_args, $a);",
+ " }",
+ "}",
+ "",
+ "local($return_val) = 0;",
+ "# Start the parallel execution by calling SysMan",
+ "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
+ "$return_val = $?;",
+ "# ToDo: fix race condition moving files and flushing them!!",
+ "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
+ "exit($return_val);"
+ ]
+
+-----------------------------------------------------------------------------
-- Linking
doLink :: [String] -> IO ()
#endif
)
)
+ -- parallel only: move binary to another dir -- HWL
+ ways_ <- readIORef v_Ways
+ when (WayPar `elem` ways_) (do
+ success <- run_phase_MoveBinary output_fn
+ if success then return ()
+ else throwDyn (OtherError ("cannot move binary to PVM dir")))
-----------------------------------------------------------------------------
-- Making a DLL
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.33 2001/03/12 14:06:47 simonpj Exp $
+-- $Id: DriverState.hs,v 1.34 2001/03/22 03:51:08 hwloidl Exp $
--
-- Settings for the driver
--
(WayUnreg, Way "u" "Unregisterised"
unregFlags ),
+ -- optl's below to tell linker where to find the PVM library -- HWL
(WayPar, Way "mp" "Parallel"
[ "-fparallel"
, "-D__PARALLEL_HASKELL__"
, "-optc-DPAR"
, "-package concurrent"
+ , "-optc-w"
+ , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
+ , "-optl-lpvm3"
+ , "-optl-lgpvm3"
, "-fvia-C" ]),
- (WayGran, Way "mg" "Gransim"
+ -- at the moment we only change the RTS and could share compiler and libs!
+ (WayPar, Way "mt" "Parallel ticky profiling"
+ [ "-fparallel"
+ , "-D__PARALLEL_HASKELL__"
+ , "-optc-DPAR"
+ , "-optc-DPAR_TICKY"
+ , "-package concurrent"
+ , "-optc-w"
+ , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
+ , "-optl-lpvm3"
+ , "-optl-lgpvm3"
+ , "-fvia-C" ]),
+
+ (WayPar, Way "md" "Distributed"
+ [ "-fparallel"
+ , "-D__PARALLEL_HASKELL__"
+ , "-D__DISTRIBUTED_HASKELL__"
+ , "-optc-DPAR"
+ , "-optc-DDIST"
+ , "-package concurrent"
+ , "-optc-w"
+ , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}"
+ , "-optl-lpvm3"
+ , "-optl-lgpvm3"
+ , "-fvia-C" ]),
+
+ (WayGran, Way "mg" "GranSim"
[ "-fgransim"
, "-D__GRANSIM__"
, "-optc-DGRAN"
-----------------------------------------------------------------------
--- $Id: primops.txt,v 1.18 2001/02/28 00:01:02 qrczak Exp $
+-- $Id: primops.txt,v 1.19 2001/03/22 03:51:08 hwloidl Exp $
--
-- Primitive Operations
--
primop IndexOffForeignObjOp_Word64 "indexWord64OffForeignObj#" GenPrimOp
ForeignObj# -> Int# -> Word64#
-
-
primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp
Addr# -> Int# -> State# s -> (# State# s, Char# #)
with
strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
-
------------------------------------------------------------------------
--- Weak pointers ---
------------------------------------------------------------------------
has_side_effects = True
out_of_line = True
-
------------------------------------------------------------------------
--- Stable pointers and names ---
------------------------------------------------------------------------
-- copyable# and noFollow# have no corresponding entry in
-- PrelGHC.hi-boot, so I don't know whether they should still
-- be here or not. JRS, 15 Jan 01
+-- not implemented; please, keep the comment as reminder -- HWL 12/3/01
--
--primop CopyableOp "copyable#" GenPrimOp
-- a -> Int#
<Para>
A Parallel Haskell program implies multiple processes running on
multiple processors, under a PVM (Parallel Virtual Machine) framework.
+An MPI interface is under development but not fully functional, yet.
</Para>
<Para>
</Para>
<Para>
-Again, check Simon's Web page for publications about Parallel Haskell
-(including “GUM”, the key bits of the runtime system).
+Check the <ULink URL="http://www.cee.hw.ac.uk/~dsg/gph/">GPH Page</Ulink>
+for more information on “GPH” (Haskell98 with extensions for
+parallel execution), the latest version of “GUM” (the runtime
+system to enable parallel executions) and papers on research issues. A
+list of publications about GPH and about GUM is also available from Simon's
+Web Page.
</Para>
<Para>
</Sect3>
-<Sect3 id="sec-scheduling-policy">
-<Title>Scheduling policy for concurrent/parallel threads
-<IndexTerm><Primary>Scheduling—concurrent/parallel</Primary></IndexTerm>
-<IndexTerm><Primary>Concurrent/parallel scheduling</Primary></IndexTerm></Title>
+<Sect3>
+<Title>Scheduling policy for concurrent threads
+<IndexTerm><Primary>Scheduling—concurrent</Primary></IndexTerm>
+<IndexTerm><Primary>Concurrent scheduling</Primary></IndexTerm></Title>
<Para>
Runnable threads are scheduled in round-robin fashion. Context
</Sect3>
+<Sect3>
+<Title>Scheduling policy for parallel threads
+<IndexTerm><Primary>Scheduling—parallel</Primary></IndexTerm>
+<IndexTerm><Primary>Parallel scheduling</Primary></IndexTerm></Title>
+
+<Para>
+In GUM we use an unfair scheduler, which means that a thread continues to
+perform graph reduction until it blocks on a closure under evaluation, on a
+remote closure or until the thread finishes.
+</Para>
+
+</Sect3>
+
</Sect2>
</Sect1>
<para>
[You won't be able to execute parallel Haskell programs unless PVM3
-(Parallel Virtual Machine, version 3) is installed at your site.]
-</para>
+(Parallel Virtual Machine, version 3) is installed at your site.]
+</Para>
<para>
To compile a Haskell program for parallel execution under PVM, use the
-<option>-parallel</option> option,<indexterm><primary>-parallel
-option</primary></indexterm> both when compiling <emphasis>and
-linking</emphasis>. You will probably want to <literal>import
-Parallel</literal> into your Haskell modules.
-</para>
+<Option>-parallel</Option> option,<IndexTerm><Primary>-parallel
+option</Primary></IndexTerm> both when compiling <Emphasis>and
+linking</Emphasis>. You will probably want to <Literal>import
+Parallel</Literal> into your Haskell modules.
+</Para>
<para>
To run your parallel program, once PVM is going, just invoke it
“as normal”. The main extra RTS option is
-<option>-N<n></option>, to say how many PVM
+<Option>-qp<n></Option>, to say how many PVM
“processors” your program to run on. (For more details of
all relevant RTS options, please see <XRef
LinkEnd="parallel-rts-opts">.)
PVM, detailed in the following sections.
</para>
-<sect2>
-<title>Dummy's guide to using PVM</title>
+<Sect2 id="pvm-dummies">
+<Title>Dummy's guide to using PVM</Title>
<para>
<indexterm><primary>PVM, how to use</primary></indexterm>
<para>
Creating and/or controlling your “parallel machine” is a purely-PVM
-business; nothing specific to Parallel Haskell.
-</para>
+business; nothing specific to Parallel Haskell. The following paragraphs
+describe how to configure your parallel machine interactively.
+</Para>
-<para>
-You use the <command>pvm</command><indexterm><primary>pvm command</primary></indexterm> command to start PVM on your
+<Para>
+If you use parallel Haskell regularly on the same machine configuration it
+is a good idea to maintain a file with all machine names and to make the
+environment variable PVM_HOST_FILE point to this file. Then you can avoid
+the interactive operations described below by just saying
+</Para>
+
+<ProgramListing>
+pvm $PVM_HOST_FILE
+</ProgramListing>
+
+<Para>
+You use the <Command>pvm</Command><IndexTerm><Primary>pvm command</Primary></IndexTerm> command to start PVM on your
machine. You can then do various things to control/monitor your
“parallel machine;” the most useful being:
</para>
</sect2>
-<sect2>
-<title>Parallelism profiles</title>
+<Sect2 id="par-profiles">
+<Title>Parallelism profiles</Title>
<para>
<indexterm><primary>parallelism profiles</primary></indexterm>
results—only with “how parallel” it was! We want pretty pictures.
</para>
-<para>
-Parallelism profiles (à la <command>hbcpp</command>) can be generated with the
-<option>-q</option><indexterm><primary>-q RTS option (concurrent, parallel)</primary></indexterm> RTS option. The
+<Para>
+Parallelism profiles (à la <Command>hbcpp</Command>) can be generated with the
+<Option>-qP</Option><IndexTerm><Primary>-qP RTS option (concurrent, parallel)</Primary></IndexTerm> RTS option. The
per-processor profiling info is dumped into files named
-<filename><full-path><program>.gr</filename>. These are then munged into a PostScript picture,
+<Filename><full-path><program>.gr</Filename>. These are then munged into a PostScript picture,
which you can then display. For example, to run your program
-<filename>a.out</filename> on 8 processors, then view the parallelism profile, do:
-</para>
+<Filename>a.out</Filename> on 8 processors, then view the parallelism profile, do:
+</Para>
-<para>
+<Para>
<Screen>
-% ./a.out +RTS -N8 -q
-% grs2gr *.???.gr > temp.gr # combine the 8 .gr files into one
-% gr2ps -O temp.gr # cvt to .ps; output in temp.ps
-% ghostview -seascape temp.ps # look at it!
+<prompt> ./a.out +RTS -qP -qp8
+<prompt> grs2gr *.???.gr > temp.gr # combine the 8 .gr files into one
+<prompt> gr2ps -O temp.gr # cvt to .ps; output in temp.ps
+<prompt> ghostview -seascape temp.ps # look at it!
</Screen>
-</para>
+</Para>
<para>
The scripts for processing the parallelism profiles are distributed
</sect2>
-<sect2>
-<title>Other useful info about running parallel programs</title>
+<Sect2>
+<Title>Other useful info about running parallel programs</Title>
-<para>
+<Para>
The “garbage-collection statistics” RTS options can be useful for
seeing what parallel programs are doing. If you do either
-<option>+RTS -Sstderr</option><indexterm><primary>-Sstderr RTS option</primary></indexterm> or <option>+RTS -sstderr</option>, then
+<Option>+RTS -Sstderr</Option><IndexTerm><Primary>-Sstderr RTS option</Primary></IndexTerm> or <Option>+RTS -sstderr</Option>, then
you'll get mutator, garbage-collection, etc., times on standard
error. The standard error of all PE's other than the `main thread'
appears in <filename>/tmp/pvml.nnn</filename>, courtesy of PVM.
<para>
<VariableList>
-<varlistentry>
-<term><option>-N<N></option>:</term>
-<listitem>
-<para>
-<indexterm><primary>-N<N> RTS option (parallel)</primary></indexterm>
-(PARALLEL ONLY) Use <literal><N></literal> PVM processors to run this program;
+<VarListEntry>
+<Term><Option>-qp<N></Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-qp<N> RTS option</Primary></IndexTerm>
+(PARALLEL ONLY) Use <Literal><N></Literal> PVM processors to run this program;
the default is 2.
</para>
</listitem>
green queue is split into green (for the currently running thread
only) and amber (for other runnable threads). We do not recommend
that you use the verbose suboption if you are planning to use the
-<command>hbcpp</command> profiling tools or if you are context switching at every heap
-check (with <option>-C</option>).
-</para>
-</listitem>
-</varlistentry>
-<varlistentry>
-<term><option>-t<num></option>:</term>
-<listitem>
-<para>
-<indexterm><primary>-t<num> RTS option</primary></indexterm>
-(PARALLEL ONLY) Limit the number of concurrent threads per processor
-to <literal><num></literal>. The default is 32. Each thread requires slightly over 1K
-<emphasis>words</emphasis> in the heap for thread state and stack objects. (For
-32-bit machines, this translates to 4K bytes, and for 64-bit machines,
-8K bytes.)
-</para>
-</listitem>
-</varlistentry>
-<varlistentry>
-<term><option>-d</option>:</term>
-<listitem>
-<para>
-<indexterm><primary>-d RTS option (parallel)</primary></indexterm>
+<Command>hbcpp</Command> profiling tools or if you are context switching at every heap
+check (with <Option>-C</Option>).
+-->
+</Para>
+</ListItem>
+</VarListEntry>
+<VarListEntry>
+<Term><Option>-qt<num></Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-qt<num> RTS option</Primary></IndexTerm>
+(PARALLEL ONLY) Limit the thread pool size, i.e. the number of concurrent
+threads per processor to <Literal><num></Literal>. The default is
+32. Each thread requires slightly over 1K <Emphasis>words</Emphasis> in
+the heap for thread state and stack objects. (For 32-bit machines, this
+translates to 4K bytes, and for 64-bit machines, 8K bytes.)
+</Para>
+</ListItem>
+</VarListEntry>
+<!-- no more -- HWL
+<VarListEntry>
+<Term><Option>-d</Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-d RTS option (parallel)</Primary></IndexTerm>
(PARALLEL ONLY) Turn on debugging. It pops up one xterm (or GDB, or
-something…) per PVM processor. We use the standard <command>debugger</command>
+something…) per PVM processor. We use the standard <Command>debugger</Command>
script that comes with PVM3, but we sometimes meddle with the
-<command>debugger2</command> script. We include ours in the GHC distribution,
-in <filename>ghc/utils/pvm/</filename>.
-</para>
-</listitem>
-</varlistentry>
-<varlistentry>
-<term><option>-e<num></option>:</term>
-<listitem>
-<para>
-<indexterm><primary>-e<num> RTS option (parallel)</primary></indexterm>
-(PARALLEL ONLY) Limit the number of pending sparks per processor to
-<literal><num></literal>. The default is 100. A larger number may be appropriate if
-your program generates large amounts of parallelism initially.
-</para>
-</listitem>
-</varlistentry>
-<varlistentry>
-<term><option>-Q<num></option>:</term>
-<listitem>
-<para>
-<indexterm><primary>-Q<num> RTS option (parallel)</primary></indexterm>
+<Command>debugger2</Command> script. We include ours in the GHC distribution,
+in <Filename>ghc/utils/pvm/</Filename>.
+</Para>
+</ListItem>
+</VarListEntry>
+-->
+<VarListEntry>
+<Term><Option>-qe<num></Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-qe<num> RTS option
+(parallel)</Primary></IndexTerm> (PARALLEL ONLY) Limit the spark pool size
+i.e. the number of pending sparks per processor to
+<Literal><num></Literal>. The default is 100. A larger number may be
+appropriate if your program generates large amounts of parallelism
+initially.
+</Para>
+</ListItem>
+</VarListEntry>
+<VarListEntry>
+<Term><Option>-qQ<num></Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-qQ<num> RTS option (parallel)</Primary></IndexTerm>
(PARALLEL ONLY) Set the size of packets transmitted between processors
-to <literal><num></literal>. The default is 1024 words. A larger number may be
+to <Literal><num></Literal>. The default is 1024 words. A larger number may be
appropriate if your machine has a high communication cost relative to
computation speed.
-</para>
-</listitem>
-</varlistentry>
+</Para>
+</ListItem>
+</VarListEntry>
+<VarListEntry>
+<Term><Option>-qh<num></Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-qh<num> RTS option (parallel)</Primary></IndexTerm>
+(PARALLEL ONLY) Select a packing scheme. Set the number of non-root thunks to pack in one packet to
+<num>-1 (0 means infinity). By default GUM uses full-subgraph
+packing, i.e. the entire subgraph with the requested closure as root is
+transmitted (provided it fits into one packet). Choosing a smaller value
+reduces the amount of pre-fetching of work done in GUM. This can be
+advantageous for improving data locality but it can also worsen the balance
+of the load in the system.
+</Para>
+</ListItem>
+</VarListEntry>
+<VarListEntry>
+<Term><Option>-qg<num></Option>:</Term>
+<ListItem>
+<Para>
+<IndexTerm><Primary>-qg<num> RTS option
+(parallel)</Primary></IndexTerm> (PARALLEL ONLY) Select a globalisation
+scheme. This option affects the
+generation of global addresses when transferring data. Global addresses are
+globally unique identifiers required to maintain sharing in the distributed
+graph structure. Currently this is a binary option. With <num>=0 full globalisation is used
+(default). This means a global address is generated for every closure that
+is transmitted. With <num>=1 a thunk-only globalisation scheme is
+used, which generated global address only for thunks. The latter case may
+lose sharing of data but has a reduced overhead in packing graph structures
+and maintaining internal tables of global addresses.
+</Para>
+</ListItem>
+</VarListEntry>
</VariableList>
</para>
/* ----------------------------------------------------------------------------
- * $Id: ClosureTypes.h,v 1.14 2001/01/29 17:23:41 simonmar Exp $
+ * $Id: ClosureTypes.h,v 1.15 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#define EVACUATED 64
-#define N_CLOSURE_TYPES 65
+#define REMOTE_REF 65
+
+#define N_CLOSURE_TYPES 66
#endif /* CLOSURETYPES_H */
/* -----------------------------------------------------------------------------
- * $Id: Hooks.h,v 1.3 1999/02/05 16:02:22 simonm Exp $
+ * $Id: Hooks.h,v 1.4 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void defaultsHook (void);
extern void PreTraceHook (long fd);
extern void PostTraceHook (long fd);
+#if defined(PAR)
+extern void InitEachPEHook (void);
+extern void ShutdownEachPEHook (void);
+#endif
\ No newline at end of file
/* ----------------------------------------------------------------------------
- * $Id: InfoMacros.h,v 1.13 2000/08/17 15:19:17 rrt Exp $
+ * $Id: InfoMacros.h,v 1.14 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
type, /* closure type */ \
info_class, entry_class, /* C storage classes */ \
prof_descr, prof_type) /* profiling info */ \
- entry_class(RBH_##entry); \
+ entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
+ info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(RBH_##entry), \
+ INIT_ENTRY(stg_RBH_##entry), \
INIT_VECTOR \
} ; \
- StgFunPtr RBH_##entry (void) { JMP_(RBH_entry); } ; \
+ StgFunPtr stg_RBH_##entry (void) { \
+ FB_ \
+ JMP_(stg_RBH_entry); \
+ FE_ \
+ } ; \
info_class INFO_TBL_CONST StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INCLUDE_RBH_INFO(RBH_##info), \
+ INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry), \
INIT_VECTOR \
}
INFO_TABLE_SRT_BITMAP(info, entry, bitmap_, srt_, srt_off_, srt_len_, \
type, info_class, entry_class, \
prof_descr, prof_type) \
- entry_class(RBH_##entry); \
+ entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
+ info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
layout : { bitmap : (StgWord32)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(RBH,srt_,srt_off_,srt_len_), \
INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(RBH_##entry), \
+ INIT_ENTRY(stg_RBH_##entry), \
INIT_VECTOR \
}; \
- StgFunPtr RBH_##entry (void) { JMP_(RBH_entry); } ; \
+ StgFunPtr stg_RBH_##entry (void) { \
+ FB_ \
+ JMP_(stg_RBH_entry); \
+ FE_ \
+ } ; \
info_class INFO_TBL_CONST StgInfoTable info = { \
layout : { bitmap : (StgWord32)bitmap_ }, \
PROF_INFO(prof_type, prof_descr) \
SRT_INFO(type,srt_,srt_off_,srt_len_), \
- INCLUDE_RBH_INFO(RBH_##info), \
+ INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry), \
INIT_VECTOR \
}
+
#else
#define \
#define \
INFO_TABLE(info, entry, ptrs, nptrs, type, info_class, \
entry_class, prof_descr, prof_type) \
- entry_class(RBH_##entry); \
+ entry_class(stg_RBH_##entry); \
entry_class(entry); \
- ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
+ ED_ StgInfoTable info; \
+ info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(RBH), \
- INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(RBH_##entry), \
+ INCLUDE_RBH_INFO(info), \
+ INIT_ENTRY(stg_RBH_##entry), \
INIT_VECTOR \
- }; \
- StgFunPtr RBH_##entry (void) { JMP_(RBH_entry); } ; \
- info_class INFO_TBL_CONST StgInfoTable info = { \
+ } ; \
+ StgFunPtr stg_RBH_##entry (void) { \
+ FB_ \
+ JMP_(stg_RBH_entry); \
+ FE_ \
+ } ; \
+ info_class INFO_TBL_CONST StgInfoTable info = { \
layout : { payload : {ptrs,nptrs} }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(type), \
- INCLUDE_RBH_INFO(RBH_##info), \
+ INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry), \
INIT_VECTOR \
}
#define \
INFO_TABLE_SELECTOR(info, entry, offset, info_class, \
entry_class, prof_descr, prof_type) \
- entry_class(RBH_##entry); \
+ entry_class(stg_RBH_##entry); \
entry_class(entry); \
ED_RO_ StgInfoTable info; \
- info_class INFO_TBL_CONST StgInfoTable RBH_##info = { \
+ info_class INFO_TBL_CONST StgInfoTable stg_RBH_##info = { \
layout : { selector_offset : offset }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(RBH), \
INCLUDE_RBH_INFO(info), \
- INIT_ENTRY(RBH_##entry), \
+ INIT_ENTRY(stg_RBH_##entry), \
INIT_VECTOR \
}; \
- StgFunPtr RBH_##entry (void) { JMP_(RBH_entry); } ; \
+ StgFunPtr stg_RBH_##entry (void) { \
+ FB_ \
+ JMP_(stg_RBH_entry); \
+ FE_ \
+ } ; \
info_class INFO_TBL_CONST StgInfoTable info = { \
layout : { selector_offset : offset }, \
PROF_INFO(prof_type, prof_descr) \
STD_INFO(THUNK_SELECTOR), \
- INCLUDE_RBH_INFO(RBH_##info), \
+ INCLUDE_RBH_INFO(stg_RBH_##info), \
INIT_ENTRY(entry), \
INIT_VECTOR \
}
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.20 2001/03/02 16:12:18 simonmar Exp $
+ * $Id: InfoTables.h,v 1.21 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#define closure_HNF(c) ( closureFlags(c) & _HNF)
#define closure_BITMAP(c) ( closureFlags(c) & _BTM)
+#define closure_NON_SPARK(c) ( (closureFlags(c) & _NS))
#define closure_SHOULD_SPARK(c) (!(closureFlags(c) & _NS))
#define closure_STATIC(c) ( closureFlags(c) & _STA)
#define closure_THUNK(c) ( closureFlags(c) & _THU)
/*
- Time-stamp: <Tue Mar 28 2000 23:50:54 Stardate: [-30]4574.76 hwloidl>
- $Id: Parallel.h,v 1.3 2000/03/31 03:09:35 hwloidl Exp $
+ Time-stamp: <Tue Mar 06 2001 00:09:10 Stardate: [-30]6285.03 hwloidl>
+ $Id: Parallel.h,v 1.4 2001/03/22 03:51:09 hwloidl Exp $
Definitions for GUM i.e. running on a parallel machine.
extern rtsBool InGlobalGC; /* Are we in the midst of performing global GC */
-static ullong startTime; /* start of comp; in RtsStartup.c */
+extern ullong startTime; /* start of comp; in RtsStartup.c */
/* the spark pools proper */
extern rtsSpark *pending_sparks_hd[]; /* ptr to start of a spark pool */
StgInt /* nat */ size;
StgInt /* nat */ unpacked_size;
StgTSO *tso;
- StgBuffer *buffer;
+ StgWord *buffer;
} rtsPackBuffer;
//@node Macros, , Prototypes, GranSim
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.75 2001/02/28 00:01:03 qrczak Exp $
+ * $Id: PrimOps.h,v 1.76 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
Stable Name / Stable Pointer PrimOps
-------------------------------------------------------------------------- */
-#ifndef PAR
-
EXTFUN_RTS(makeStableNamezh_fast);
#define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
#define eqStablePtrzh(r,sp1,sp2) \
(r = ((stgCast(StgWord,sp1) & ~STABLEPTR_WEIGHT_MASK) == (stgCast(StgWord,sp2) & ~STABLEPTR_WEIGHT_MASK)))
-#endif
-
/* -----------------------------------------------------------------------------
Concurrency/Exception PrimOps.
-------------------------------------------------------------------------- */
#if defined(GRAN)
//@cindex _par_
-#define parzh(r,node) PAR(r,node,1,0,0,0,0,0)
+#define parzh(r,node) parAny(r,node,1,0,0,0,0,0)
//@cindex _parAt_
#define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
//@cindex _parLocal_
#define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
- PAR(r,node,rest,identifier,gran_info,size_info,par_info,1)
+ parAny(r,node,rest,identifier,gran_info,size_info,par_info,1)
//@cindex _parGlobal_
#define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \
- PAR(r,node,rest,identifier,gran_info,size_info,par_info,0)
+ parAny(r,node,rest,identifier,gran_info,size_info,par_info,0)
-#define PAR(r,node,rest,identifier,gran_info,size_info,par_info,local) \
+#define parAny(r,node,rest,identifier,gran_info,size_info,par_info,local) \
{ \
if (closure_SHOULD_SPARK((StgClosure*)node)) { \
rtsSpark *result; \
Weak Pointer PrimOps.
-------------------------------------------------------------------------- */
-#ifndef PAR
-
EXTFUN_RTS(mkWeakzh_fast);
EXTFUN_RTS(finalizzeWeakzh_fast);
#define sameWeakzh(w1,w2) ((w1)==(w2))
-#endif
/* -----------------------------------------------------------------------------
Foreign Object PrimOps.
-------------------------------------------------------------------------- */
-#ifndef PAR
-
#define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
#define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
#define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i)
#endif
-#endif
-
-
/* -----------------------------------------------------------------------------
Constructor tags
-------------------------------------------------------------------------- */
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.20 2001/02/09 12:09:33 simonmar Exp $
+ * $Id: RtsAPI.h,v 1.21 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
SchedulerStatus
rts_evalLazyIO ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret );
-#if defined(PAR) || defined(SMP)
-SchedulerStatus
-rts_evalNothing(unsigned int stack_size);
-#endif
-
void
rts_checkSchedStatus ( char* site, SchedulerStatus rc);
/*
- Time-stamp: <Mon Nov 22 1999 21:29:44 Stardate: [-30]3939.47 hwloidl>
+ Time-stamp: <Mon Mar 05 2001 22:39:27 Stardate: [-30]6284.72 hwloidl>
RTS specific types.
*/
#elif defined(GRAN)
+// GlobalTaskId is dummy in GranSim;
+// we define it to have cleaner code in the RTS
+typedef int GlobalTaskId;
typedef lnat rtsTime;
typedef StgWord PEs;
/* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.12 2000/12/04 12:31:20 simonmar Exp $
+ * $Id: SchedAPI.h,v 1.13 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team 1998
*
#else
StgTSO *createThread(nat stack_size);
#endif
+#if defined(PAR) || defined(SMP)
+void taskStart(void);
+#endif
void scheduleThread(StgTSO *tso);
static inline void pushClosure (StgTSO *tso, StgClosure *c) {
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.37 2001/02/15 14:27:36 sewardj Exp $
+ * $Id: StgMiscClosures.h,v 1.38 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
extern DLL_IMPORT_RTS const StgInfoTable stg_gc_f1_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_gc_d1_info;
+/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
+#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
+/* this is the NIL ptr for a list CAFs */
+#define END_ECAF_LIST ((StgCAF *)(void*)&stg_END_TSO_QUEUE_closure)
#if defined(PAR) || defined(GRAN)
/* this is the NIL ptr for a blocking queue */
-# define END_BQ_QUEUE ((StgBlockingQueueElement *)(void*)&END_TSO_QUEUE_closure)
+# define END_BQ_QUEUE ((StgBlockingQueueElement *)(void*)&stg_END_TSO_QUEUE_closure)
/* this is the NIL ptr for a blocked fetch queue (as in PendingFetches in GUM) */
-# define END_BF_QUEUE ((StgBlockedFetch *)(void*)&END_TSO_QUEUE_closure)
+# define END_BF_QUEUE ((StgBlockedFetch *)(void*)&stg_END_TSO_QUEUE_closure)
#endif
+/* ToDo?: different name for end of sleeping queue ? -- HWL */
/* info tables */
#if defined(PAR) || defined(GRAN)
extern DLL_IMPORT_RTS const StgInfoTable stg_RBH_info;
#endif
+#if defined(PAR)
+extern DLL_IMPORT_RTS const StgInfoTable stg_FETCH_ME_BQ_info;
+#endif
extern DLL_IMPORT_RTS const StgInfoTable stg_BCO_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_EVACUATED_info;
extern DLL_IMPORT_RTS const StgInfoTable stg_FOREIGN_info;
/* -----------------------------------------------------------------------------
- * $Id: TSO.h,v 1.19 2000/12/14 15:19:47 sewardj Exp $
+ * $Id: TSO.h,v 1.20 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#if defined(GRAN) || defined(PAR)
-#if DEBUG // && PARANOIA_LEVEL>999
-// magic marker for TSOs; debugging only
+#if DEBUG
#define TSO_MAGIC 4321
#endif
} StgTSOParInfo;
#endif /* PAR */
+#if defined(DIST)
+typedef struct {
+ StgThreadPriority priority;
+ StgInt revalTid; /* ToDo: merge both into 1 word */
+ StgInt revalSlot;
+} StgTSODistInfo;
+#else /* !DIST */
+typedef struct {
+} StgTSODistInfo;
+#endif /* DIST */
+
#if defined(GRAN)
typedef StgTSOStatBuf StgTSOGranInfo;
#else /* !GRAN */
ThreadFinished
} StgThreadReturnCode;
+/*
+ * We distinguish between the various classes of threads in the system.
+ */
+
+typedef enum {
+ AdvisoryPriority,
+ MandatoryPriority,
+ RevalPriority
+} StgThreadPriority;
+
/*
* Threads may be blocked for several reasons. A blocked thread will
* have the reason in the why_blocked field of the TSO, and some
StgTSOProfInfo prof;
StgTSOParInfo par;
StgTSOGranInfo gran;
-
+ StgTSODistInfo dist;
+
/* The thread stack... */
StgWord stack_size; /* stack size in *words* */
StgWord max_stack_size; /* maximum stack size in *words* */
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.23 2001/02/09 13:09:17 simonmar Exp $
+ * $Id: Updates.h,v 1.24 2001/03/22 03:51:09 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#if defined(PAR)
/*
- In a parallel setup several types of closures, might have a blocking queue:
+ In a parallel setup several types of closures might have a blocking queue:
BLACKHOLE_BQ ... same as in the default concurrent setup; it will be
reawakened via calling UPD_IND on that closure after
having finished the computation of the graph
TSO ... as in the default concurrent setup
BLOCKED_FETCH ... indicating that a TSO on another PE is waiting for
the result of the current computation
- CONSTR ... a RBHSave closure (which contains data ripped out of
+ CONSTR ... an RBHSave closure (which contains data ripped out of
the closure to make room for a blocking queue; since
it only contains data we use the exisiting type of
a CONSTR closure); this closure is the end of a
if (info == &stg_BLACKHOLE_BQ_info || \
info == &stg_FETCH_ME_BQ_info || \
get_itbl(closure)->type == RBH) { \
- StgBlockingQueueElement *bqe = ((StgBlockingQueue *)closure)->blocking_queue;\
- ASSERT(bqe!=END_BQ_QUEUE); \
- DO_AWAKEN_BQ(bqe, closure); \
+ DO_AWAKEN_BQ(((StgBlockingQueue *)closure)->blocking_queue, closure); \
}
#elif defined(GRAN)
#define AWAKEN_BQ(info,closure) \
if (info == &stg_BLACKHOLE_BQ_info || \
get_itbl(closure)->type == RBH) { \
- StgBlockingQueueElement *bqe = ((StgBlockingQueue *)closure)->blocking_queue;\
- ASSERT(bqe!=END_BQ_QUEUE); \
- DO_AWAKEN_BQ(bqe, closure); \
+ DO_AWAKEN_BQ(((StgBlockingQueue *)closure)->blocking_queue, closure); \
}
% ------------------------------------------------------------------------------
-% $Id: PrelForeign.lhs,v 1.17 2001/01/11 17:25:57 simonmar Exp $
+% $Id: PrelForeign.lhs,v 1.18 2001/03/22 03:51:09 hwloidl Exp $
%
% (c) The University of Glasgow, 1994-2000
%
%*********************************************************
\begin{code}
-#ifndef __PARALLEL_HASKELL__
+
newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr p finalizer
= do fObj <- mkForeignPtr p
foreignPtrToPtr (ForeignPtr fo) = Ptr (foreignObjToAddr# fo)
castForeignPtr (ForeignPtr a) = ForeignPtr a
-#endif
+
\end{code}
% ------------------------------------------------------------------------------
-% $Id: PrelWeak.lhs,v 1.15 2001/01/11 17:25:57 simonmar Exp $
+% $Id: PrelWeak.lhs,v 1.16 2001/03/22 03:51:09 hwloidl Exp $
%
% (c) The University of Glasgow, 1998-2000
%
import PrelMaybe
import PrelIOBase ( IO(..), unIO )
-#ifndef __PARALLEL_HASKELL__
-
data Weak v = Weak (Weak# v)
mkWeak :: k -- key
in
go n
-#endif
-
\end{code}
/* -----------------------------------------------------------------------------
- * $Id: ClosureFlags.c,v 1.8 2001/03/02 16:12:18 simonmar Exp $
+ * $Id: ClosureFlags.c,v 1.9 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team 1998-1999
*
[FETCH_ME_BQ ] = ( _NS| _MUT|_UPT ),
[RBH ] = ( _NS| _MUT|_UPT ),
[EVACUATED ] = ( 0 ),
+[REMOTE_REF ] = (_HNF| _NS| _UPT ),
[N_CLOSURE_TYPES ] = ( 0 )
};
/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.18 2000/12/04 12:31:20 simonmar Exp $
+ * $Id: Exception.hc,v 1.19 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
ASSERT(CurrentTSO->blocked_exceptions != NULL);
#if defined(GRAN)
awakenBlockedQueue(CurrentTSO->blocked_exceptions,
- CurrentTSO->block_info.closure);
+ (StgClosure*)NULL);
#elif defined(PAR)
- // is CurrentTSO->block_info.closure always set to the node
- // holding the blocking queue !? -- HWL
+ /* we don't need node info (2nd arg) in this case
+ (note that CurrentTSO->block_info.closure isn't always set) */
awakenBlockedQueue(CurrentTSO->blocked_exceptions,
- CurrentTSO->block_info.closure);
+ (StgClosure*)NULL);
#else
awakenBlockedQueue(CurrentTSO->blocked_exceptions);
#endif
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.99 2001/03/20 11:37:21 simonmar Exp $
+ * $Id: GC.c,v 1.100 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team 1998-1999
*
#include "Weak.h"
#include "StablePriv.h"
#include "Prelude.h"
+#include "ParTicky.h" // ToDo: move into Rts.h
#if defined(GRAN) || defined(PAR)
# include "GranSimRts.h"
# include "ParallelRts.h"
/* tell the stats department that we've started a GC */
stat_startGC();
+ /* Init stats and print par specific (timing) info */
+ PAR_TICKY_PAR_START();
+
/* attribute any costs to CCS_GC */
#ifdef PROFILING
prev_CCS = CCCS;
/* Mark the entries in the GALA table of the parallel system */
markLocalGAs(major_gc);
+ /* Mark all entries on the list of pending fetches */
+ markPendingFetches(major_gc);
#endif
/* Mark the weak pointer list, and prepare to detect dead weak
/* ok, GC over: tell the stats department what happened. */
stat_endGC(allocated, collected, live, copied, N);
+
+ //PAR_TICKY_TP();
}
//@node Weak Pointers, Evacuation, Garbage Collect
/* not evaluated yet */
break;
+#if defined(PAR)
+ /* a copy of the top-level cases below */
+ case RBH: // cf. BLACKHOLE_BQ
+ {
+ //StgInfoTable *rip = get_closure_info(q, &size, &ptrs, &nonptrs, &vhs, str);
+ to = copy(q,BLACKHOLE_sizeW(),stp);
+ //ToDo: derive size etc from reverted IP
+ //to = copy(q,size,stp);
+ // recordMutable((StgMutClosure *)to);
+ return to;
+ }
+
+ case BLOCKED_FETCH:
+ ASSERT(sizeofW(StgBlockedFetch) >= MIN_NONUPD_SIZE);
+ to = copy(q,sizeofW(StgBlockedFetch),stp);
+ return to;
+
+# ifdef DIST
+ case REMOTE_REF:
+# endif
+ case FETCH_ME:
+ ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
+ to = copy(q,sizeofW(StgFetchMe),stp);
+ return to;
+
+ case FETCH_ME_BQ:
+ ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
+ to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp);
+ return to;
+#endif
+
default:
barf("evacuate: THUNK_SELECTOR: strange selectee %d",
(int)(selectee_info->type));
q, info_type(q), to, info_type(to)));
return to;
+# ifdef DIST
+ case REMOTE_REF:
+# endif
case FETCH_ME:
ASSERT(sizeofW(StgBlockedFetch) >= MIN_UPD_SIZE);
to = copy(q,sizeofW(StgFetchMe),stp);
break;
}
+#ifdef DIST
+ case REMOTE_REF:
+#endif
case FETCH_ME:
- IF_DEBUG(gc,
- belch("@@ scavenge: HWL claims nothing to do for %p (%s)",
- p, info_type((StgClosure *)p)));
p += sizeofW(StgFetchMe);
break; // nothing to do in this case
break;
}
+#ifdef DIST
+ case REMOTE_REF:
+ barf("scavenge_mutable_list: REMOTE_REF %d", (int)(info->type));
+#endif
case FETCH_ME:
p += sizeofW(StgFetchMe);
break; // nothing to do in this case
/* -----------------------------------------------------------------------------
- * $Id: Linker.c,v 1.32 2001/02/28 10:03:42 sewardj Exp $
+ * $Id: Linker.c,v 1.33 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 2000
*
} RtsSymbolVal;
+#if !defined(PAR)
+#define Maybe_ForeignObj SymX(mkForeignObjzh_fast)
+
+#define Maybe_Stable_Names SymX(mkWeakzh_fast) \
+ SymX(makeStableNamezh_fast) \
+ SymX(finalizzeWeakzh_fast)
+#else
+/* These are not available in GUM!!! -- HWL */
+#define Maybe_ForeignObj
+#define Maybe_Stable_Names
+#endif
+
+
#define RTS_SYMBOLS \
SymX(MainRegTable) \
Sym(stg_gc_enter_1) \
SymX(stackOverflow) \
SymX(int2Integerzh_fast) \
SymX(word2Integerzh_fast) \
- SymX(mkForeignObjzh_fast) \
+ Maybe_ForeignObj \
SymX(__encodeDouble) \
SymX(decodeDoublezh_fast) \
SymX(decodeFloatzh_fast) \
SymX(orIntegerzh_fast) \
SymX(xorIntegerzh_fast) \
SymX(complementIntegerzh_fast) \
- SymX(mkWeakzh_fast) \
- SymX(makeStableNamezh_fast) \
- SymX(finalizzeWeakzh_fast) \
+ Maybe_Stable_Names \
SymX(blockAsyncExceptionszh_fast) \
SymX(unblockAsyncExceptionszh_fast) \
SymX(isDoubleNaN) \
/* -----------------------------------------------------------------------------
- * $Id: Main.c,v 1.26 2001/02/09 12:40:22 simonmar Exp $
+ * $Id: Main.c,v 1.27 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team 1998-2000
*
#endif
#ifdef PAR
-# include "ParInit.h"
# include "Parallel.h"
+# include "ParallelRts.h"
# include "LLC.h"
#endif
# endif
if (IAmMainThread == rtsTrue) {
- fprintf(stderr, "Main Thread Started ...\n");
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== [%x] Main Thread Started ...\n", mytid));
/* ToDo: Dump event for the main thread */
status = rts_evalIO((HaskellObj)mainIO_closure, NULL);
mytid));
/* all non-main threads enter the scheduler without work */
- status = rts_evalNothing((StgClosure*)NULL);
+ taskStart();
+ status = Success; // declare victory (see shutdownParallelSystem)
}
# elif defined(GRAN)
# endif /* !PAR && !GRAN */
- // ToDo: update for parallel execution
/* check the status of the entire Haskell computation */
switch (status) {
case Deadlock:
case Success:
exit_status = EXIT_SUCCESS;
break;
+#if defined(PAR)
+ case NoStatus:
+ prog_belch("main thread PE killed; probably due to failure of another PE; check /tmp/pvml...");
+ exit_status = EXIT_KILLED;
+ break;
+#endif
default:
barf("main thread completed with invalid status");
}
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.73 2001/02/28 00:01:04 qrczak Exp $
+ * $Id: PrimOps.hc,v 1.74 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
-------------------------------------------------------------------------- */
-#ifndef PAR
FN_(mkForeignObjzh_fast)
{
/* R1.p = ptr to foreign object,
RET_P(result);
FE_
}
-#endif
/* These two are out-of-line for the benefit of the NCG */
FN_(unsafeThawArrayzh_fast)
Weak Pointer Primitives
-------------------------------------------------------------------------- */
-#ifndef PAR
-
FN_(mkWeakzh_fast)
{
/* R1.p = key
FE_
}
-#endif /* !PAR */
-
/* -----------------------------------------------------------------------------
Arbitrary-precision Integer operations.
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.37 2001/02/15 14:30:07 sewardj Exp $
+ * $Id: Printer.c,v 1.38 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1994-2000.
*
#include "Printer.h"
+#if defined(GRAN) || defined(PAR)
// HWL: explicit fixed header size to make debugging easier
int fixed_hs = FIXED_HS, itbl_sz = sizeofW(StgInfoTable),
uf_sz=sizeofW(StgUpdateFrame), sf_sz=sizeofW(StgSeqFrame);
+#endif
/* --------------------------------------------------------------------------
* local function decls
fprintf(stderr,")\n");
break;
+#ifdef DIST
+ case REMOTE_REF:
+ fprintf(stderr,"REMOTE_REF(");
+ printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
+ fprintf(stderr,")\n");
+ break;
+#endif
+
case FETCH_ME_BQ:
fprintf(stderr,"FETCH_ME_BQ(");
// printGA((globalAddr *)stgCast(StgFetchMe*,obj)->ga);
"FETCH_ME_BQ", /* 62 */
"RBH", /* 63 */
"EVACUATED", /* 64 */
- "N_CLOSURE_TYPES" /* 65 */
+ "REMOTE_REF", /* 65 */
+ "N_CLOSURE_TYPES" /* 66 */
};
char *
/* Causing linking trouble on Win32 plats, so I'm
disabling this for now.
*/
-#if defined(HAVE_BFD_H) && !defined(_WIN32)
+#if defined(HAVE_BFD_H) && !defined(_WIN32) && !defined(PAR) && !defined(GRAN)
#include <bfd.h>
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.25 2001/02/08 14:36:21 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.26 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-2001
*
return waitThread(tso, ret);
}
-#if defined(PAR)
-/*
- Needed in the parallel world for non-Main PEs, which do not get a piece
- of work to start with --- they have to humbly ask for it
-*/
-
-SchedulerStatus
-rts_evalNothing(unsigned int stack_size)
-{
- /* ToDo: propagate real SchedulerStatus back to caller */
- scheduleThread(END_TSO_QUEUE);
- return Success;
-}
-#endif
-
/* Convenience function for decoding the returned status. */
void
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.37 2001/03/14 11:18:18 sewardj Exp $
+ * $Id: RtsFlags.c,v 1.38 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
char *par_debug_opts_strs[] = {
"DEBUG (-qDv, -qD1): verbose; be generally verbose with parallel related stuff.\n",
- "DEBUG (-qDt, -qD2): trace; trace messages.\n",
+ "DEBUG (-qDq, -qD2): bq; print blocking queues.\n",
"DEBUG (-qDs, -qD4): schedule; scheduling of parallel threads.\n",
"DEBUG (-qDe, -qD8): free; free messages.\n",
"DEBUG (-qDr, -qD16): resume; resume messages.\n",
//"DEBUG (-qDo, -qD512): forward; forwarding messages to other PEs.\n",
"DEBUG (-qDl, -qD256): tables; print internal LAGA etc tables.\n",
"DEBUG (-qDo, -qD512): packet; packets and graph structures when packing.\n",
- "DEBUG (-qDp, -qD1024): pack; packing and unpacking graphs.\n"
+ "DEBUG (-qDp, -qD1024): pack; packing and unpacking graphs.\n",
+ "DEBUG (-qDz, -qD2048): paranoia; ridiculously detailed output (excellent for filling a partition).\n"
};
/* one character codes for the available debug options */
char par_debug_opts_flags[] = {
- 'v', 't', 's', 'e', 'r', 'w', 'F', 'f', 'l', 'o', 'p'
+ 'v', 'q', 's', 'e', 'r', 'w', 'F', 'f', 'l', 'o', 'p', 'z'
};
/* prefix strings printed with the debug messages of the corresponding type */
char *par_debug_opts_prefix[] = {
" ", /* verbose */
- "..", /* trace */
+ "##", /* bq */
"--", /* schedule */
"!!", /* free */
"[]", /* resume */
"", /* tables */
"**", /* packet */
"**" /* pack */
+ ":(" /* paranoia */
};
#endif /* PAR */
RtsFlags.GcFlags.heapSizeSuggestion = 0; /* none */
RtsFlags.GcFlags.pcFreeHeap = 3; /* 3% */
RtsFlags.GcFlags.oldGenFactor = 2;
+#if defined(PAR)
+ /* A hack currently needed for GUM -- HWL */
+ RtsFlags.GcFlags.generations = 1;
+ RtsFlags.GcFlags.steps = 2;
+ RtsFlags.GcFlags.squeezeUpdFrames = rtsFalse;
+#else
RtsFlags.GcFlags.generations = 2;
RtsFlags.GcFlags.steps = 2;
-
RtsFlags.GcFlags.squeezeUpdFrames = rtsTrue;
+#endif
#ifdef RTS_GTK_FRONTPANEL
RtsFlags.GcFlags.frontpanel = rtsFalse;
#endif
#ifdef PAR
RtsFlags.ParFlags.ParStats.Full = rtsFalse;
+ RtsFlags.ParFlags.ParStats.Suppressed = rtsFalse;
RtsFlags.ParFlags.ParStats.Binary = rtsFalse;
RtsFlags.ParFlags.ParStats.Sparks = rtsFalse;
RtsFlags.ParFlags.ParStats.Heap = rtsFalse;
RtsFlags.ParFlags.ParStats.Global = rtsFalse;
RtsFlags.ParFlags.outputDisabled = rtsFalse;
+#ifdef DIST
+ RtsFlags.ParFlags.doFairScheduling = rtsTrue; /* fair sched by def */
+#else
+ RtsFlags.ParFlags.doFairScheduling = rtsFalse; /* unfair sched by def */
+#endif
RtsFlags.ParFlags.packBufferSize = 1024;
-
+ RtsFlags.ParFlags.thunksToPack = 1; /* 0 ... infinity; */
+ RtsFlags.ParFlags.globalising = 1; /* 0 ... everything */
RtsFlags.ParFlags.maxThreads = 1024;
RtsFlags.ParFlags.maxFishes = MAX_FISHES;
RtsFlags.ParFlags.fishDelay = FISH_DELAY;
# define SMP_BUILD_ONLY(x) x
#else
# define SMP_BUILD_ONLY(x) \
-prog_belch("GHC not built for: -parallel"); \
+prog_belch("GHC not built for: -smp"); \
error = rtsTrue;
#endif
stats:
#ifdef PAR
- /* Opening all those files would almost certainly fail... */
- RtsFlags.ParFlags.ParStats.Full = rtsTrue;
- RtsFlags.GcFlags.statsFile = stderr; /* temporary; ToDo: rm */
+ /* Opening all those files would almost certainly fail... */
+ // RtsFlags.ParFlags.ParStats.Full = rtsTrue;
+ RtsFlags.GcFlags.statsFile = stderr; /* temporary; ToDo: rm */
#else
RtsFlags.GcFlags.statsFile
= open_stats_file(arg, *argc, argv,
case 'q':
PAR_BUILD_ONLY(
- process_par_option(arg, rts_argc, rts_argv, &error);
+ process_par_option(arg, rts_argc, rts_argv, &error);
) break;
/* =========== GRAN =============================== */
case 'b':
GRAN_BUILD_ONLY(
- process_gran_option(arg, rts_argc, rts_argv, &error);
+ process_gran_option(arg, rts_argc, rts_argv, &error);
) break;
/* =========== TICKY ============================== */
static void
process_par_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error)
{
- if (rts_argv[arg][1] != 'q') /* All GUM options start with -q */
+
+ if (rts_argv[arg][1] != 'q') { /* All GUM options start with -q */
+ belch("Warning: GUM option does not start with -q: %s", rts_argv[arg]);
return;
-
+ }
+
/* Communication and task creation cost parameters */
switch(rts_argv[arg][2]) {
case 'e': /* -qe<n> ... allow <n> local sparks */
RtsFlags.ParFlags.maxFishes));
break;
-
- case 'd':
+ case 'F':
if (rts_argv[arg][3] != '\0') {
RtsFlags.ParFlags.fishDelay
= strtol(rts_argv[arg]+3, (char **) NULL, 10);
} else {
- belch("setupRtsFlags: missing fish delay time for -qd\n");
+ belch("setupRtsFlags: missing fish delay time for -qF\n");
*error = rtsTrue;
}
IF_PAR_DEBUG(verbose,
- belch("-qd<n>: fish delay time %d",
+ belch("-qF<n>: fish delay time %d us",
RtsFlags.ParFlags.fishDelay));
break;
belch("-qO: output disabled"));
break;
+ case 'g': /* -qg<n> ... globalisation scheme */
+ if (rts_argv[arg][3] != '\0') {
+ RtsFlags.ParFlags.globalising = decode(rts_argv[arg]+3);
+ } else {
+ belch("setupRtsFlags: missing identifier for globalisation scheme (for -qg)\n");
+ *error = rtsTrue;
+ }
+ IF_PAR_DEBUG(verbose,
+ belch("-qg<n>: globalisation scheme set to %d",
+ RtsFlags.ParFlags.globalising));
+ break;
+
+ case 'h': /* -qh<n> ... max number of thunks (except root) in packet */
+ if (rts_argv[arg][3] != '\0') {
+ RtsFlags.ParFlags.thunksToPack = decode(rts_argv[arg]+3);
+ } else {
+ belch("setupRtsFlags: missing number of thunks per packet (for -qh)\n");
+ *error = rtsTrue;
+ }
+ IF_PAR_DEBUG(verbose,
+ belch("-qh<n>: thunks per packet set to %d",
+ RtsFlags.ParFlags.thunksToPack));
+ break;
+
case 'P': /* -qP for writing a log file */
- RtsFlags.ParFlags.ParStats.Full = rtsTrue;
+ //RtsFlags.ParFlags.ParStats.Full = rtsFalse;
/* same encoding as in GranSim after -bP */
switch(rts_argv[arg][3]) {
- case '\0': break; // nothing special, just an ordinary profile
- //case '0': RtsFlags.ParFlags.ParStats.Suppressed = rtsTrue;
- // break;
+ case '\0': RtsFlags.ParFlags.ParStats.Full = rtsTrue;
+ break; // nothing special, just an ordinary profile
+ case '0': RtsFlags.ParFlags.ParStats.Suppressed = rtsTrue;
+ RtsFlags.ParFlags.ParStats.Full = rtsFalse;
+ break;
case 'b': RtsFlags.ParFlags.ParStats.Binary = rtsTrue;
break;
case 's': RtsFlags.ParFlags.ParStats.Sparks = rtsTrue;
// break;
case 'n': RtsFlags.ParFlags.ParStats.NewLogfile = rtsTrue;
break;
- case 'g': RtsFlags.ParFlags.ParStats.Global = rtsTrue;
+ case 'g':
+# if defined(PAR_TICKY)
+ RtsFlags.ParFlags.ParStats.Global = rtsTrue;
+# else
+ fprintf(stderr,"-qPg is only possible for a PAR_TICKY RTS, which this is not");
+ stg_exit(EXIT_FAILURE);
+# endif
break;
default: barf("Unknown option -qP%c", rts_argv[arg][2]);
}
if (rts_argv[arg][3] != '\0') {
RtsFlags.ParFlags.packBufferSize = decode(rts_argv[arg]+3);
} else {
- belch("setupRtsFlags: missing size of PackBuffer (for -Q)\n");
- error = rtsTrue;
+ belch("setupRtsFlags: missing size of PackBuffer (for -qQ)\n");
+ *error = rtsTrue;
}
IF_PAR_DEBUG(verbose,
belch("-qQ<n>: pack buffer size set to %d",
RtsFlags.ParFlags.packBufferSize));
break;
+ case 'R':
+ RtsFlags.ParFlags.doFairScheduling = rtsTrue;
+ IF_PAR_DEBUG(verbose,
+ belch("-qR: fair-ish scheduling"));
+ break;
+
# if defined(DEBUG)
case 'w':
if (rts_argv[arg][3] != '\0') {
break;
# endif
default:
- belch("Unknown option -q%c", rts_argv[arg][2]);
+ belch("Unknown option -q%c (%d opts in total)",
+ rts_argv[arg][2], *rts_argc);
break;
} /* switch */
}
fprintf(stderr, par_debug_opts_strs[i]);
switch (i) {
case 0: RtsFlags.ParFlags.Debug.verbose = rtsTrue; break;
- case 1: RtsFlags.ParFlags.Debug.trace = rtsTrue; break;
+ case 1: RtsFlags.ParFlags.Debug.bq = rtsTrue; break;
case 2: RtsFlags.ParFlags.Debug.schedule = rtsTrue; break;
case 3: RtsFlags.ParFlags.Debug.free = rtsTrue; break;
case 4: RtsFlags.ParFlags.Debug.resume = rtsTrue; break;
case 7: RtsFlags.ParFlags.Debug.fish = rtsTrue; break;
case 8: RtsFlags.ParFlags.Debug.tables = rtsTrue; break;
case 9: RtsFlags.ParFlags.Debug.packet = rtsTrue; break;
- case 10: RtsFlags.ParFlags.Debug.pack = rtsTrue; break;
- default: barf("set_par_debug_options: only %d debug options expected");
+ case 10: RtsFlags.ParFlags.Debug.pack = rtsTrue; break;
+ case 11: RtsFlags.ParFlags.Debug.paranoia = rtsTrue; break;
+ default: barf("set_par_debug_options: only %d debug options expected",
+ MAX_PAR_DEBUG_OPTION);
} /* switch */
} /* if */
}
if ((n>>i)&1) {
fprintf(stderr, debug_opts_strs[i]);
switch (i) {
- case 0: RtsFlags.DebugFlags.scheduler = rtsTrue; break;
- case 1: RtsFlags.DebugFlags.evaluator = rtsTrue; break;
- case 2: RtsFlags.DebugFlags.codegen = rtsTrue; break;
- case 3: RtsFlags.DebugFlags.weak = rtsTrue; break;
- case 4: RtsFlags.DebugFlags.gccafs = rtsTrue; break;
- case 5: RtsFlags.DebugFlags.gc = rtsTrue; break;
- case 6: RtsFlags.DebugFlags.block_alloc = rtsTrue; break;
- case 7: RtsFlags.DebugFlags.sanity = rtsTrue; break;
- case 8: RtsFlags.DebugFlags.stable = rtsTrue; break;
- case 9: RtsFlags.DebugFlags.prof = rtsTrue; break;
- case 10: RtsFlags.DebugFlags.gran = rtsTrue; break;
- case 11: RtsFlags.DebugFlags.par = rtsTrue; break;
- case 12: RtsFlags.DebugFlags.linker = rtsTrue; break;
+ case 0: RtsFlags.DebugFlags.scheduler = rtsTrue; break;
+ case 1: RtsFlags.DebugFlags.evaluator = rtsTrue; break;
+ case 2: RtsFlags.DebugFlags.codegen = rtsTrue; break;
+ case 3: RtsFlags.DebugFlags.weak = rtsTrue; break;
+ case 4: RtsFlags.DebugFlags.gccafs = rtsTrue; break;
+ case 5: RtsFlags.DebugFlags.gc = rtsTrue; break;
+ case 6: RtsFlags.DebugFlags.block_alloc = rtsTrue; break;
+ case 7: RtsFlags.DebugFlags.sanity = rtsTrue; break;
+ case 8: RtsFlags.DebugFlags.stable = rtsTrue; break;
+ case 9: RtsFlags.DebugFlags.prof = rtsTrue; break;
+ case 10: RtsFlags.DebugFlags.gran = rtsTrue; break;
+ case 11: RtsFlags.DebugFlags.par = rtsTrue; break;
+ default: barf("set_debug_options: only %d debug options expected",
+ MAX_DEBUG_OPTION);
} /* switch */
} /* if */
}
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.31 2001/03/14 11:18:18 sewardj Exp $
+ * $Id: RtsFlags.h,v 1.32 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
/* currently the same as GRAN_STATS_FLAGS */
struct PAR_STATS_FLAGS {
rtsBool Full; /* Full .gr profile (rtsTrue) or only END events? */
- // rtsBool Suppressed; /* No .gr profile at all */
+ rtsBool Suppressed; /* No .gr profile at all */
rtsBool Binary; /* Binary profile? (not yet implemented) */
rtsBool Sparks; /* Info on sparks in profile? */
rtsBool Heap; /* Info on heap allocs in profile? */
struct PAR_DEBUG_FLAGS {
/* flags to control debugging output in various subsystems */
rtsBool verbose : 1; /* 1 */
- rtsBool trace : 1; /* 2 */
+ rtsBool bq : 1; /* 2 */
rtsBool schedule : 1; /* 4 */
rtsBool free : 1; /* 8 */
rtsBool resume : 1; /* 16 */
rtsBool tables : 1; /* 256 */
rtsBool packet : 1; /* 512 */
rtsBool pack : 1; /* 1024 */
+ rtsBool paranoia : 1; /* 2048 */
};
-#define MAX_PAR_DEBUG_OPTION 10
+#define MAX_PAR_DEBUG_OPTION 11
#define PAR_DEBUG_MASK(n) ((nat)(ldexp(1,n)))
#define MAX_PAR_DEBUG_MASK ((nat)(ldexp(1,(MAX_PAR_DEBUG_OPTION+1))-1))
struct PAR_STATS_FLAGS ParStats; /* profile and stats output */
struct PAR_DEBUG_FLAGS Debug; /* debugging options */
rtsBool outputDisabled; /* Disable output for performance purposes */
+ rtsBool doFairScheduling; /* Fair-ish scheduling (round robin; no time-slices) */
nat packBufferSize;
+ nat thunksToPack; /* number of thunks in packet + 1 */
+ nat globalising; /* globalisation scheme */
nat maxLocalSparks; /* spark pool size */
nat maxThreads; /* thread pool size */
nat maxFishes; /* max number of active fishes */
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.49 2001/02/11 17:51:08 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.50 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
#endif
#if defined(GRAN)
-#include "GranSimRts.h"
-#include "ParallelRts.h"
+# include "GranSimRts.h"
+#endif
+
+#if defined(GRAN) || defined(PAR)
+# include "ParallelRts.h"
#endif
#if defined(PAR)
-#include "ParInit.h"
-#include "Parallel.h"
-#include "LLC.h"
+# include "Parallel.h"
+# include "LLC.h"
#endif
/*
static int rts_has_started_up = 0;
#if defined(PAR)
-static ullong startTime = 0;
+ullong startTime = 0;
#endif
EXTFUN(__init_Prelude);
stat_startInit();
#ifdef PAR
-/*
- * The parallel system needs to be initialised and synchronised before
- * the program is run.
- */
- fprintf(stderr, "startupHaskell: argv[0]=%s\n", argv[0]);
- if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
- IAmMainThread = rtsTrue;
- argv++; argc--; /* Strip off flag argument */
- // IF_PAR_DEBUG(verbose,
- fprintf(stderr, "[%x] I am Main Thread\n", mytid);
+ /*
+ * The parallel system needs to be initialised and synchronised before
+ * the program is run.
+ */
+ startupParallelSystem(argv);
+
+ if (*argv[0] == '-') { /* Strip off mainPE flag argument */
+ argv++;
+ argc--;
}
- /*
- * Grab the number of PEs out of the argument vector, and
- * eliminate it from further argument processing.
- */
- nPEs = atoi(argv[1]);
- argv[1] = argv[0];
+
+ argv[1] = argv[0]; /* ignore the nPEs argument */
argv++; argc--;
- initEachPEHook(); /* HWL: hook to be execed on each PE */
#endif
/* Set the RTS flags to default values. */
#if defined(PAR)
/* NB: this really must be done after processing the RTS flags */
- fprintf(stderr, "Synchronising system (%d PEs)\n", nPEs);
- SynchroniseSystem(); // calls initParallelSystem etc
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== Synchronising system (%d PEs)\n", nPEs));
+ synchroniseSystem(); // calls initParallelSystem etc
#endif /* PAR */
/* initialise scheduler data structures (needs to be done before
{
OnExitHook();
shutdownHaskell();
+#if defined(PAR)
+ /* really exit (stg_exit() would call shutdownParallelSystem() again) */
+ exit(n);
+#else
stg_exit(n);
+#endif;
}
void
resetNonBlockingFd(2);
#if defined(PAR)
+ /* controlled exit; good thread! */
shutdownParallelSystem(0);
+
+ /* global statistics in parallel system */
+ PAR_TICKY_PAR_END();
#endif
/* stop timing the shutdown, we're about to print stats */
#endif
rts_has_started_up=0;
-
}
/*
* called from STG-land to exit the program
*/
+#ifdef PAR
+static int exit_started=rtsFalse;
+#endif
+
void
stg_exit(I_ n)
-{
-#if 0 /* def PAR */
- par_exit(n);
-#else
- exit(n);
+{
+#ifdef PAR
+ /* HACK: avoid a loop when exiting due to a stupid error */
+ if (exit_started)
+ return;
+ exit_started=rtsTrue;
+
+ IF_PAR_DEBUG(verbose, fprintf(stderr,"==-- stg_exit %d on [%x]...", n, mytid));
+ shutdownParallelSystem(n);
#endif
+ exit(n);
}
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.26 2001/02/09 13:09:16 simonmar Exp $
+ * $Id: Sanity.c,v 1.27 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
ASSERT(LOOKS_LIKE_PTR((((StgBlockedFetch *)p)->node)));
return sizeofW(StgBlockedFetch); // see size used in evacuate()
+#ifdef DIST
+ case REMOTE_REF:
+ return sizeofW(StgFetchMe);
+#endif //DIST
+
case FETCH_ME:
ASSERT(LOOKS_LIKE_GA(((StgFetchMe *)p)->ga));
return sizeofW(StgFetchMe); // see size used in evacuate()
xxx);
}
+#if defined(PAR)
/*
Check heap between start and end. Used after unpacking graphs.
*/
extern void
checkHeapChunk(StgPtr start, StgPtr end)
{
+ extern globalAddr *LAGAlookup(StgClosure *addr);
+ StgPtr p;
+ nat size;
+
+ for (p=start; p<end; p+=size) {
+ ASSERT(LOOKS_LIKE_GHC_INFO((void*)*p));
+ if (get_itbl((StgClosure*)p)->type == FETCH_ME &&
+ *(p+1) == 0x0000eeee /* ie. unpack garbage (see SetGAandCommonUp) */) {
+ /* if it's a FM created during unpack and commoned up, it's not global */
+ ASSERT(LAGAlookup((StgClosure*)p)==NULL);
+ size = sizeofW(StgFetchMe);
+ } else if (get_itbl((StgClosure*)p)->type == IND) {
+ *(p+2) = 0x0000ee11; /* mark slop in IND as garbage */
+ size = MIN_UPD_SIZE;
+ } else {
+ size = checkClosure(stgCast(StgClosure*,p));
+ /* This is the smallest size of closure that can live in the heap. */
+ ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
+ }
+ }
+}
+#else /* !PAR */
+extern void
+checkHeapChunk(StgPtr start, StgPtr end)
+{
StgPtr p;
nat size;
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
}
}
+#endif
//@cindex checkChain
extern void
ASSERT(!gala->preferred || gala == gala0);
ASSERT(LOOKS_LIKE_GHC_INFO(((StgClosure *)gala->la)->header.info));
ASSERT(gala->next!=gala); // detect direct loops
- /*
if ( check_closures ) {
checkClosure(stgCast(StgClosure*,gala->la));
}
- */
}
for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
/* -----------------------------------------------------------------------------
- * $Id: Sanity.h,v 1.7 2000/12/11 12:37:00 simonmar Exp $
+ * $Id: Sanity.h,v 1.8 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
* ---------------------------------------------------------------------------*/
#ifdef DEBUG
+
+# if defined(PAR)
+# define PVM_PE_MASK 0xfffc0000
+# define MAX_PVM_PES MAX_PES
+# define MAX_PVM_TIDS MAX_PES
+# define MAX_SLOTS 100000
+# endif
+
/* debugging routines */
extern void checkHeap ( bdescr *bd, StgPtr start );
extern void checkHeapChunk ( StgPtr start, StgPtr end );
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.93 2001/03/02 16:15:53 simonmar Exp $
+ * $Id: Schedule.c,v 1.94 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-2000
*
* Scheduler
*
- * The main scheduling code in GranSim is quite different from that in std
- * (concurrent) Haskell: while concurrent Haskell just iterates over the
- * threads in the runnable queue, GranSim is event driven, i.e. it iterates
- * over the events in the global event queue. -- HWL
+ * Different GHC ways use this scheduler quite differently (see comments below)
+ * Here is the global picture:
+ *
+ * WAY Name CPP flag What's it for
+ * --------------------------------------
+ * mp GUM PAR Parallel execution on a distributed memory machine
+ * s SMP SMP Parallel execution on a shared memory machine
+ * mg GranSim GRAN Simulation of parallel execution
+ * md GUM/GdH DIST Distributed execution (based on GUM)
* --------------------------------------------------------------------------*/
//@node Main scheduling code, , ,
//@section Main scheduling code
-/* Version with scheduler monitor support for SMPs.
+/*
+ * Version with scheduler monitor support for SMPs (WAY=s):
This design provides a high-level API to create and schedule threads etc.
as documented in the SMP design document.
In a non-SMP build, there is one global capability, namely MainRegTable.
SDM & KH, 10/99
+
+ * Version with support for distributed memory parallelism aka GUM (WAY=mp):
+
+ The main scheduling loop in GUM iterates until a finish message is received.
+ In that case a global flag @receivedFinish@ is set and this instance of
+ the RTS shuts down. See ghc/rts/parallel/HLComms.c:processMessages()
+ for the handling of incoming messages, such as PP_FINISH.
+ Note that in the parallel case we have a system manager that coordinates
+ different PEs, each of which are running one instance of the RTS.
+ See ghc/rts/parallel/SysMan.c for the main routine of the parallel program.
+ From this routine processes executing ghc/rts/Main.c are spawned. -- HWL
+
+ * Version with support for simulating parallel execution aka GranSim (WAY=mg):
+
+ The main scheduling code in GranSim is quite different from that in std
+ (concurrent) Haskell: while concurrent Haskell just iterates over the
+ threads in the runnable queue, GranSim is event driven, i.e. it iterates
+ over the events in the global event queue. -- HWL
*/
//@menu
#if defined(PAR)
StgTSO *LastTSO;
rtsTime TimeOfLastYield;
+rtsBool emitSchedule = rtsTrue;
#endif
#if DEBUG
};
#endif
+#ifdef PAR
+StgTSO * createSparkThread(rtsSpark spark);
+StgTSO * activateSpark (rtsSpark spark);
+#endif
+
/*
* The thread state for the main thread.
// ToDo: check whether not needed any more
rtsSpark spark;
StgTSO *tso;
GlobalTaskId pe;
+ rtsBool receivedFinish = rtsFalse;
+# if defined(DEBUG)
+ nat tp_size, sp_size; // stats only
+# endif
#endif
rtsBool was_interrupted = rtsFalse;
#elif defined(PAR)
- while (!GlobalStopPending) { /* GlobalStopPending set in par_exit */
-
+ while (!receivedFinish) { /* set by processMessages */
+ /* when receiving PP_FINISH message */
#else
while (1) {
for (; n > 0; n--) {
StgClosure *spark;
- spark = findSpark();
+ spark = findSpark(rtsFalse);
if (spark == NULL) {
break; /* no more sparks in the pool */
} else {
/* I'd prefer this to be done in activateSpark -- HWL */
/* tricky - it needs to hold the scheduler lock and
* not try to re-acquire it -- SDM */
- StgTSO *tso;
- tso = createThread_(RtsFlags.GcFlags.initialStkSize, rtsTrue);
- pushClosure(tso,spark);
- PUSH_ON_RUN_QUEUE(tso);
-#ifdef PAR
- advisory_thread_count++;
-#endif
-
+ createSparkThread(spark);
IF_DEBUG(scheduler,
- sched_belch("turning spark of closure %p into a thread",
+ sched_belch("==^^ turning spark of closure %p into a thread",
(StgClosure *)spark));
}
}
main_threads = NULL;
}
}
+#elif defined(PAR)
+ /* ToDo: add deadlock detection in GUM (similar to SMP) -- HWL */
#else /* ! SMP */
if (blocked_queue_hd == END_TSO_QUEUE
&& run_queue_hd == END_TSO_QUEUE
if (!RtsFlags.GranFlags.Light)
handleIdlePEs();
- IF_DEBUG(gran, fprintf(stderr, "GRAN: switch by event-type\n"))
+ IF_DEBUG(gran, fprintf(stderr, "GRAN: switch by event-type\n"));
/* main event dispatcher in GranSim */
switch (event->evttype) {
IF_DEBUG(gran,
fprintf(stderr, "GRAN: About to run current thread, which is\n");
- G_TSO(t,5))
+ G_TSO(t,5));
context_switch = 0; // turned on via GranYield, checking events and time slice
procStatus[CurrentProc] = Busy;
#elif defined(PAR)
-
if (PendingFetches != END_BF_QUEUE) {
processFetches();
}
/* ToDo: phps merge with spark activation above */
/* check whether we have local work and send requests if we have none */
- if (run_queue_hd == END_TSO_QUEUE) { /* no runnable threads */
+ if (EMPTY_RUN_QUEUE()) { /* no runnable threads */
/* :-[ no local threads => look out for local sparks */
/* the spark pool for the current PE */
pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
* to turn one of those pending sparks into a
* thread...
*/
-
- spark = findSpark(); /* get a spark */
+
+ spark = findSpark(rtsFalse); /* get a spark */
if (spark != (rtsSpark) NULL) {
tso = activateSpark(spark); /* turn the spark into a thread */
IF_PAR_DEBUG(schedule,
spark_queue_len(pool)));
goto next_thread;
}
- } else
+ }
+
+ /* If we still have no work we need to send a FISH to get a spark
+ from another PE
+ */
+ if (EMPTY_RUN_QUEUE()) {
/* =8-[ no local sparks => look for work on other PEs */
- {
/*
* We really have absolutely no work. Send out a fish
* (there may be some out there already), and wait for
* we're hoping to see. (Of course, we still have to
* respond to other types of messages.)
*/
- if (//!fishing &&
- outstandingFishes < RtsFlags.ParFlags.maxFishes ) { // &&
- // (last_fish_arrived_at+FISH_DELAY < CURRENT_TIME)) {
- /* fishing set in sendFish, processFish;
+ TIME now = msTime() /*CURRENT_TIME*/;
+ IF_PAR_DEBUG(verbose,
+ belch("-- now=%ld", now));
+ IF_PAR_DEBUG(verbose,
+ if (outstandingFishes < RtsFlags.ParFlags.maxFishes &&
+ (last_fish_arrived_at!=0 &&
+ last_fish_arrived_at+RtsFlags.ParFlags.fishDelay > now)) {
+ belch("--$$ delaying FISH until %ld (last fish %ld, delay %ld, now %ld)",
+ last_fish_arrived_at+RtsFlags.ParFlags.fishDelay,
+ last_fish_arrived_at,
+ RtsFlags.ParFlags.fishDelay, now);
+ });
+
+ if (outstandingFishes < RtsFlags.ParFlags.maxFishes &&
+ (last_fish_arrived_at==0 ||
+ (last_fish_arrived_at+RtsFlags.ParFlags.fishDelay <= now))) {
+ /* outstandingFishes is set in sendFish, processFish;
avoid flooding system with fishes via delay */
pe = choosePE();
sendFish(pe, mytid, NEW_FISH_AGE, NEW_FISH_HISTORY,
NEW_FISH_HUNGER);
+
+ // Global statistics: count no. of fishes
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fish_mess++;
+ }
}
-
- processMessages();
+
+ receivedFinish = processMessages();
goto next_thread;
- // ReSchedule(0);
}
} else if (PacketsWaiting()) { /* Look for incoming messages */
- processMessages();
+ receivedFinish = processMessages();
}
/* Now we are sure that we have some work available */
ASSERT(run_queue_hd != END_TSO_QUEUE);
+
/* Take a thread from the run queue, if we have work */
t = POP_RUN_QUEUE(); // take_off_run_queue(END_TSO_QUEUE);
+ IF_DEBUG(sanity,checkTSO(t));
/* ToDo: write something to the log-file
if (RTSflags.ParFlags.granSimStats && !sameThread)
/* the spark pool for the current PE */
pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
- IF_DEBUG(scheduler, belch("--^^ %d sparks on [%#x] (hd=%x; tl=%x; base=%x, lim=%x)",
- spark_queue_len(pool),
- CURRENT_PROC,
- pool->hd, pool->tl, pool->base, pool->lim));
-
- IF_DEBUG(scheduler, belch("--== %d threads on [%#x] (hd=%x; tl=%x)",
- run_queue_len(), CURRENT_PROC,
- run_queue_hd, run_queue_tl));
+ IF_DEBUG(scheduler,
+ belch("--=^ %d threads, %d sparks on [%#x]",
+ run_queue_len(), spark_queue_len(pool), CURRENT_PROC));
+
+#if 1
+ if (0 && RtsFlags.ParFlags.ParStats.Full &&
+ t && LastTSO && t->id != LastTSO->id &&
+ LastTSO->why_blocked == NotBlocked &&
+ LastTSO->what_next != ThreadComplete) {
+ // if previously scheduled TSO not blocked we have to record the context switch
+ DumpVeryRawGranEvent(TimeOfLastYield, CURRENT_PROC, CURRENT_PROC,
+ GR_DESCHEDULE, LastTSO, (StgClosure *)NULL, 0, 0);
+ }
-#if 0
- if (t != LastTSO) {
+ if (RtsFlags.ParFlags.ParStats.Full &&
+ (emitSchedule /* forced emit */ ||
+ (t && LastTSO && t->id != LastTSO->id))) {
/*
we are running a different TSO, so write a schedule event to log file
NB: If we use fair scheduling we also have to write a deschedule
*/
DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
GR_SCHEDULE, t, (StgClosure *)NULL, 0, 0);
-
+ emitSchedule = rtsFalse;
}
+
#endif
#else /* !GRAN && !PAR */
/* HACK 675: if the last thread didn't yield, make sure to print a
SCHEDULE event to the log file when StgRunning the next thread, even
if it is the same one as before */
- LastTSO = t; //(ret == ThreadBlocked) ? END_TSO_QUEUE : t;
+ LastTSO = t;
TimeOfLastYield = CURRENT_TIME;
#endif
switch (ret) {
case HeapOverflow:
+#if defined(GRAN)
+ IF_DEBUG(gran,
+ DumpGranEvent(GR_DESCHEDULE, t));
+ globalGranStats.tot_heapover++;
+#elif defined(PAR)
+ // IF_DEBUG(par,
+ //DumpGranEvent(GR_DESCHEDULE, t);
+ globalParStats.tot_heapover++;
+#endif
/* make all the running tasks block on a condition variable,
* maybe set context_switch and wait till they all pile in,
* then have them wait on a GC condition variable.
threadPaused(t);
#if defined(GRAN)
ASSERT(!is_on_queue(t,CurrentProc));
+#elif defined(PAR)
+ /* Currently we emit a DESCHEDULE event before GC in GUM.
+ ToDo: either add separate event to distinguish SYSTEM time from rest
+ or just nuke this DESCHEDULE (and the following SCHEDULE) */
+ if (0 && RtsFlags.ParFlags.ParStats.Full) {
+ DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
+ GR_DESCHEDULE, t, (StgClosure *)NULL, 0, 0);
+ emitSchedule = rtsTrue;
+ }
#endif
ready_to_gc = rtsTrue;
break;
case StackOverflow:
+#if defined(GRAN)
+ IF_DEBUG(gran,
+ DumpGranEvent(GR_DESCHEDULE, t));
+ globalGranStats.tot_stackover++;
+#elif defined(PAR)
+ // IF_DEBUG(par,
+ // DumpGranEvent(GR_DESCHEDULE, t);
+ globalParStats.tot_stackover++;
+#endif
IF_DEBUG(scheduler,belch("--<< thread %ld (%p; %s) stopped, StackOverflow",
t->id, t, whatNext_strs[t->what_next]));
/* just adjust the stack for this thread, then pop it back
DumpGranEvent(GR_DESCHEDULE, t));
globalGranStats.tot_yields++;
#elif defined(PAR)
- IF_DEBUG(par,
- DumpGranEvent(GR_DESCHEDULE, t));
+ // IF_DEBUG(par,
+ // DumpGranEvent(GR_DESCHEDULE, t);
+ globalParStats.tot_yields++;
#endif
/* put the thread back on the run queue. Then, if we're ready to
* GC, check whether this is the last task to stop. If so, wake
//belch("&& Doing sanity check on all ThreadQueues (and their TSOs).");
checkThreadQsSanity(rtsTrue));
#endif
+#if defined(PAR)
+ if (RtsFlags.ParFlags.doFairScheduling) {
+ /* this does round-robin scheduling; good for concurrency */
+ APPEND_TO_RUN_QUEUE(t);
+ } else {
+ /* this does unfair scheduling; good for parallelism */
+ PUSH_ON_RUN_QUEUE(t);
+ }
+#else
+ /* this does round-robin scheduling; good for concurrency */
APPEND_TO_RUN_QUEUE(t);
+#endif
#if defined(GRAN)
/* add a ContinueThread event to actually process the thread */
new_event(CurrentProc, CurrentProc, CurrentTime[CurrentProc],
IF_GRAN_DEBUG(bq,
belch("GRAN: eventq and runnableq after adding yielded thread to queue again:");
G_EVENTQ(0);
- G_CURR_THREADQ(0))
+ G_CURR_THREADQ(0));
#endif /* GRAN */
break;
procStatus[CurrentProc] = Idle;
*/
#elif defined(PAR)
- IF_DEBUG(par,
- DumpGranEvent(GR_DESCHEDULE, t));
+ IF_DEBUG(scheduler,
+ belch("--<< thread %ld (%p; %s) stopped, blocking on node %p with BQ: ",
+ t->id, t, whatNext_strs[t->what_next], t->block_info.closure));
+ IF_PAR_DEBUG(bq,
+
+ if (t->block_info.closure!=(StgClosure*)NULL)
+ print_bq(t->block_info.closure));
/* Send a fetch (if BlockedOnGA) and dump event to log file */
blockThread(t);
- IF_DEBUG(scheduler,
- belch("--<< thread %ld (%p; %s) stopped, blocking on node %p with BQ: ",
- t->id, t, whatNext_strs[t->what_next], t->block_info.closure);
- if (t->block_info.closure!=(StgClosure*)NULL) print_bq(t->block_info.closure));
+ /* whatever we schedule next, we must log that schedule */
+ emitSchedule = rtsTrue;
#else /* !GRAN */
/* don't need to do anything. Either the thread is blocked on
#if defined(GRAN)
endThread(t, CurrentProc); // clean-up the thread
#elif defined(PAR)
+ /* For now all are advisory -- HWL */
+ //if(t->priority==AdvisoryPriority) ??
advisory_thread_count--;
- if (RtsFlags.ParFlags.ParStats.Full)
+
+# ifdef DIST
+ if(t->dist.priority==RevalPriority)
+ FinishReval(t);
+# endif
+
+ if (RtsFlags.ParFlags.ParStats.Full &&
+ !RtsFlags.ParFlags.ParStats.Suppressed)
DumpEndEvent(CURRENT_PROC, t, rtsFalse /* not mandatory */);
#endif
break;
IF_GRAN_DEBUG(bq,
fprintf(stderr, "GRAN: eventq and runnableq after Garbage collection:\n");
G_EVENTQ(0);
- G_CURR_THREADQ(0))
+ G_CURR_THREADQ(0));
#endif /* GRAN */
}
#if defined(GRAN)
*/
#endif /* GRAN */
} /* end of while(1) */
+ IF_PAR_DEBUG(verbose,
+ belch("== Leaving schedule() after having received Finish"));
}
/* ---------------------------------------------------------------------------
tso->why_blocked = NotBlocked;
tso->blocked_exceptions = NULL;
+ //tso->splim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
tso->stack_size = stack_size;
tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize)
- TSO_STRUCT_SIZEW;
*/
#endif
-#if defined(GRAN) || defined(PAR)
- DumpGranEvent(GR_START,tso);
+#if defined(GRAN)
+ if (RtsFlags.GranFlags.GranSimStats.Full)
+ DumpGranEvent(GR_START,tso);
+#elif defined(PAR)
+ if (RtsFlags.ParFlags.ParStats.Full)
+ DumpGranEvent(GR_STARTQ,tso);
+ /* HACk to avoid SCHEDULE
+ LastTSO = tso; */
#endif
/* Link the new thread on the global thread list.
tso->global_link = all_threads;
all_threads = tso;
+#if defined(DIST)
+ tso->dist.priority = MandatoryPriority; //by default that is...
+#endif
+
#if defined(GRAN)
tso->gran.pri = pri;
# if defined(DEBUG)
globalGranStats.threads_created_on_PE[CurrentProc]++;
globalGranStats.tot_sq_len += spark_queue_len(CurrentProc);
globalGranStats.tot_sq_probes++;
+#elif defined(PAR)
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ //fprintf(stderr, "Creating thread %d @ %11.2f\n", tso->id, usertime());
+ globalParStats.tot_threads_created++;
+ }
#endif
#if defined(GRAN)
return tso;
}
+#if defined(PAR)
+/* RFP:
+ all parallel thread creation calls should fall through the following routine.
+*/
+StgTSO *
+createSparkThread(rtsSpark spark)
+{ StgTSO *tso;
+ ASSERT(spark != (rtsSpark)NULL);
+ if (advisory_thread_count >= RtsFlags.ParFlags.maxThreads)
+ { threadsIgnored++;
+ barf("{createSparkThread}Daq ghuH: refusing to create another thread; no more than %d threads allowed (currently %d)",
+ RtsFlags.ParFlags.maxThreads, advisory_thread_count);
+ return END_TSO_QUEUE;
+ }
+ else
+ { threadsCreated++;
+ tso = createThread_(RtsFlags.GcFlags.initialStkSize, rtsTrue);
+ if (tso==END_TSO_QUEUE)
+ barf("createSparkThread: Cannot create TSO");
+#if defined(DIST)
+ tso->priority = AdvisoryPriority;
+#endif
+ pushClosure(tso,spark);
+ PUSH_ON_RUN_QUEUE(tso);
+ advisory_thread_count++;
+ }
+ return tso;
+}
+#endif
+
/*
Turn a spark into a thread.
ToDo: fix for SMP (needs to acquire SCHED_MUTEX!)
activateSpark (rtsSpark spark)
{
StgTSO *tso;
-
- ASSERT(spark != (rtsSpark)NULL);
- tso = createThread_(RtsFlags.GcFlags.initialStkSize, rtsTrue);
- if (tso!=END_TSO_QUEUE) {
- pushClosure(tso,spark);
- PUSH_ON_RUN_QUEUE(tso);
- advisory_thread_count++;
- if (RtsFlags.ParFlags.ParStats.Full) {
- //ASSERT(run_queue_hd == END_TSO_QUEUE); // I think ...
- IF_PAR_DEBUG(verbose,
- belch("==^^ activateSpark: turning spark of closure %p (%s) into a thread",
- (StgClosure *)spark, info_type((StgClosure *)spark)));
- }
- } else {
- barf("activateSpark: Cannot create TSO");
+ tso = createSparkThread(spark);
+ if (RtsFlags.ParFlags.ParStats.Full) {
+ //ASSERT(run_queue_hd == END_TSO_QUEUE); // I think ...
+ IF_PAR_DEBUG(verbose,
+ belch("==^^ activateSpark: turning spark of closure %p (%s) into a thread",
+ (StgClosure *)spark, info_type((StgClosure *)spark)));
}
// ToDo: fwd info on local/global spark to thread -- HWL
// tso->gran.exported = spark->exported;
* ------------------------------------------------------------------------ */
#if defined(PAR) || defined(SMP)
-void *
-taskStart( void *arg STG_UNUSED )
+void
+taskStart(void) /* ( void *arg STG_UNUSED) */
{
- rts_evalNothing(NULL);
+ scheduleThread(END_TSO_QUEUE);
}
#endif
m->link = main_threads;
main_threads = m;
- IF_DEBUG(scheduler, fprintf(stderr, "scheduler: new main thread (%d)\n",
+ IF_DEBUG(scheduler, fprintf(stderr, "== scheduler: new main thread (%d)\n",
m->tso->id));
#ifdef SMP
pthread_cond_destroy(&m->wakeup);
#endif
- IF_DEBUG(scheduler, fprintf(stderr, "scheduler: main thread (%d) finished\n",
+ IF_DEBUG(scheduler, fprintf(stderr, "== scheduler: main thread (%d) finished\n",
m->tso->id));
free(m);
new_tso_size = round_to_mblocks(new_tso_size); /* Be MBLOCK-friendly */
new_stack_size = new_tso_size - TSO_STRUCT_SIZEW;
- IF_DEBUG(scheduler, fprintf(stderr,"scheduler: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
+ IF_DEBUG(scheduler, fprintf(stderr,"== scheduler: increasing stack size from %d words to %d.\n", tso->stack_size, new_stack_size));
dest = (StgTSO *)allocate(new_tso_size);
TICK_ALLOC_TSO(new_tso_size-sizeofW(StgTSO),0);
diff = (P_)new_sp - (P_)tso->sp; /* In *words* */
dest->su = (StgUpdateFrame *) ((P_)dest->su + diff);
dest->sp = new_sp;
+ //dest->splim = (P_)dest->splim + (nat)((P_)dest - (P_)tso);
dest->stack_size = new_stack_size;
/* and relocate the update frame list */
update blocked and fetch time (depending on type of the orig closure) */
if (RtsFlags.ParFlags.ParStats.Full) {
DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
- GR_RESUME, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
+ GR_RESUMEQ, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
0, 0 /* spark_queue_len(ADVISORY_POOL) */);
+ if (EMPTY_RUN_QUEUE())
+ emitSchedule = rtsTrue;
switch (get_itbl(node)->type) {
case FETCH_ME_BQ:
case BLACKHOLE_BQ:
((StgTSO *)bqe)->par.blocktime += CURRENT_TIME-((StgTSO *)bqe)->par.blockedat;
break;
+#ifdef DIST
+ case MVAR:
+ break;
+#endif
default:
barf("{unblockOneLocked}Daq Qagh: unexpected closure in blocking queue");
}
case BLOCKED_FETCH:
/* if it's a BLOCKED_FETCH put it on the PendingFetches list */
next = bqe->link;
- bqe->link = PendingFetches;
- PendingFetches = bqe;
+ bqe->link = (StgBlockingQueueElement *)PendingFetches;
+ PendingFetches = (StgBlockedFetch *)bqe;
break;
# if defined(DEBUG)
(StgClosure *)bqe);
# endif
}
- // IF_DEBUG(scheduler,sched_belch("waking up thread %ld", tso->id));
+ IF_PAR_DEBUG(bq, fprintf(stderr, ", %p (%s)", bqe, info_type((StgClosure*)bqe)));
return next;
}
nat len = 0;
IF_GRAN_DEBUG(bq,
- belch("## AwBQ for node %p on PE %d @ %ld by TSO %d (%p): ", \
+ belch("##-_ AwBQ for node %p on PE %d @ %ld by TSO %d (%p): ", \
node, CurrentProc, CurrentTime[CurrentProc],
CurrentTSO->id, CurrentTSO));
node_loc = where_is(node);
- ASSERT(get_itbl(q)->type == TSO || // q is either a TSO or an RBHSave
+ ASSERT(q == END_BQ_QUEUE ||
+ get_itbl(q)->type == TSO || // q is either a TSO or an RBHSave
get_itbl(q)->type == CONSTR); // closure (type constructor)
ASSERT(is_unique(node));
void
awakenBlockedQueue(StgBlockingQueueElement *q, StgClosure *node)
{
- StgBlockingQueueElement *bqe, *next;
+ StgBlockingQueueElement *bqe;
ACQUIRE_LOCK(&sched_mutex);
IF_PAR_DEBUG(verbose,
- belch("## AwBQ for node %p on [%x]: ",
+ belch("##-_ AwBQ for node %p on [%x]: ",
node, mytid));
-
- ASSERT(get_itbl(q)->type == TSO ||
+#ifdef DIST
+ //RFP
+ if(get_itbl(q)->type == CONSTR || q==END_BQ_QUEUE) {
+ IF_PAR_DEBUG(verbose, belch("## ... nothing to unblock so lets just return. RFP (BUG?)"));
+ return;
+ }
+#endif
+
+ ASSERT(q == END_BQ_QUEUE ||
+ get_itbl(q)->type == TSO ||
get_itbl(q)->type == BLOCKED_FETCH ||
get_itbl(q)->type == CONSTR);
case BlockedOnRead:
case BlockedOnWrite:
{
+ /* take TSO off blocked_queue */
StgBlockingQueueElement *prev = NULL;
for (t = (StgBlockingQueueElement *)blocked_queue_hd; t != END_BQ_QUEUE;
prev = t, t = t->link) {
case BlockedOnDelay:
{
+ /* take TSO off sleeping_queue */
StgBlockingQueueElement *prev = NULL;
for (t = (StgBlockingQueueElement *)sleeping_queue; t != END_BQ_QUEUE;
prev = t, t = t->link) {
{
StgTSO *t;
+# if defined(GRAN)
+ char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
+ ullong_format_string(TIME_ON_PROC(CurrentProc),
+ time_string, rtsFalse/*no commas!*/);
+
+ sched_belch("all threads at [%s]:", time_string);
+# elif defined(PAR)
+ char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
+ ullong_format_string(CURRENT_TIME,
+ time_string, rtsFalse/*no commas!*/);
+
+ sched_belch("all threads at [%s]:", time_string);
+# else
sched_belch("all threads:");
+# endif
+
for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) {
fprintf(stderr, "\tthread %d ", t->id);
printThreadStatus(t);
/* should cover all closures that may have a blocking queue */
ASSERT(get_itbl(node)->type == BLACKHOLE_BQ ||
get_itbl(node)->type == FETCH_ME_BQ ||
- get_itbl(node)->type == RBH);
+ get_itbl(node)->type == RBH ||
+ get_itbl(node)->type == MVAR);
ASSERT(node!=(StgClosure*)NULL); // sanity check
+
+ print_bqe(((StgBlockingQueue*)node)->blocking_queue);
+}
+
+/*
+ Print a whole blocking queue starting with the element bqe.
+*/
+void
+print_bqe (StgBlockingQueueElement *bqe)
+{
+ rtsBool end;
+
/*
NB: In a parallel setup a BQ of an RBH must end with an RBH_Save closure;
*/
- for (bqe = ((StgBlockingQueue*)node)->blocking_queue, end = (bqe==END_BQ_QUEUE);
+ for (end = (bqe==END_BQ_QUEUE);
!end; // iterate until bqe points to a CONSTR
- end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE), bqe = end ? END_BQ_QUEUE : bqe->link) {
- ASSERT(bqe != END_BQ_QUEUE); // sanity check
- ASSERT(bqe != (StgTSO*)NULL); // sanity check
+ end = (get_itbl(bqe)->type == CONSTR) || (bqe->link==END_BQ_QUEUE),
+ bqe = end ? END_BQ_QUEUE : bqe->link) {
+ ASSERT(bqe != END_BQ_QUEUE); // sanity check
+ ASSERT(bqe != (StgBlockingQueueElement *)NULL); // sanity check
/* types of closures that may appear in a blocking queue */
ASSERT(get_itbl(bqe)->type == TSO ||
get_itbl(bqe)->type == BLOCKED_FETCH ||
get_itbl(bqe)->type == CONSTR);
/* only BQs of an RBH end with an RBH_Save closure */
- ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
+ //ASSERT(get_itbl(bqe)->type != CONSTR || get_itbl(node)->type == RBH);
switch (get_itbl(bqe)->type) {
case TSO:
- fprintf(stderr," TSO %d (%x),",
+ fprintf(stderr," TSO %u (%x),",
((StgTSO *)bqe)->id, ((StgTSO *)bqe));
break;
case BLOCKED_FETCH:
"RBH_Save_?"), get_itbl(bqe));
break;
default:
- barf("Unexpected closure type %s in blocking queue of %p (%s)",
- info_type(bqe), node, info_type(node));
+ barf("Unexpected closure type %s in blocking queue", // of %p (%s)",
+ info_type((StgClosure *)bqe)); // , node, info_type(node));
break;
}
} /* for */
va_start(ap,s);
#ifdef SMP
fprintf(stderr, "scheduler (task %ld): ", pthread_self());
+#elif defined(PAR)
+ fprintf(stderr, "== ");
#else
fprintf(stderr, "scheduler: ");
#endif
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.21 2000/12/04 12:31:21 simonmar Exp $
+ * $Id: Schedule.h,v 1.22 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team 1998-1999
*
void startTasks( void );
#endif
-
//@cindex awakenBlockedQueue
/* awakenBlockedQueue()
*
void printAllThreads(void);
#endif
void print_bq (StgClosure *node);
+#if defined(PAR)
+void print_bqe (StgBlockingQueueElement *bqe);
+#endif
/* -----------------------------------------------------------------------------
* Some convenient macros...
*/
-/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
-#define END_TSO_QUEUE ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
-/* this is the NIL ptr for a list CAFs */
-#define END_ECAF_LIST ((StgCAF *)(void*)&stg_END_TSO_QUEUE_closure)
+/* END_TSO_QUEUE and friends now defined in includes/StgMiscClosures.h */
//@cindex APPEND_TO_RUN_QUEUE
/* Add a thread to the end of the run queue.
#define THREAD_RUNNABLE() /* nothing */
#endif
+//@cindex EMPTY_RUN_QUEUE
+/* Check whether the run queue is empty i.e. the PE is idle
+ */
+#define EMPTY_RUN_QUEUE() (run_queue_hd == END_TSO_QUEUE)
+
//@node Index, , Some convenient macros
//@subsection Index
/* ---------------------------------------------------------------------------
- * $Id: Sparks.c,v 1.2 2000/03/31 03:09:36 hwloidl Exp $
+ * $Id: Sparks.c,v 1.3 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 2000
*
//* GUM code::
//* GranSim code::
//@end menu
+//*/
//@node Includes, GUM code, Spark Management Routines, Spark Management Routines
//@subsection Includes
#include "Storage.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
+#include "ParTicky.h"
# if defined(PAR)
# include "ParallelRts.h"
+# include "GranSimRts.h" // for GR_...
# elif defined(GRAN)
# include "GranSimRts.h"
# endif
static void slide_spark_pool( StgSparkPool *pool );
-void
+rtsBool
initSparkPools( void )
{
Capability *cap;
pool->hd = pool->base;
pool->tl = pool->base;
}
+ return rtsTrue; /* Qapla' */
}
+/*
+ We traverse the spark pool until we find the 2nd usable (i.e. non-NF)
+ spark. Rationale, we don't want to give away the only work a PE has.
+ ToDo: introduce low- and high-water-marks for load balancing.
+*/
StgClosure *
-findSpark( void )
+findSpark( rtsBool for_export )
{
Capability *cap;
StgSparkPool *pool;
- StgClosure *spark;
+ StgClosure *spark, *first=NULL;
+ rtsBool isIdlePE = EMPTY_RUN_QUEUE();
#ifdef SMP
/* walk over the capabilities, allocating a spark pool for each one */
pool = &(cap->rSparks);
while (pool->hd < pool->tl) {
spark = *pool->hd++;
- if (closure_SHOULD_SPARK(spark))
- return spark;
+ if (closure_SHOULD_SPARK(spark)) {
+ if (for_export && isIdlePE) {
+ if (first==NULL) {
+ first = spark; // keep the first usable spark if PE is idle
+ } else {
+ pool->hd--; // found a second spark; keep it in the pool
+ ASSERT(*pool->hd==spark);
+ if (RtsFlags.ParFlags.ParStats.Sparks)
+ DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
+ GR_STEALING, ((StgTSO *)NULL), first,
+ 0, 0 /* spark_queue_len(ADVISORY_POOL) */);
+ return first; // and return the *first* spark found
+ }
+ } else {
+ if (RtsFlags.ParFlags.ParStats.Sparks && for_export)
+ DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
+ GR_STEALING, ((StgTSO *)NULL), spark,
+ 0, 0 /* spark_queue_len(ADVISORY_POOL) */);
+ return spark; // return first spark found
+ }
+ }
}
slide_spark_pool(pool);
}
return NULL;
}
+/*
+ activateSpark is defined in Schedule.c
+*/
rtsBool
add_to_spark_queue( StgClosure *closure, StgSparkPool *pool )
{
if (closure_SHOULD_SPARK(closure) &&
pool->tl < pool->lim) {
*(pool->tl++) = closure;
+
+#if defined(PAR)
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ // fprintf(stderr, "Creating spark for %x @ %11.2f\n", closure, usertime());
+ globalParStats.tot_sparks_created++;
+ }
+#endif
return rtsTrue;
} else {
+#if defined(PAR)
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ //fprintf(stderr, "Ignoring spark for %x @ %11.2f\n", closure, usertime());
+ globalParStats.tot_sparks_ignored++;
+ }
+#endif
return rtsFalse;
}
}
markSparkQueue( void )
{
StgClosure **sparkp, **to_sparkp;
-#ifdef DEBUG
- nat n, pruned_sparks;
-#endif
+ nat n, pruned_sparks; // stats only
StgSparkPool *pool;
Capability *cap;
+ PAR_TICKY_MARK_SPARK_QUEUE_START();
+
#ifdef SMP
/* walk over the capabilities, allocating a spark pool for each one */
for (cap = free_capabilities; cap != NULL; cap = cap->link) {
{
#endif
pool = &(cap->rSparks);
-
-#ifdef DEBUG
+
+#if defined(PAR)
+ // stats only
n = 0;
pruned_sparks = 0;
#endif
if (closure_SHOULD_SPARK(*sparkp)) {
*to_sparkp = MarkRoot(*sparkp);
to_sparkp++;
-#ifdef DEBUG
+#ifdef PAR
n++;
#endif
} else {
-#ifdef DEBUG
+#ifdef PAR
pruned_sparks++;
#endif
}
pool->hd = pool->base;
pool->tl = to_sparkp;
+ PAR_TICKY_MARK_SPARK_QUEUE_END(n);
+
#if defined(SMP)
IF_DEBUG(scheduler,
belch("markSparkQueue: marked %d sparks and pruned %d sparks on [%x]",
IF_GRAN_DEBUG(pri,
belch("++ No high priority spark available; low priority (%u) spark chosen: node=%p; name=%u\n",
spark->gran_info,
- spark->node, spark->name);)
+ spark->node, spark->name));
}
CurrentTime[proc] += RtsFlags.GranFlags.Costs.threadcreatetime;
FindWork,
(StgTSO*)NULL, (StgClosure*)NULL, (rtsSpark*)NULL);
barf("//// activateSpark: out of heap ; ToDo: call GarbageCollect()");
- GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots, rtsFalse);
// HWL old: ReallyPerformThreadGC(TSO_HS+TSO_CTS_SIZE,rtsFalse);
// HWL old: SAVE_Hp -= TSO_HS+TSO_CTS_SIZE;
spark = NULL;
/* -----------------------------------------------------------------------------
- * $Id: Sparks.h,v 1.2 2000/03/31 03:09:36 hwloidl Exp $
+ * $Id: Sparks.h,v 1.3 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 2000
*
#elif defined(PAR) || defined(SMP)
-void initSparkPools( void );
+rtsBool initSparkPools( void );
void markSparkQueue( void );
-StgClosure *findSpark( void );
+StgClosure *findSpark( rtsBool );
+StgTSO *activateSpark (rtsSpark spark) ;
rtsBool add_to_spark_queue( StgClosure *closure, StgSparkPool *pool );
void markSparkQueue( void );
+nat spark_queue_len( StgSparkPool *pool );
+void disposeSpark( StgClosure *spark );
+
#endif
/* -----------------------------------------------------------------------------
- * $Id: Stats.c,v 1.24 2001/03/14 15:01:04 sewardj Exp $
+ * $Id: Stats.c,v 1.25 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "MBlock.h"
#include "Schedule.h"
#include "Stats.h"
+#include "ParTicky.h" // ToDo: move into Rts.h
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#include <windows.h>
#endif
+#if defined(PAR) || !(!defined(HAVE_GETRUSAGE) || irix_TARGET_OS || defined(_WIN32))
+#include <sys/resource.h>
+#endif
+
/* huh? */
#define BIG_STRING_LEN 512
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.36 2001/02/11 17:51:08 simonmar Exp $
+ * $Id: Storage.c,v 1.37 2001/03/22 03:51:10 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
}
RELEASE_LOCK(&sm_mutex);
+
+#ifdef PAR
+ /* If we are PAR or DIST then we never forget a CAF */
+ { globalAddr *newGA;
+ //belch("<##> Globalising CAF %08x %s",caf,info_type(caf));
+ newGA=makeGlobal(caf,rtsTrue); /*given full weight*/
+ ASSERT(newGA);
+ }
+#endif PAR
}
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: InitEachPE.c,v 1.2 1998/12/02 13:29:12 simonm Exp $
+ * $Id: InitEachPE.c,v 1.3 2001/03/22 03:51:11 hwloidl Exp $
*
* User-overridable RTS hooks.
*
#ifdef PAR
void
-initEachPEHook (void)
-{ /* in a GUM setup this is called on each
- PE immediately before SynchroniseSystem
- it can be used to read in static data
+InitEachPEHook (void)
+{ /* In a GUM setup this is called on each
+ PE immediately before SynchroniseSystem.
+ It can be used to read in static data
to each PE which has to be available to
- each PE
-
- This version is the one specialised
- for Lolita, calling the LoadAllData stuff.
- The default version probably should do
- nothing -- HWL
+ each PE. See GPH-Maple as an example how to
+ use this in combination with foreign language
+ code:
+ http://www.risc.uni-linz.ac.at/software/ghc-maple/
+ -- HWL
*/
}
#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: ShutdownEachPEHook.c,v 1.1 2001/03/22 03:51:11 hwloidl Exp $
+ *
+ * User-overridable RTS hooks.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+
+#ifdef PAR
+void
+ShutdownEachPEHook (void)
+{ /* In a GUM setup this routine is called at the end of
+ shutdownParallelSystem on each PE. Useful for
+ cleaning up stuff, especially when interfacing
+ with foreign language code.
+ -- HWL
+ */
+}
+#endif
--- /dev/null
+#include "Dist.h"
+
+#ifdef DIST /* whole file */
+
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+#include "ParallelRts.h"
+#include "Parallel.h" // nPEs,allPEs,mytid
+#include "HLC.h" //for sendReval
+#include "LLC.h" //for pvm stuff
+#include "FetchMe.h" // for BLOCKED_FETCH_info
+#include "Storage.h" // for recordMutable
+
+/* hopefully the result>0 */
+StgWord32 cGetPECount(void)
+{ return nPEs;
+}
+
+/* return taskID, n is 1..count, n=1 is always the mainPE */
+StgPEId cGetPEId(StgWord32 n)
+{ return allPEs[n-1];
+}
+
+/* return the taskID */
+StgPEId cGetMyPEId(void)
+{ return mytid;
+}
+
+/* return the taskID of the owning PE of an MVar/TSO:
+- MVAR/TSOs get converted to REMOTE_REFs when shipped, and
+ there is no mechanism for using these REMOTE_REFs
+ apart from this code.
+*/
+
+StgPEId cGetCertainOwner(StgClosure *mv)
+{ globalAddr *ga;
+ switch(get_itbl(mv)->type)
+ { case TSO:
+ case MVAR:
+ return mytid; // must be local
+ case REMOTE_REF:
+ ga = LAGAlookup(mv);
+ ASSERT(ga);
+ return ga->payload.gc.gtid; // I know its global address
+ }
+ barf("Dist.c:cGetCertainOwner() wrong closure type %s",info_type(mv));
+}
+
+/* for some additional fun, lets look up a certain host... */
+StgPEId cGetHostOwner(StgByteArray h) //okay h is a C string
+{ int nArch,nHost,nTask,i;
+ StgPEId dtid;
+ struct pvmhostinfo *host;
+ struct pvmtaskinfo *task;
+
+ dtid=0;
+ pvm_config(&nHost,&nArch,&host);
+ for(i=0;i<nHost;i++)
+ if(strcmp(host[i].hi_name,h)==0)
+ { dtid=host[i].hi_tid;
+ break;
+ }
+ if(dtid==0) return 0; // no host of that name
+
+ for(i=0;i<nPEs;i++)
+ { pvm_tasks(allPEs[i],&nTask,&task);
+ ASSERT(nTask==1); //cause we lookup a single task
+ if(task[0].ti_host==dtid)
+ return allPEs[i];
+ }
+ return 0; //know host, put no PE on it
+}
+
+void cRevalIO(StgClosure *job,StgPEId p)
+{ nat size;
+ rtsPackBuffer *buffer=NULL;
+
+ ASSERT(get_itbl(job)->type==MVAR);
+ job=((StgMVar*)job)->value; // extract the job from the MVar
+
+ ASSERT(closure_THUNK(job)); // must be a closure!!!!!
+ ASSERT(p!=mytid);
+
+ buffer = PackNearbyGraph(job, END_TSO_QUEUE, &size,p);
+ ASSERT(buffer != (rtsPackBuffer *)NULL);
+ ASSERT(get_itbl(job)->type==RBH);
+
+ IF_PAR_DEBUG(verbose,
+ belch("@;~) %x doing revalIO to %x\n",
+ mytid,p));
+
+ sendReval(p,size,buffer);
+
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_reval_mess++;
+ }
+
+ /*
+ We turn job into a FETCHME_BQ so that the thread will block
+ when it enters it.
+
+ Note: it will not receive an ACK, thus no GA.
+ */
+
+ ASSERT(get_itbl(job)->type==RBH);
+
+ /* put closure on mutables list, while it is still a RBH */
+ recordMutable((StgMutClosure *)job);
+
+ /* actually turn it into a FETCH_ME_BQ */
+ SET_INFO(job, &FETCH_ME_BQ_info);
+ ((StgFetchMe *)job)->ga = 0; //hope this won't make anyone barf!!!
+ ((StgBlockingQueue*)job)->blocking_queue=END_BQ_QUEUE;
+}
+
+#endif
--- /dev/null
+#ifndef __DIST_H
+#define __DIST_H
+
+#ifdef DIST
+
+#include "Rts.h"
+
+typedef StgWord32 StgPEId;
+
+// interface functions for Haskell Language calls
+StgWord32 cGetPECount(void);
+StgPEId cGetPEId(StgWord32 n);
+StgPEId cGetMyPEId(void);
+StgPEId cGetCertainOwner(StgClosure *mv);
+void cRevalIO(StgClosure *job,StgPEId p);
+StgPEId cGetHostOwner(StgByteArray h);
+
+#endif // DIST
+
+#endif // __DIST_H
/* -----------------------------------------------------------------------------
- * $Id: FetchMe.h,v 1.2 2000/01/13 14:34:06 hwloidl Exp $
+ * $Id: FetchMe.h,v 1.3 2001/03/22 03:51:11 hwloidl Exp $
*
* Closure types for the parallel system.
*
* ---------------------------------------------------------------------------*/
-EI_(FETCH_ME_info);
-EF_(FETCH_ME_entry);
+EI_(stg_FETCH_ME_info);
+EF_(stg_FETCH_ME_entry);
-EI_(FETCH_ME_BQ_info);
-EF_(FETCH_ME_BQ_entry);
+EI_(stg_FETCH_ME_BQ_info);
+EF_(stg_FETCH_ME_BQ_entry);
-EI_(BLOCKED_FETCH_info);
-EF_(BLOCKED_FETCH_entry);
+EI_(stg_BLOCKED_FETCH_info);
+EF_(stg_BLOCKED_FETCH_entry);
-EI_(RBH_Save_0_info);
-EF_(RBH_Save_0_entry);
-EI_(RBH_Save_1_info);
-EF_(RBH_Save_1_entry);
-EI_(RBH_Save_2_info);
-EF_(RBH_Save_2_entry);
+EI_(stg_REMOTE_REF_info);
+EF_(stg_REMOTE_REF_entry);
+
+EI_(stg_RBH_Save_0_info);
+EF_(stg_RBH_Save_0_entry);
+EI_(stg_RBH_Save_1_info);
+EF_(stg_RBH_Save_1_entry);
+EI_(stg_RBH_Save_2_info);
+EF_(stg_RBH_Save_2_entry);
/* ----------------------------------------------------------------------------
- Time-stamp: <Thu Feb 24 2000 21:31:41 Stardate: [-30]4409.48 hwloidl>
- $Id: FetchMe.hc,v 1.5 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Tue Mar 06 2001 17:01:46 Stardate: [-30]6288.54 hwloidl>
+ $Id: FetchMe.hc,v 1.6 2001/03/22 03:51:11 hwloidl Exp $
Entry code for a FETCH_ME closure
checkClosure() (using the same fcts for determining the size of the
closures would be a good idea; at least it would be a nice step towards
making this code bug free).
-
- About the difference between std and PAR in returning to the RTS:
- in PAR we call RTS functions from within the entry code (see also
- BLACKHOLE_entry and friends in StgMiscClosures.hc); therefore, we
- have to save the thread state before calling these functions ---
- this is done via SAVE_THREAD_STATE; we then just load the return
- code into R1 before jumping into the RTS --- this is done via
- THREAD_RETURN; so, in short we have something like
- SAVE_THREAD_STATE + THREAD_RETURN = BLOCK_NP
-
------------------------------------------------------------------------ */
//@node Info tables, Index, Includes
//@subsection Info tables
//@cindex FETCH_ME_info
-INFO_TABLE(FETCH_ME_info, FETCH_ME_entry, 0,2, FETCH_ME, const, EF_,0,0);
+INFO_TABLE(stg_FETCH_ME_info, stg_FETCH_ME_entry, 0,2, FETCH_ME,, EF_,"FETCH_ME","FETCH_ME");
//@cindex FETCH_ME_entry
-STGFUN(FETCH_ME_entry)
+STGFUN(stg_FETCH_ME_entry)
{
- /*
- Not needed any more since we call blockThread in the scheduler
- (via BLOCK_NP(1) which returns with BlockedOnGA
-
- extern globalAddr *rga_GLOBAL;
- extern globalAddr *lga_GLOBAL;
- extern globalAddr fmbqga_GLOBAL;
- extern StgClosure *p_GLOBAL;
- globalAddr *rga;
- globalAddr *lga;
- globalAddr fmbqga;
- StgClosure *p;
- */
-
FB_
- /*
- rga_GLOBAL = ((StgFetchMe *)R1.p)->ga;
- ASSERT(rga->payload.gc.gtid != mytid);
- */
+ TICK_ENT_BH();
+
ASSERT(((StgFetchMe *)R1.p)->ga->payload.gc.gtid != mytid);
/* Turn the FETCH_ME into a FETCH_ME_BQ, and place the current thread
* on the blocking queue.
*/
- // R1.cl->header.info = FETCH_ME_BQ_info;
- SET_INFO((StgClosure *)R1.cl, &FETCH_ME_BQ_info);
+ // ((StgFetchMeBlockingQueue *)R1.cl)->header.info = &FETCH_ME_BQ_info; // does the same as SET_INFO
+ SET_INFO((StgClosure *)R1.cl, &stg_FETCH_ME_BQ_info);
+ /* Remember GA as a global var (used in blockThread); NB: not thread safe! */
+ ASSERT(theGlobalFromGA.payload.gc.gtid == (GlobalTaskId)0);
+ theGlobalFromGA = *((StgFetchMe *)R1.p)->ga;
+
/* Put ourselves on the blocking queue for this black hole */
- // This is really, really BAD; tmp HACK to remember ga (checked in blockThread)
ASSERT(looks_like_ga(((StgFetchMe *)R1.p)->ga));
- CurrentTSO->link = (StgBlockingQueueElement *)((StgFetchMe *)R1.p)->ga; // END_BQ_QUEUE;
+ CurrentTSO->link = END_BQ_QUEUE;
((StgFetchMeBlockingQueue *)R1.cl)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
/* jot down why and on what closure we are blocked */
CurrentTSO->why_blocked = BlockedOnGA;
CurrentTSO->block_info.closure = R1.cl;
+ /* closure is mutable since something has just been added to its BQ */
//recordMutable((StgMutClosure *)R1.cl);
- //p_GLOBAL = R1.cl;
/* sendFetch etc is now done in blockThread, which is called from the
scheduler -- HWL */
When the data arrives from the remote PE, all waiting threads are
woken up and the FETCH_ME_BQ is overwritten with the fetched data.
- FETCH_ME_BQ_entry is a copy of BLACKHOLE_BQ_entry -- HWL
+ FETCH_ME_BQ_entry is almost identical to BLACKHOLE_BQ_entry -- HWL
------------------------------------------------------------------------ */
-INFO_TABLE(FETCH_ME_BQ_info, FETCH_ME_BQ_entry,0,2,FETCH_ME_BQ,const,EF_,0,0);
+INFO_TABLE(stg_FETCH_ME_BQ_info, stg_FETCH_ME_BQ_entry,0,2,FETCH_ME_BQ,,EF_,"FETCH_ME_BQ","FETCH_ME_BQ");
//@cindex FETCH_ME_BQ_info
-STGFUN(FETCH_ME_BQ_entry)
+STGFUN(stg_FETCH_ME_BQ_entry)
{
FB_
TICK_ENT_BH();
/* Put ourselves on the blocking queue for this node */
- CurrentTSO->link = ((StgBlockingQueue *)R1.p)->blocking_queue;
- ((StgBlockingQueue *)R1.p)->blocking_queue = CurrentTSO;
+ CurrentTSO->link = (StgTSO*)((StgBlockingQueue *)R1.p)->blocking_queue;
+ ((StgBlockingQueue *)R1.p)->blocking_queue = (StgBlockingQueueElement *)CurrentTSO;
/* jot down why and on what closure we are blocked */
CurrentTSO->why_blocked = BlockedOnGA_NoSend;
computation. Thus, when updating the closure, the result has to be sent
to that PE. The relevant routines handling that are awakenBlockedQueue
and blockFetch (for putting BLOCKED_FETCH closure into a BQ).
-*/
+ ------------------------------------------------------------------------ */
//@cindex BLOCKED_FETCH_info
-INFO_TABLE(BLOCKED_FETCH_info, BLOCKED_FETCH_entry,0,2,BLOCKED_FETCH,const,EF_,0,0);
+INFO_TABLE(stg_BLOCKED_FETCH_info, stg_BLOCKED_FETCH_entry,0,2,BLOCKED_FETCH,,EF_,"BLOCKED_FETCH","BLOCKED_FETCH");
//@cindex BLOCKED_FETCH_entry
-STGFUN(BLOCKED_FETCH_entry)
+STGFUN(stg_BLOCKED_FETCH_entry)
{
FB_
/* see NON_ENTERABLE_ENTRY_CODE in StgMiscClosures.hc */
FE_
}
+
+/* ---------------------------------------------------------------------------
+ REMOTE_REF
+
+ A REMOTE_REF closure is generated whenever we wish to refer to a sticky
+ object on another PE.
+ ------------------------------------------------------------------------ */
+
+//@cindex REMOTE_REF_info
+INFO_TABLE(stg_REMOTE_REF_info, stg_REMOTE_REF_entry,0,2,REMOTE_REF,,EF_,"REMOTE_REF","REMOTE_REF");
+//@cindex REMOTE_REF_entry
+STGFUN(stg_REMOTE_REF_entry)
+{
+ FB_
+ /* see NON_ENTERABLE_ENTRY_CODE in StgMiscClosures.hc */
+ STGCALL2(fprintf,stderr,"REMOTE REF object entered!\n");
+ STGCALL1(shutdownHaskellAndExit, EXIT_FAILURE);
+ FE_
+}
+
#endif /* PAR */
//@node Index, , Info tables
/* ---------------------------------------------------------------------------
- Time-stamp: <Mon Mar 27 2000 17:10:57 Stardate: [-30]4568.37 hwloidl>
- $Id: Global.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Wed Mar 21 2001 16:32:23 Stardate: [-30]6363.44 hwloidl>
+ $Id: Global.c,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
(c) The AQUA/Parade Projects, Glasgow University, 1995
The GdH/APART 624 Projects, Heriot-Watt University, Edinburgh, 1999
//* GC functions for GALA tables::
//* Index::
//@end menu
+//*/
//@node Includes, Global tables and lists, Global Address Manipulation, Global Address Manipulation
//@subsection Includes
#include "RtsUtils.h"
#include "Storage.h"
#include "Hash.h"
+#include "HLC.h"
#include "ParallelRts.h"
+#if defined(DEBUG)
+# include "Sanity.h"
+#include "ParallelDebug.h"
+#endif
#if defined(DIST)
-#include "Dist.h"
+# include "Dist.h"
#endif
/*
if ((gl = freeGALAList) != NULL) {
IF_DEBUG(sanity,
ASSERT(gl->ga.weight==0xdead0add);
- ASSERT(gl->la==0xdead00aa));
+ ASSERT(gl->la==(StgPtr)0xdead00aa));
freeGALAList = gl->next;
} else {
gl = (GALA *) stgMallocBytes(GCHUNK * sizeof(GALA), "allocGALA");
p->next = p + 1;
IF_DEBUG(sanity,
p->ga.weight=0xdead0add;
- p->la=0xdead00aa);
+ p->la=(StgPtr)0xdead00aa);
}
/* last elem in the new block has NULL pointer in link field */
p->next = NULL;
IF_DEBUG(sanity,
p->ga.weight=0xdead0add;
- p->la=0xdead00aa);
+ p->la=(StgPtr)0xdead00aa);
}
IF_DEBUG(sanity,
gl->ga.weight=0xdead0add;
- gl->la=0xdead00aa);
+ gl->la=(StgPtr)0xdead00aa);
return gl;
}
PEs
taskIDtoPE(GlobalTaskId gtid)
{
- return (PEs) lookupHashTable(taskIDtoPEtable, gtid);
+ return ((PEs) lookupHashTable(taskIDtoPEtable, gtid));
}
//@cindex registerTask
void
-registerTask(gtid)
-GlobalTaskId gtid;
-{
+registerTask(GlobalTaskId gtid) {
+ nextPE++; //start counting from 1
if (gtid == mytid)
thisPE = nextPE;
- insertHashTable(taskIDtoPEtable, gtid, (void *) (StgWord) nextPE++);
+ insertHashTable(taskIDtoPEtable, gtid, (void *) (StgWord) nextPE);
}
//@node Interface to LAGA table, Interface to GALA table, Interface to taskId-PE table, Global Address Manipulation
gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
ASSERT(gala!=NULL);
ASSERT(gala->preferred==rtsTrue);
- gala->preferred==rtsFalse;
+ gala->preferred = rtsFalse;
}
/*
if ((gala = freeIndirections) != NULL) {
IF_DEBUG(sanity,
ASSERT(gala->ga.weight==0xdead0add);
- ASSERT(gala->la==0xdead00aa));
+ ASSERT(gala->la==(StgPtr)0xdead00aa));
freeIndirections = gala->next;
} else {
gala = allocGALA();
IF_DEBUG(sanity,
ASSERT(gala->ga.weight==0xdead0add);
- ASSERT(gala->la==0xdead00aa));
+ ASSERT(gala->la==(StgPtr)0xdead00aa));
gala->ga.payload.gc.gtid = mytid;
gala->ga.payload.gc.slot = nextIndirection++;
+ IF_DEBUG(sanity,
+ if (nextIndirection>=MAX_SLOTS)
+ barf("Cannot handle more than %d slots for GA in a sanity-checking setup (this is no error)"));
}
gala->ga.weight = MAX_GA_WEIGHT;
- gala->la = closure;
+ gala->la = (StgPtr)closure;
IF_DEBUG(sanity,
- gala->next=0xcccccccc);
+ gala->next=(struct gala *)0xcccccccc);
return gala;
}
/* check whether we already have a GA for this local closure */
GALA *oldGALA = lookupHashTable(LAtoGALAtable, (StgWord) closure);
/* create an entry in the LAGA table */
- GALA *newGALA = allocIndirection((StgPtr)closure);
+ GALA *newGALA = allocIndirection(closure);
StgWord pga = PackGA(thisPE, newGALA->ga.payload.gc.slot);
IF_DEBUG(sanity,
- ASSERT(newGALA->next==0xcccccccc););
+ ASSERT(newGALA->next==(struct gala *)0xcccccccc););
// ASSERT(HEAP_ALLOCED(closure)); // check that closure might point into the heap; might be static, though
ASSERT(GALAlookup(&(newGALA->ga)) == NULL);
- newGALA->la = closure;
+ /* global statistics gathering */
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.local_alloc_GA++;
+ }
+
+ newGALA->la = (StgPtr)closure;
newGALA->preferred = preferred;
if (preferred) {
ASSERT(GALAlookup(remote_ga) == NULL);
newGALA->ga = *remote_ga;
- newGALA->la = local_closure;
+ newGALA->la = (StgPtr)local_closure;
newGALA->preferred = preferred;
if (preferred) {
addWeight(ga)
globalAddr *ga;
{
- StgWord pga = PackGA(taskIDtoPE(ga->payload.gc.gtid), ga->payload.gc.slot);
- GALA *gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
+ StgWord pga;
+ GALA *gala;
+
+ ASSERT(LOOKS_LIKE_GA(ga));
+
+ pga = PackGA(taskIDtoPE(ga->payload.gc.gtid), ga->payload.gc.slot);
+ gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
IF_PAR_DEBUG(weight,
fprintf(stderr, "@* Adding weight %x to ", ga->weight);
taskIDtoPEtable = allocHashTable();
LAtoGALAtable = allocHashTable();
pGAtoGALAtable = allocHashTable();
-#ifdef DIST
- stickyClosureTable = allocHashTable();
-#endif
}
//@cindex PackGA
void
markLocalGAs(rtsBool full)
{
- GALA *gala;
- GALA *next;
- GALA *prev = NULL;
+ GALA *gala, *next, *prev = NULL;
StgPtr old_la, new_la;
nat n=0, m=0; // debugging only
-
+ double start_time_GA; // stats only
+
IF_PAR_DEBUG(tables,
- belch("@@%%%% markLocalGAs: Marking LIVE INDIRECTIONS in GALA table starting with GALA at %p\n",
- liveIndirections);
+ belch("@@%%%% markLocalGAs (full=%d): Marking LIVE INDIRECTIONS in GALA table starting with GALA at %p\n",
+ full, liveIndirections);
printLAGAtable());
+ PAR_TICKY_MARK_LOCAL_GAS_START();
+
for (gala = liveIndirections, m=0; gala != NULL; gala = next, m++) {
IF_PAR_DEBUG(tables,
fputs("@@ ",stderr);
printGA(&(gala->ga));
fprintf(stderr, ";@ %d: LA: %p (%s) ",
- m, gala->la, info_type(gala->la)));
+ m, (void*)gala->la, info_type((StgClosure*)gala->la)));
next = gala->next;
old_la = gala->la;
ASSERT(gala->ga.payload.gc.gtid == mytid); /* it's supposed to be local */
/* Remote references exist, so we must evacuate the local closure */
if (get_itbl((StgClosure *)old_la)->type == EVACUATED) {
/* somebody else already evacuated this closure */
- new_la = ((StgEvacuated *)old_la)->evacuee;
+ new_la = (StgPtr)((StgEvacuated *)old_la)->evacuee;
IF_PAR_DEBUG(tables,
belch(" already evacuated to %p", new_la));
} else {
//ASSERT(HEAP_ALLOCED(foo));
n++;
- new_la = MarkRoot(foo); // or just evacuate(old_ga)
+ new_la = (StgPtr) MarkRoot(foo);
IF_PAR_DEBUG(tables,
belch(" evacuated %p to %p", foo, new_la));
- //ASSERT(Bdescr(new_la)->evacuated);
+ /* ToDo: is this the right assertion to check that new_la is in to-space?
+ ASSERT(!HEAP_ALLOCED(new_la) || Bdescr(new_la)->evacuated);
+ */
#else
new_la = MarkRoot(old_la); // or just evacuate(old_ga)
IF_PAR_DEBUG(tables,
gala->la = new_la;
/* remove old LA and replace with new LA */
- if (!full && gala->preferred && new_la != old_la) {
+ if (/* !full && */ gala->preferred && new_la != old_la) {
GALA *q;
ASSERT(lookupHashTable(LAtoGALAtable, (StgWord)old_la));
(void) removeHashTable(LAtoGALAtable, (StgWord) old_la, (void *) gala);
q->preferred = rtsFalse;
IF_PAR_DEBUG(tables,
fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
- new_la, info_type(new_la));
+ new_la, info_type((StgClosure*)new_la));
printGA(&(q->ga));
fputc('\n', stderr));
}
gala->next = prev;
prev = gala;
+ } else if(LOOKS_LIKE_STATIC_CLOSURE(gala->la)) {
+ /* to handle the CAFs, is this all?*/
+ MarkRoot(gala->la);
+ IF_PAR_DEBUG(tables,
+ belch(" processed static closure"));
+ n++;
+ gala->next = prev;
+ prev = gala;
} else {
/* Since we have all of the weight, this GA is no longer needed */
StgWord pga = PackGA(thisPE, gala->ga.payload.gc.slot);
gala->next = freeIndirections;
freeIndirections = gala;
(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
- if (!full && gala->preferred)
+ if (/* !full && */ gala->preferred)
(void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
IF_DEBUG(sanity,
gala->ga.weight = 0xdead0add;
- gala->la = (StgClosure *) 0xdead00aa);
+ gala->la = (StgPtr) 0xdead00aa);
}
} /* for gala ... */
liveIndirections = prev; /* list has been reversed during the marking */
+
+ PAR_TICKY_MARK_LOCAL_GAS_END(n);
+
IF_PAR_DEBUG(tables,
belch("@@%%%% markLocalGAs: %d of %d GALAs marked on PE %x",
n, m, mytid));
void
rebuildGAtables(rtsBool full)
{
- GALA *gala;
- GALA *next;
- GALA *prev;
- StgClosure *closure, *last, *new_closure;
-
- prepareFreeMsgBuffers();
+ GALA *gala, *next, *prev;
+ StgClosure *closure;
+ nat n = 0, size_GA = 0; // stats only (no. of GAs, and their heap size in bytes)
IF_PAR_DEBUG(tables,
- belch("@@%%%% rebuildGAtables: rebuilding LIVE REMOTE GAs in GALA table starting with GALA at %p\n",
- liveRemoteGAs));
+ belch("@@%%%% rebuildGAtables (full=%d): rebuilding LIVE REMOTE GAs in GALA table starting with GALA at %p\n",
+ full, liveRemoteGAs));
+
+ PAR_TICKY_REBUILD_GA_TABLES_START();
+
+ prepareFreeMsgBuffers();
for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) {
IF_PAR_DEBUG(tables,
closure = (StgClosure *) (gala->la);
IF_PAR_DEBUG(tables,
- fprintf(stderr, " %p (%s) ",
- (StgClosure *)closure, info_type(closure)));
+ fprintf(stderr, " %p (%s) ",
+ (StgClosure *)closure, info_type(closure)));
- if (!full && gala->preferred)
+ if (/* !full && */ gala->preferred)
(void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *) gala);
/* Follow indirection chains to the end, just in case */
This approach also drops global aliases for PLCs.
*/
+ //ASSERT(!HEAP_ALLOCED(closure) || !(Bdescr((StgPtr)closure)->evacuated));
if (get_itbl(closure)->type == EVACUATED) {
closure = ((StgEvacuated *)closure)->evacuee;
IF_PAR_DEBUG(tables,
StgWord pga = PackGA(pe, gala->ga.payload.gc.slot);
/* check that the block containing this closure is not in to-space */
- //ASSERT(Bdescr(closure)->evacuated==0);
IF_PAR_DEBUG(tables,
fprintf(stderr, " !EVAC %p (%s); sending free to PE %d\n",
closure, info_type(closure), pe));
(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
- freeRemoteGA(pe, &(gala->ga));
+ freeRemoteGA(pe-1, &(gala->ga)); //-1 cause ids start at 1... not 0
gala->next = freeGALAList;
freeGALAList = gala;
IF_DEBUG(sanity,
gala->ga.weight = 0xdead0add;
- gala->la = 0xdead00aa);
+ gala->la = (StgPtr)0xdead00aa);
continue;
}
- gala->la = closure;
- if (!full && gala->preferred) {
+ gala->la = (StgPtr)closure;
+ if (/* !full && */ gala->preferred) {
GALA *q;
if ((q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la))!=NULL) {
if (q->preferred && gala->preferred) {
q->preferred = rtsFalse;
IF_PAR_DEBUG(tables,
fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
- gala->la, info_type(gala->la));
+ gala->la, info_type((StgClosure*)gala->la));
printGA(&(q->ga));
fputc('\n', stderr));
}
}
gala->next = prev;
prev = gala;
+ /* Global statistics: count GAs and total size
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i;
+ char str[80];
+
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+
+ size_GA += size ;
+ n++; // stats: count number of GAs we add to the new table
+ }
+ */
}
- //}
liveRemoteGAs = prev; /* list is reversed during marking */
/* If we have any remaining FREE messages to send off, do so now */
sendFreeMessages();
+ PAR_TICKY_CNT_FREE_GA();
+
IF_DEBUG(sanity,
checkFreeGALAList();
checkFreeIndirectionsList());
- if (full)
- rebuildLAGAtable();
+ rebuildLAGAtable();
+
+#if defined(PAR_TICKY)
+ getLAGAtableSize(&n, &size_GA); // determine no of GAs and global heap
+ PAR_TICKY_REBUILD_GA_TABLES_END(n, size_GA); // record these values
+#endif
IF_PAR_DEBUG(tables,
belch("@#%%%% rebuildGAtables: After ReBuilding GALA table starting with GALA at %p",
n++;
if (gala->preferred) {
GALA *q;
- if (q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la)) {
+ if ((q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la))!=NULL) {
if (q->preferred && gala->preferred) {
/* this deprecates q (see also GALAdeprecate) */
q->preferred = rtsFalse;
(void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *)q);
IF_PAR_DEBUG(tables,
fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
- gala->la, info_type(gala->la));
+ gala->la, info_type((StgClosure*)gala->la));
printGA(&(q->ga));
fputc('\n', stderr));
}
m++;
if (gala->preferred) {
GALA *q;
- if (q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la)) {
+ if ((q = lookupHashTable(LAtoGALAtable, (StgWord) gala->la))!=NULL) {
if (q->preferred && gala->preferred) {
/* this deprecates q (see also GALAdeprecate) */
q->preferred = rtsFalse;
(void) removeHashTable(LAtoGALAtable, (StgWord) gala->la, (void *)q);
IF_PAR_DEBUG(tables,
fprintf(stderr, "@@## found hash entry for closure %p (%s): deprecated GA ",
- gala->la, info_type(gala->la));
+ (StgClosure*)gala->la, info_type((StgClosure*)gala->la));
printGA(&(q->ga));
fputc('\n', stderr));
}
n,m));
}
+/*
+ Determine the size of the LAGA and GALA tables.
+ Has to be done after rebuilding the tables.
+ Only used for global statistics gathering.
+*/
+
+//@cindex getLAGAtableSize
+void
+getLAGAtableSize(nat *nP, nat *sizeP)
+{
+ GALA *gala;
+ // nat n=0, tot_size=0;
+ StgClosure *closure;
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i;
+ char str[80];
+ /* IN order to avoid counting closures twice we maintain a hash table
+ of all closures seen so far.
+ ToDo: collect this data while rebuilding the GALA table and make use
+ of the existing hash tables;
+ */
+ HashTable *closureTable; // hash table for closures encountered already
+
+ closureTable = allocHashTable();
+
+ (*nP) = (*sizeP) = 0;
+ for (gala = liveIndirections; gala != NULL; gala = gala->next) {
+ closure = (StgClosure*) gala->la;
+ if (lookupHashTable(closureTable, (StgWord)closure)==NULL) { // not seen yet
+ insertHashTable(closureTable, (StgWord)closure, (void *)1);
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+ (*sizeP) += size ; // stats: measure total heap size of global closures
+ (*nP)++; // stats: count number of GAs
+ }
+ }
+
+ for (gala = liveRemoteGAs; gala != NULL; gala = gala->next) {
+ closure = (StgClosure*) gala->la;
+ if (lookupHashTable(closureTable, (StgWord)closure)==NULL) { // not seen yet
+ insertHashTable(closureTable, (StgWord)closure, (void *)1);
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+ (*sizeP) += size ; // stats: measure total heap size of global closures
+ (*nP)++; // stats: count number of GAs
+ }
+ }
+
+ freeHashTable(closureTable, NULL);
+}
+
//@node Debugging routines, Index, GC functions for GALA tables, Global Address Manipulation
//@subsection Debugging routines
printGALA (GALA *gala)
{
printGA(&(gala->ga));
- fprintf(stderr, " -> %p (%s)", (StgPtr)gala->la, info_type(gala->la));
- fprintf(stderr, " %s", (gala->preferred) ? "PREF" : "____");
+ fprintf(stderr, " -> %p (%s)",
+ (StgClosure*)gala->la, info_type((StgClosure*)gala->la));
+ fprintf(stderr, " %s",
+ (gala->preferred) ? "PREF" : "____");
}
/*
for (gl=freeGALAList; gl != NULL; gl=gl->next) {
ASSERT(gl->ga.weight==0xdead0add);
- ASSERT(gl->la==0xdead00aa);
+ ASSERT(gl->la==(StgPtr)0xdead00aa);
}
}
for (gl=freeIndirections; gl != NULL; gl=gl->next) {
ASSERT(gl->ga.weight==0xdead0add);
- ASSERT(gl->la==0xdead00aa);
+ ASSERT(gl->la==(StgPtr)0xdead00aa);
}
}
#endif /* PAR -- whole file */
/*
- Time-stamp: <Mon Mar 20 2000 19:18:25 Stardate: [-30]4534.02 hwloidl>
- $Id: GranSim.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Tue Mar 06 2001 00:17:42 Stardate: [-30]6285.06 hwloidl>
+ $Id: GranSim.c,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
Variables and functions specific to GranSim the parallelism simulator
for GPH.
IF_DEBUG(gran,
fprintf(stderr, "GRAN: new_event: \n");
- print_event(newentry))
+ print_event(newentry));
}
//@cindex prepend_event
# endif
barf("//// do_the_fetchnode: out of heap after handleFetchRequest; ToDo: call GarbageCollect()");
prepend_event(event);
- performGC(); // GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots, rtsFalse);
// HWL: ToDo: check whether a ContinueThread has to be issued
// HWL old: ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
# if 0 && defined(GRAN_CHECK) && defined(GRAN)
ASSERT(!is_on_queue(tso, from));
// ToDo: check whether graph is ever used as an rtsPackBuffer!!
- if ((graph = (StgClosure *)PackNearbyGraph(node, tso, &size)) == NULL)
+ if ((graph = (StgClosure *)PackNearbyGraph(node, tso, &size, 0)) == NULL)
return (OutOfHeap); /* out of heap */
/* Actual moving/copying of node is done on arrival; see FETCHREPLY */
}
IF_GRAN_DEBUG(randomSteal,
belch("^^ RANDOM_STEAL (fishing): stealing from PE %d (current proc is %d)",
- p, proc);)
+ p, proc));
return (PEs)p;
}
IF_DEBUG(gran,
belch("GRAN: TSO %d (%p) [PE %d] blocks on closure %p @ %lx",
- tso->id, tso, proc, node, CurrentTime[proc]);)
+ tso->id, tso, proc, node, CurrentTime[proc]));
/* THIS SHOULD NEVER HAPPEN!
/* --------------------------------------------------------------------------
- Time-stamp: <Wed Mar 29 2000 19:09:41 Stardate: [-30]4578.78 hwloidl>
- $Id: GranSimRts.h,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Tue Mar 06 2001 00:18:30 Stardate: [-30]6285.06 hwloidl>
+ $Id: GranSimRts.h,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
Variables and functions specific to GranSim.
----------------------------------------------------------------------- */
//* Statistics gathering::
//* Prototypes::
//@end menu
+//*/ fool highlight
//@node Event queue, Spark handling routines, Headers for GranSim objs used only in the RTS internally, Headers for GranSim objs used only in the RTS internally
//@subsection Event queue
nat tot_sparks_created, sparks_created_on_PE[MAX_PROC];
/* scheduling stats */
- nat tot_yields;
+ nat tot_yields, tot_stackover, tot_heapover;
/* blocking queue statistics */
rtsTime tot_bq_processing_time;
/* For debugging */
rtsBool is_on_queue (StgTSO *tso, PEs proc);
+#endif
-/* Interface for dumping routines (i.e. writing to log file) */
+#if defined(GRAN) || defined(PAR)
+/*
+ Interface for dumping routines (i.e. writing to log file).
+ These routines are shared with GUM (and could also be used for SMP).
+*/
void DumpGranEvent(GranEventType name, StgTSO *tso);
void DumpEndEvent(PEs proc, StgTSO *tso, rtsBool mandatory_thread);
void DumpTSO(StgTSO *tso);
void DumpRawGranEvent(PEs proc, PEs p, GranEventType name,
- StgTSO *tso, StgClosure *node, StgInt sparkname, StgInt len);
-
+ StgTSO *tso, StgClosure *node,
+ StgInt sparkname, StgInt len);
+void DumpVeryRawGranEvent(rtsTime time, PEs proc, PEs p, GranEventType name,
+ StgTSO *tso, StgClosure *node,
+ StgInt sparkname, StgInt len);
#endif
#endif /* GRANSIM_RTS_H */
/* --------------------------------------------------------------------------
- Time-stamp: <Sun Dec 05 1999 21:02:36 Stardate: [-30]4004.38 hwloidl>
- $Id: HLC.h,v 1.2 2000/01/13 14:34:07 hwloidl Exp $
+ Time-stamp: <Sun Mar 18 2001 20:16:14 Stardate: [-30]6349.22 hwloidl>
+ $Id: HLC.h,v 1.3 2001/03/22 03:51:11 hwloidl Exp $
High Level Communications Header (HLC.h)
rtsBool initMoreBuffers(void);
void sendFetch (globalAddr *ga, globalAddr *bqga, int load);
-void sendResume(globalAddr *rga, int nelem, rtsPackBuffer *data);
+void sendResume(globalAddr *rga, int nelem, rtsPackBuffer *packBuffer);
void sendAck (GlobalTaskId task, int ngas, globalAddr *gagamap);
void sendFish (GlobalTaskId destPE, GlobalTaskId origPE, int age, int history, int hunger);
void sendFree (GlobalTaskId destPE, int nelem, P_ data);
-void sendSchedule(GlobalTaskId origPE, int nelem, rtsPackBuffer *data);
+void sendSchedule(GlobalTaskId origPE, int nelem, rtsPackBuffer *packBuffer);
+void sendReval(GlobalTaskId origPE, int nelem, rtsPackBuffer *data);
//@node Message-Processing Functions
//@subsection Message-Processing Functions
-void processMessages(void);
+rtsBool processMessages(void);
void processFetches(void);
void processTheRealFetches(void);
StgClosure *createBlockedFetch (globalAddr ga, globalAddr rga);
void waitForTermination(void);
+/* Message bouncing (startup and shutdown, mainly) */
+void bounceFish(void);
+void bounceReval(void);
+
void DebugPrintGAGAMap (globalAddr *gagamap, int nGAs);
#endif /* PAR */
/* ----------------------------------------------------------------------------
- * Time-stamp: <Wed Mar 29 2000 19:35:36 Stardate: [-30]4578.87 hwloidl>
- * $Id: HLComms.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ * Time-stamp: <Wed Mar 21 2001 16:34:41 Stardate: [-30]6363.45 hwloidl>
+ * $Id: HLComms.c,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
*
* High Level Communications Routines (HLComms.lc)
*
* Contains the high-level routines (i.e. communication
* subsystem independent) used by GUM
*
- * Phil Trinder, Glasgow University, 12 December 1994
- * Adapted for new RTS
- * Phil Trinder, Simon Marlow July 1998
- * H-W. Loidl, Heriot-Watt University, November 1999
+ * GUM 0.2x: Phil Trinder, Glasgow University, 12 December 1994
+ * GUM 3.xx: Phil Trinder, Simon Marlow July 1998
+ * GUM 4.xx: H-W. Loidl, Heriot-Watt University, November 1999 -
*
* ------------------------------------------------------------------------- */
#include "Parallel.h"
#include "GranSimRts.h"
#include "ParallelRts.h"
+#include "Sparks.h"
#include "FetchMe.h" // for BLOCKED_FETCH_info etc
#if defined(DEBUG)
# include "ParallelDebug.h"
#endif
#include "StgMacros.h" // inlined IS_... fcts
+#ifdef DIST
+#include "SchedAPI.h" //for createIOThread
+extern unsigned int context_switch;
+#endif DIST
+
//@node GUM Message Sending and Unpacking Functions, Message-Processing Functions, Includes, High Level Communications Routines
//@subsection GUM Message Sending and Unpacking Functions
{
ASSERT(rga->weight > 0 && lga->weight > 0);
IF_PAR_DEBUG(fetch,
- belch("** [%x] Sending Fetch for ((%x, %d, 0)); locally ((%x, %d, %x)), load = %d",
- mytid,
+ belch("~^** Sending Fetch for ((%x, %d, 0)); locally ((%x, %d, %x)), load = %d",
rga->payload.gc.gtid, rga->payload.gc.slot,
lga->payload.gc.gtid, lga->payload.gc.slot, lga->weight,
load));
GetArgs(buf, 6);
IF_PAR_DEBUG(fetch,
- belch("** [%x] Unpacking Fetch for ((%x, %d, 0)) to ((%x, %d, %x)), load = %d",
- mytid,
+ belch("~^** Unpacking Fetch for ((%x, %d, 0)) to ((%x, %d, %x)), load = %d",
(GlobalTaskId) buf[0], (int) buf[1],
(GlobalTaskId) buf[3], (int) buf[4], buf[2], buf[5]));
//@cindex sendResume
void
-sendResume(globalAddr *rga, int nelem, rtsPackBuffer *data) // StgPtr data)
+sendResume(globalAddr *rga, int nelem, rtsPackBuffer *packBuffer)
{
- IF_PAR_DEBUG(resume,
- PrintPacket(data);
- belch("[] [%x] Sending Resume for ((%x, %d, %x))",
- mytid,
- rga->payload.gc.gtid, rga->payload.gc.slot, rga->weight));
+ IF_PAR_DEBUG(fetch,
+ belch("~^[] Sending Resume (packet <<%d>> with %d elems) for ((%x, %d, %x)) to [%x]",
+ packBuffer->id, nelem,
+ rga->payload.gc.gtid, rga->payload.gc.slot, rga->weight,
+ rga->payload.gc.gtid));
+ IF_PAR_DEBUG(packet,
+ PrintPacket(packBuffer));
+
+ ASSERT(nelem==packBuffer->size);
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+nelem) == END_OF_BUFFER_MARKER));
sendOpNV(PP_RESUME, rga->payload.gc.gtid,
- nelem + PACK_BUFFER_HDR_SIZE, (StgPtr)data,
+ nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM, (StgPtr)packBuffer,
2, (rtsWeight) rga->weight, (StgWord) rga->payload.gc.slot);
}
//@cindex unpackResume
static void
-unpackResume(globalAddr *lga, int *nelem, rtsPackBuffer *data)
+unpackResume(globalAddr *lga, int *nelem, rtsPackBuffer *packBuffer)
{
long buf[3];
GetArgs(buf, 3);
- IF_PAR_DEBUG(resume,
- belch("[] [%x] Unpacking Resume for ((%x, %d, %x))",
- mytid, mytid,
- (int) buf[1], (unsigned) buf[0]));
-
/*
RESUME event is written in awaken_blocked_queue
DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(lga->payload.gc.gtid),
lga->payload.gc.gtid = mytid;
lga->payload.gc.slot = (int) buf[1];
- *nelem = (int) buf[2]; // includes PACK_BUFFER_HDR_SIZE;
- GetArgs(data, *nelem);
- *nelem -= PACK_BUFFER_HDR_SIZE;
+ *nelem = (int) buf[2] - PACK_BUFFER_HDR_SIZE - DEBUG_HEADROOM;
+ GetArgs(packBuffer, *nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM);
+
+ IF_PAR_DEBUG(fetch,
+ belch("~^[] Unpacking Resume (packet <<%d>> with %d elems) for ((%x, %d, %x))",
+ packBuffer->id, *nelem, mytid, (int) buf[1], (unsigned) buf[0]));
+
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+*nelem) == END_OF_BUFFER_MARKER));
}
/*
long *p;
int i;
+ if(ngas==0)
+ return; //don't send unnecessary messages!!
+
buffer = (long *) gumPackBuffer;
for(i = 0, p = buffer; i < ngas; i++, p += 6) {
gagamap++;
}
IF_PAR_DEBUG(schedule,
- belch(",, [%x] Sending Ack (%d pairs) to PE %x\n",
- mytid, ngas, task));
+ belch("~^,, Sending Ack (%d pairs) to [%x]\n",
+ ngas, task));
- sendOpN(PP_ACK, task, p - buffer, buffer);
+ sendOpN(PP_ACK, task, p - buffer, (StgPtr)buffer);
}
/*
*ngas = GAarraysize / 6;
IF_PAR_DEBUG(schedule,
- belch(",, [%x] Unpacking Ack (%d pairs) on %x\n",
- mytid, *ngas, mytid));
+ belch("~^,, Unpacking Ack (%d pairs) on [%x]\n",
+ *ngas, mytid));
while (GAarraysize > 0) {
GetArgs(buf, 6);
int age, int history, int hunger)
{
IF_PAR_DEBUG(fish,
- belch("$$ [%x] Sending Fish to %x (%d outstanding fishes)",
- mytid, destPE, outstandingFishes));
+ belch("~^$$ Sending Fish to [%x] (%d outstanding fishes)",
+ destPE, outstandingFishes));
sendOpV(PP_FISH, destPE, 4,
(StgWord) origPE, (StgWord) age, (StgWord) history, (StgWord) hunger);
GetArgs(buf, 4);
IF_PAR_DEBUG(fish,
- belch("$$ [%x] Unpacking Fish from PE %x (age=%d)",
- mytid, (GlobalTaskId) buf[0], (int) buf[1]));
+ belch("~^$$ Unpacking Fish from [%x] (age=%d)",
+ (GlobalTaskId) buf[0], (int) buf[1]));
*origPE = (GlobalTaskId) buf[0];
*age = (int) buf[1];
sendFree(GlobalTaskId pe, int nelem, StgPtr data)
{
IF_PAR_DEBUG(free,
- belch("!! [%x] Sending Free (%d GAs) to %x",
- mytid, nelem/2, pe));
+ belch("~^!! Sending Free (%d GAs) to [%x]",
+ nelem/2, pe));
sendOpN(PP_FREE, pe, nelem, data);
}
*/
//@cindex unpackFree
static void
-unpackFree(int *nelem, rtsPackBuffer *data)
+unpackFree(int *nelem, StgWord *data)
{
long buf[1];
*nelem = (int) buf[0];
IF_PAR_DEBUG(free,
- belch("!! [%x] Unpacking Free (%d GAs)",
- mytid, *nelem/2));
+ belch("~^!! Unpacking Free (%d GAs)",
+ *nelem/2));
GetArgs(data, *nelem);
}
*/
//@cindex sendSchedule
void
-sendSchedule(GlobalTaskId origPE, int nelem, rtsPackBuffer *data) // StgPtr data)
+sendSchedule(GlobalTaskId origPE, int nelem, rtsPackBuffer *packBuffer)
{
IF_PAR_DEBUG(schedule,
- PrintPacket(data);
- belch("-- [%x] Sending Schedule (%d elems) to %x\n",
- mytid, nelem, origPE));
+ belch("~^-- Sending Schedule (packet <<%d>> with %d elems) to [%x]\n",
+ packBuffer->id, nelem, origPE));
+ IF_PAR_DEBUG(packet,
+ PrintPacket(packBuffer));
- sendOpN(PP_SCHEDULE, origPE, nelem + PACK_BUFFER_HDR_SIZE, (StgPtr)data);
+ ASSERT(nelem==packBuffer->size);
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+nelem) == END_OF_BUFFER_MARKER));
+
+ sendOpN(PP_SCHEDULE, origPE,
+ nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM, (StgPtr)packBuffer);
}
/*
//@cindex unpackSchedule
static void
-unpackSchedule(int *nelem, rtsPackBuffer *data)
+unpackSchedule(int *nelem, rtsPackBuffer *packBuffer)
{
- long buf[1];
+ long buf[1];
+
+ /* first, just unpack 1 word containing the total size (including header) */
+ GetArgs(buf, 1);
+ /* no. of elems, not counting the header of the pack buffer */
+ *nelem = (int) buf[0] - PACK_BUFFER_HDR_SIZE - DEBUG_HEADROOM;
- GetArgs(buf, 1);
- /* no. of elems, not counting the header of the pack buffer */
- *nelem = (int) buf[0] - PACK_BUFFER_HDR_SIZE;
+ /* automatic cast of flat pvm-data to rtsPackBuffer */
+ GetArgs(packBuffer, *nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM);
- IF_PAR_DEBUG(schedule,
- belch("-- [%x] Unpacking Schedule (%d elems) on %x\n",
- mytid, *nelem));
+ IF_PAR_DEBUG(schedule,
+ belch("~^-- Unpacking Schedule (packet <<%d>> with %d elems) on [%x]\n",
+ packBuffer->id, *nelem, mytid));
- /* automatic cast of flat pvm-data to rtsPackBuffer */
- GetArgs(data, *nelem + PACK_BUFFER_HDR_SIZE);
+ ASSERT(*nelem==packBuffer->size);
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+*nelem) == END_OF_BUFFER_MARKER));
}
+#ifdef DIST
+/* sendReval is almost identical to the Schedule version, so we can unpack with unpackSchedule */
+void
+sendReval(GlobalTaskId origPE, int nelem, rtsPackBuffer *packBuffer)
+{
+ IF_PAR_DEBUG(schedule,
+ belch("~^-- Sending Reval (packet <<%d>> with %d elems) to [%x]\n",
+ packBuffer->id, nelem, origPE));
+ IF_PAR_DEBUG(packet,
+ PrintPacket(packBuffer));
+
+ ASSERT(nelem==packBuffer->size);
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*(packBuffer->buffer+nelem) == END_OF_BUFFER_MARKER));
+
+ sendOpN(PP_REVAL, origPE,
+ nelem + PACK_BUFFER_HDR_SIZE + DEBUG_HEADROOM, (StgPtr)packBuffer);
+}
+
+void FinishReval(StgTSO *t)
+{ StgClosure *res;
+ globalAddr ga;
+ nat size;
+ rtsPackBuffer *buffer=NULL;
+
+ ga.payload.gc.slot = t->revalSlot;
+ ga.payload.gc.gtid = t->revalTid;
+ ga.weight = 0;
+
+ //find where the reval result is
+ res = GALAlookup(&ga);
+ ASSERT(res);
+
+ IF_PAR_DEBUG(schedule,
+ printGA(&ga);
+ belch(" needs the result %08x\n",res));
+
+ //send off the result
+ buffer = PackNearbyGraph(res, END_TSO_QUEUE, &size,ga.payload.gc.gtid);
+ ASSERT(buffer != (rtsPackBuffer *)NULL);
+ sendResume(&ga, size, buffer);
+
+ IF_PAR_DEBUG(schedule,
+ belch("@;~) Reval Finished"));
+}
+
+#endif DIST
+
//@node Message-Processing Functions, GUM Message Processor, GUM Message Sending and Unpacking Functions, High Level Communications Routines
//@subsection Message-Processing Functions
sendFetch(((StgFetchMe *)closure)->ga, &rga, 0 /* load */);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fetch_mess++;
+ }
+
IF_PAR_DEBUG(fetch,
belch("__-> processFetches: Forwarding fetch from %lx to %lx",
mytid, rga.payload.gc.gtid));
belch("__*> processFetches: PackNearbyGraph of closure %p (%s)",
closure, info_type(closure)));
- if ((packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size)) == NULL) {
+ if ((packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, bf->ga.payload.gc.gtid)) == NULL) {
// Put current BF back on list
bf->link = (StgBlockingQueueElement *)PendingFetches;
PendingFetches = (StgBlockedFetch *)bf;
// ToDo: check that nothing more has to be done to prepare for GC!
barf("processFetches: out of heap while packing graph; ToDo: call GC here");
- GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots, rtsFalse);
bf = PendingFetches;
PendingFetches = (StgBlockedFetch *)(bf->link);
closure = bf->node;
- packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size);
+ packBuffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, bf->ga.payload.gc.gtid);
ASSERT(packBuffer != (rtsPackBuffer *)NULL);
}
rga.payload.gc.gtid = bf->ga.payload.gc.gtid;
rga.weight = bf->ga.weight;
sendResume(&rga, size, packBuffer);
+
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_resume_mess++;
+ }
}
}
PendingFetches = END_BF_QUEUE;
#endif
+/*
+ Way of dealing with unwanted fish.
+ Used during startup/shutdown, or from unknown PEs
+*/
+void
+bounceFish(void) {
+ GlobalTaskId origPE;
+ int age, history, hunger;
+
+ /* IF_PAR_DEBUG(verbose, */
+ belch(".... [%x] Bouncing unwanted FISH",mytid);
+
+ unpackFish(&origPE, &age, &history, &hunger);
+
+ if (origPE == mytid) {
+ //fishing = rtsFalse; // fish has come home
+ outstandingFishes--;
+ last_fish_arrived_at = CURRENT_TIME; // remember time (see schedule fct)
+ return; // that's all
+ }
+
+ /* otherwise, send it home to die */
+ sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fish_mess++;
+ }
+}
+
/*
* processFish unpacks a fish message, reissuing it if it's our own,
* sending work if we have it or sending it onwards otherwise.
IF_PAR_DEBUG(fish,
belch("$$__ processing fish; %d sparks available",
spark_queue_len(&(MainRegTable.rSparks))));
- while ((spark = findSpark()) != NULL) {
+ while ((spark = findSpark(rtsTrue/*for_export*/)) != NULL) {
nat size;
// StgClosure *graph;
packBuffer = gumPackBuffer;
ASSERT(closure_SHOULD_SPARK((StgClosure *)spark));
- if ((packBuffer = PackNearbyGraph(spark, END_TSO_QUEUE, &size)) == NULL) {
+ if ((packBuffer = PackNearbyGraph(spark, END_TSO_QUEUE, &size,origPE)) == NULL) {
IF_PAR_DEBUG(fish,
belch("$$ GC while trying to satisfy FISH via PackNearbyGraph of node %p",
(StgClosure *)spark));
barf("processFish: out of heap while packing graph; ToDo: call GC here");
- GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots, rtsFalse);
/* Now go back and try again */
} else {
+ IF_PAR_DEBUG(verbose,
+ if (RtsFlags.ParFlags.ParStats.Sparks)
+ belch("==== STEALING spark %x; sending to %x", spark, origPE));
+
IF_PAR_DEBUG(fish,
belch("$$-- Replying to FISH from %x by sending graph @ %p (%s)",
origPE,
(StgClosure *)spark, info_type((StgClosure *)spark)));
sendSchedule(origPE, size, packBuffer);
disposeSpark(spark);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_schedule_mess++;
+ }
+
break;
}
}
belch("$$^^ No sparks available for FISH from %x",
origPE));
/* We have no sparks to give */
- if (age < FISH_LIFE_EXPECTANCY)
+ if (age < FISH_LIFE_EXPECTANCY) {
/* and the fish is atill young, send it to another PE to look for work */
sendFish(choosePE(), origPE,
(age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
- /* otherwise, send it home to die */
- else
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fish_mess++;
+ }
+ } else { /* otherwise, send it home to die */
sendFish(origPE, origPE, (age + 1), NEW_FISH_HISTORY, NEW_FISH_HUNGER);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fish_mess++;
+ }
}
+ }
} /* processFish */
/*
if (ip->type == FETCH_ME) {
/* Forward the Fetch to someone else */
sendFetch(((StgFetchMe *)closure)->ga, &rga, load);
+
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fetch_mess++;
+ }
} else if (rga.payload.gc.gtid == mytid) {
/* Our own FETCH forwarded back around to us */
StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)GALAlookup(&rga);
IF_PAR_DEBUG(fetch,
belch("%%%%== Fetch returned to sending PE; closure=%p (%s); receiver=%p (%s)",
- closure, info_type(closure), fmbq, info_type(fmbq)));
+ closure, info_type(closure), fmbq, info_type((StgClosure*)fmbq)));
/* We may have already discovered that the fetch target is our own. */
if ((StgClosure *)fmbq != closure)
CommonUp((StgClosure *)fmbq, closure);
/* This includes RBH's and FMBQ's */
StgBlockedFetch *bf;
+ /* Can we assert something on the remote GA? */
ASSERT(GALAlookup(&rga) == NULL);
/* If we're hitting a BH or RBH or FMBQ we have to put a BLOCKED_FETCH
closure into the BQ in order to denote that when updating this node
the result should be sent to the originator of this fetch message. */
bf = (StgBlockedFetch *)createBlockedFetch(ga, rga);
- blockFetch(bf, closure);
-
IF_PAR_DEBUG(fetch,
belch("%%++ Blocking Fetch ((%x, %d, %x)) on %p (%s)",
rga.payload.gc.gtid, rga.payload.gc.slot, rga.weight,
closure, info_type(closure)));
- } else {
- /* The target of the FetchMe is some local graph */
- nat size;
- // StgClosure *graph;
- rtsPackBuffer *buffer = (rtsPackBuffer *)NULL;
-
- if ((buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size)) == NULL) {
- barf("processFetch: out of heap while packing graph; ToDo: call GC here");
- GarbageCollect(GetRoots);
- closure = GALAlookup(&ga);
- buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size);
- ASSERT(buffer != (rtsPackBuffer *)NULL);
- }
- sendResume(&rga, size, buffer);
+ blockFetch(bf, closure);
+ } else {
+ /* The target of the FetchMe is some local graph */
+ nat size;
+ // StgClosure *graph;
+ rtsPackBuffer *buffer = (rtsPackBuffer *)NULL;
+
+ if ((buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, rga.payload.gc.gtid)) == NULL) {
+ barf("processFetch: out of heap while packing graph; ToDo: call GC here");
+ GarbageCollect(GetRoots, rtsFalse);
+ closure = GALAlookup(&ga);
+ buffer = PackNearbyGraph(closure, END_TSO_QUEUE, &size, rga.payload.gc.gtid);
+ ASSERT(buffer != (rtsPackBuffer *)NULL);
}
+ sendResume(&rga, size, buffer);
+
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_resume_mess++;
+ }
+ }
+}
+
+/*
+ The list of pending fetches must be a root-list for GC.
+ This routine is called from GC.c (same as marking GAs etc).
+*/
+void
+markPendingFetches(rtsBool major_gc) {
+
+ /* No need to traverse the list; this is done via the scavenge code
+ for a BLOCKED_FETCH closure, which evacuates the link field */
+
+ if (PendingFetches != END_BF_QUEUE ) {
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, "@@@@ PendingFetches is root; evaced from %p to",
+ PendingFetches));
+
+ PendingFetches = MarkRoot((StgClosure*)PendingFetches);
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, " %p\n", PendingFetches));
+
+ } else {
+ IF_PAR_DEBUG(tables,
+ fprintf(stderr, "@@@@ PendingFetches is empty; no need to mark it\n"));
+ }
}
/*
globalAddr lga;
globalAddr *gagamap;
- packBuffer = gumPackBuffer;
- unpackResume(&lga, &nelem, (StgPtr)packBuffer);
+ packBuffer = (rtsPackBuffer *)gumPackBuffer;
+ unpackResume(&lga, &nelem, packBuffer);
- IF_PAR_DEBUG(resume,
+ IF_PAR_DEBUG(fetch,
fprintf(stderr, "[]__ Rcvd Resume for ");
printGA(&lga);
- fputc('\n', stderr);
+ fputc('\n', stderr));
+ IF_PAR_DEBUG(packet,
PrintPacket((rtsPackBuffer *)packBuffer));
/*
old = GALAlookup(&lga);
+ /* ToDo: The closure that requested this graph must be one of these two?*/
+ ASSERT(get_itbl(old)->type == FETCH_ME_BQ ||
+ get_itbl(old)->type == RBH);
+
if (RtsFlags.ParFlags.ParStats.Full) {
- // StgTSO *tso = END_TSO_QUEUE;
- StgBlockingQueueElement *bqe;
+ StgBlockingQueueElement *bqe, *last_bqe;
+
+ IF_PAR_DEBUG(fetch,
+ belch("[]-- Resume is REPLY to closure %lx", old));
/* Write REPLY events to the log file, indicating that the remote
- data has arrived */
- if (get_itbl(old)->type == FETCH_ME_BQ ||
- get_itbl(old)->type == RBH)
- for (bqe = ((StgFetchMeBlockingQueue *)old)->blocking_queue;
- bqe->link != END_BQ_QUEUE;
- bqe = bqe->link)
- if (get_itbl((StgClosure *)bqe)->type == TSO)
- DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(sender),
- GR_REPLY, ((StgTSO *)bqe), ((StgTSO *)bqe)->block_info.closure,
- 0, spark_queue_len(&(MainRegTable.rSparks)));
+ data has arrived
+ NB: we emit a REPLY only for the *last* elem in the queue; this is
+ the one that triggered the fetch message; all other entries
+ have just added themselves to the queue, waiting for the data
+ they know that has been requested (see entry code for FETCH_ME_BQ)
+ */
+ if ((get_itbl(old)->type == FETCH_ME_BQ ||
+ get_itbl(old)->type == RBH)) {
+ for (bqe = ((StgFetchMeBlockingQueue *)old)->blocking_queue,
+ last_bqe = END_BQ_QUEUE;
+ get_itbl(bqe)->type==TSO ||
+ get_itbl(bqe)->type==BLOCKED_FETCH;
+ last_bqe = bqe, bqe = bqe->link) { /* nothing */ }
+
+ ASSERT(last_bqe==END_BQ_QUEUE ||
+ get_itbl((StgClosure *)last_bqe)->type == TSO);
+
+ /* last_bqe now points to the TSO that triggered the FETCH */
+ if (get_itbl((StgClosure *)last_bqe)->type == TSO)
+ DumpRawGranEvent(CURRENT_PROC, taskIDtoPE(sender),
+ GR_REPLY, ((StgTSO *)last_bqe), ((StgTSO *)last_bqe)->block_info.closure,
+ 0, spark_queue_len(&(MainRegTable.rSparks)));
+ }
}
newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
if (get_itbl(old)->type == FETCH_ME_BQ)
CommonUp(old, newGraph);
+ IF_PAR_DEBUG(fetch,
+ belch("[]-- Ready to resume unpacked graph at %p (%s)",
+ newGraph, info_type(newGraph)));
+
IF_PAR_DEBUG(tables,
DebugPrintGAGAMap(gagamap, nGAs));
static void
processSchedule(GlobalTaskId sender)
{
- nat nelem, space_required, nGAs;
+ nat nelem, nGAs;
rtsBool success;
static rtsPackBuffer *packBuffer;
StgClosure *newGraph;
packBuffer = gumPackBuffer; /* HWL */
unpackSchedule(&nelem, packBuffer);
+ IF_PAR_DEBUG(schedule,
+ belch("--__ Rcvd Schedule (%d elems)", nelem));
IF_PAR_DEBUG(packet,
- belch("--__ Rcvd Schedule (%d elems)", nelem);
PrintPacket(packBuffer));
/*
ASSERT(newGraph != NULL);
success = add_to_spark_queue(newGraph, &(MainRegTable.rSparks));
- IF_PAR_DEBUG(packet,
+ if (RtsFlags.ParFlags.ParStats.Full &&
+ RtsFlags.ParFlags.ParStats.Sparks &&
+ success)
+ DumpRawGranEvent(CURRENT_PROC, CURRENT_PROC,
+ GR_STOLEN, ((StgTSO *)NULL), newGraph,
+ 0, 0 /* spark_queue_len(ADVISORY_POOL) */);
+
+ IF_PAR_DEBUG(schedule,
if (success)
- belch("--^^ added spark to unpacked graph %p; %d sparks available on [%x]",
- newGraph, spark_queue_len(&(MainRegTable.rSparks)), mytid);
+ belch("--^^ added spark to unpacked graph %p (%s); %d sparks available on [%x] (%s)",
+ newGraph, info_type(newGraph), spark_queue_len(&(MainRegTable.rSparks)), mytid);
else
- belch("--^^ received non-sparkable closure %p; nothing added to spark pool; %d sparks available on [%x]",
- newGraph, spark_queue_len(&(MainRegTable.rSparks)), mytid);
+ belch("--^^ received non-sparkable closure %p (%s); nothing added to spark pool; %d sparks available on [%x]",
+ newGraph, info_type(newGraph), spark_queue_len(&(MainRegTable.rSparks)), mytid));
+ IF_PAR_DEBUG(packet,
belch("*< Unpacked graph with root at %p (%s):",
newGraph, info_type(newGraph));
PrintGraph(newGraph, 0));
IF_PAR_DEBUG(tables,
DebugPrintGAGAMap(gagamap, nGAs));
- if (nGAs > 0)
- sendAck(sender, nGAs, gagamap);
+ sendAck(sender, nGAs, gagamap);
//fishing = rtsFalse;
ASSERT(outstandingFishes>0);
ASSERT(get_itbl(old_closure)==RBH);
*/
if (get_itbl(old_closure)->type==RBH)
- convertToFetchMe(old_closure, ga);
+ convertToFetchMe((StgRBH *)old_closure, ga);
} else {
/*
* Oops...we've got this one already; update the RBH to
IF_DEBUG(sanity, checkLAGAtable(rtsFalse));
}
+#ifdef DIST
+
+void
+bounceReval(void) {
+ barf("Task %x: TODO: should send NACK in response to REVAL",mytid);
+}
+
+static void
+processReval(GlobalTaskId sender) //similar to schedule...
+{ nat nelem, space_required, nGAs;
+ static rtsPackBuffer *packBuffer;
+ StgClosure *newGraph;
+ globalAddr *gagamap;
+ StgTSO* tso;
+ globalAddr *ga;
+
+ packBuffer = gumPackBuffer; /* HWL */
+ unpackSchedule(&nelem, packBuffer); /* okay, since the structure is the same */
+
+ IF_PAR_DEBUG(packet,
+ belch("@;~) [%x] Rcvd Reval (%d elems)", mytid, nelem);
+ PrintPacket(packBuffer));
+
+ /*
+ space_required = packBuffer[0];
+ if (SAVE_Hp + space_required >= SAVE_HpLim) {
+ ReallyPerformThreadGC(space_required, rtsFalse);
+ SAVE_Hp -= space_required;
+ }
+ */
+
+ // ToDo: check whether GC is necessary !!!!!!!!!!!!!!!!!!!!!
+ newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
+ ASSERT(newGraph != NULL);
+
+ IF_PAR_DEBUG(packet,
+ belch("@;~) Unpacked graph with root at %p (%s):",
+ newGraph, info_type(newGraph));
+ PrintGraph(newGraph, 0));
+
+ IF_PAR_DEBUG(tables,
+ DebugPrintGAGAMap(gagamap, nGAs));
+
+ IF_PAR_DEBUG(tables,
+ printLAGAtable();
+ DebugPrintGAGAMap(gagamap, nGAs));
+
+ //We don't send an Ack to the head!!!!
+ ASSERT(nGAs>0);
+ sendAck(sender, nGAs-1, gagamap+2);
+
+ IF_PAR_DEBUG(verbose,
+ belch("@;~) About to create Reval thread on behalf of %x",
+ sender));
+
+ tso=createGenThread(RtsFlags.GcFlags.initialStkSize,newGraph);
+ tso->priority=RevalPriority;
+ tso->revalSlot=gagamap->payload.gc.slot;//record who sent the reval
+ tso->revalTid =gagamap->payload.gc.gtid;
+ scheduleThread(tso);
+ context_switch = 1; // switch at the earliest opportunity
+}
+#endif
+
+
//@node GUM Message Processor, Miscellaneous Functions, Message-Processing Functions, High Level Communications Routines
//@subsection GUM Message Processor
*/
//@cindex processMessages
-void
+rtsBool
processMessages(void)
{
rtsPacket packet;
OpCode opcode;
GlobalTaskId task;
-
+ rtsBool receivedFinish = rtsFalse;
+
do {
packet = GetPacket(); /* Get next message; block until one available */
getOpcodeAndSender(packet, &opcode, &task);
- switch (opcode) {
- case PP_FINISH:
- IF_PAR_DEBUG(verbose,
- belch("==== received FINISH [%p]", mytid));
- /* setting this global variables eventually terminates the main
- scheduling loop for this PE and causes a shut-down, sending
- PP_FINISH to SysMan */
- GlobalStopPending = rtsTrue;
- break;
-
- case PP_FETCH:
- processFetch();
- break;
-
- case PP_RESUME:
- processResume(task);
- break;
-
- case PP_ACK:
- processAck();
- break;
-
- case PP_FISH:
- processFish();
- break;
-
- case PP_FREE:
- processFree();
- break;
+ if (task==SysManTask) {
+ switch (opcode) {
+ case PP_PETIDS:
+ processPEtids();
+ break;
+
+ case PP_FINISH:
+ IF_PAR_DEBUG(verbose,
+ belch("==== received FINISH [%p]", mytid));
+ /* this boolean value is returned and propagated to the main
+ scheduling loop, thus shutting-down this PE */
+ receivedFinish = rtsTrue;
+ break;
+
+ default:
+ barf("Task %x: received unknown opcode %x from SysMan",mytid, opcode);
+ }
+ } else if (taskIDtoPE(task)==0) {
+ /* When a new PE joins then potentially FISH & REVAL message may
+ reach PES before they are notified of the new PEs existance. The
+ only solution is to bounce/fail these messages back to the sender.
+ But we will worry about it once we start seeing these race
+ conditions! */
+ switch (opcode) {
+ case PP_FISH:
+ bounceFish();
+ break;
+#ifdef DIST
+ case PP_REVAL:
+ bounceReval();
+ break;
+#endif
+ case PP_PETIDS:
+ belch("Task %x: Ignoring PVM session opened by another SysMan %x",mytid,task);
+ break;
+
+ case PP_FINISH:
+ break;
+
+ default:
+ belch("Task %x: Ignoring opcode %x from unknown PE %x",mytid, opcode, task);
+ }
+ } else
+ switch (opcode) {
+ case PP_FETCH:
+ processFetch();
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.rec_fetch_mess++;
+ }
+ break;
+
+ case PP_RESUME:
+ processResume(task);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.rec_resume_mess++;
+ }
+ break;
+
+ case PP_ACK:
+ processAck();
+ break;
+
+ case PP_FISH:
+ processFish();
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.rec_fish_mess++;
+ }
+ break;
+
+ case PP_FREE:
+ processFree();
+ break;
- case PP_SCHEDULE:
- processSchedule(task);
- break;
-
- default:
- /* Anything we're not prepared to deal with. */
- barf("Task %x: Unexpected opcode %x from %x",
- mytid, opcode, task);
- } /* switch */
+ case PP_SCHEDULE:
+ processSchedule(task);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.rec_schedule_mess++;
+ }
+ break;
+
+#ifdef DIST
+ case PP_REVAL:
+ processReval(task);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.rec_reval_mess++;
+ }
+ break;
+#endif
+
+ default:
+ /* Anything we're not prepared to deal with. */
+ barf("Task %x: Unexpected opcode %x from %x",
+ mytid, opcode, task);
+ } /* switch */
} while (PacketsWaiting()); /* While there are messages: process them */
+ return receivedFinish;
} /* processMessages */
//@node Miscellaneous Functions, Index, GUM Message Processor, High Level Communications Routines
switch (get_itbl(bh)->type) {
case BLACKHOLE:
bf->link = END_BQ_QUEUE;
- //((StgBlockingQueue *)bh)->header.info = &BLACKHOLE_BQ_info;
- SET_INFO(bh, &BLACKHOLE_BQ_info); // turn closure into a blocking queue
+ //((StgBlockingQueue *)bh)->header.info = &stg_BLACKHOLE_BQ_info;
+ SET_INFO(bh, &stg_BLACKHOLE_BQ_info); // turn closure into a blocking queue
((StgBlockingQueue *)bh)->blocking_queue = (StgBlockingQueueElement *)bf;
// put bh on the mutables list
(StgClosure *)bh, get_itbl((StgClosure *)bh),
info_type((StgClosure *)bh));
}
- IF_PAR_DEBUG(schedule,
+ IF_PAR_DEBUG(bq,
belch("##++ blockFetch: after block the BQ of %p (%s) is:",
bh, info_type(bh));
print_bq(bh));
/*
- blockThread is called from the main scheduler whenever tso returns with
+ @blockThread@ is called from the main scheduler whenever tso returns with
a ThreadBlocked return code; tso has already been added to a blocking
queue (that's done in the entry code of the closure, because it is a
cheap operation we have to do in any case); the main purpose of this
void
blockThread(StgTSO *tso)
{
- globalAddr *remote_ga;
+ globalAddr *remote_ga=NULL;
globalAddr *local_ga;
globalAddr fmbq_ga;
end this point; if something (eg. GC) happens inbetween the whole
thing will blow up
The problem is that the ga field of the FETCH_ME has been overwritten
- with the head of the blocking (which is tso).
+ with the head of the blocking queue (which is tso).
*/
- //ASSERT(looks_like_ga((globalAddr *)tso->link));
- ASSERT(tso->link!=END_TSO_QUEUE && tso->link!=NULL);
- remote_ga = (globalAddr *)tso->link; // ((StgFetchMe *)tso->block_info.closure)->ga;
- tso->link = END_BQ_QUEUE;
+ ASSERT(looks_like_ga(&theGlobalFromGA));
+ // ASSERT(tso->link!=END_TSO_QUEUE && tso->link!=NULL);
+ remote_ga = &theGlobalFromGA; //tso->link;
+ tso->link = (StgTSO*)END_BQ_QUEUE;
/* it was tso which turned node from FETCH_ME into FETCH_ME_BQ =>
we have to send a Fetch message here! */
if (RtsFlags.ParFlags.ParStats.Full) {
/* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
tso->par.exectime += CURRENT_TIME - tso->par.blockedat;
tso->par.fetchcount++;
tso->par.blockedat = CURRENT_TIME;
/* we are about to send off a FETCH message, so dump a FETCH event */
DumpRawGranEvent(CURRENT_PROC,
taskIDtoPE(remote_ga->payload.gc.gtid),
- GR_FETCH, tso, tso->block_info.closure, 0);
+ GR_FETCH, tso, tso->block_info.closure, 0, 0);
}
/* Phil T. claims that this was a workaround for a hard-to-find
* bug, hence I'm leaving it out for now --SDM
/* Assign a brand-new global address to the newly created FMBQ */
local_ga = makeGlobal(tso->block_info.closure, rtsFalse);
splitWeight(&fmbq_ga, local_ga);
- ASSERT(fmbq_ga.weight == 1L << (BITS_IN(unsigned) - 1));
+ ASSERT(fmbq_ga.weight == 1U << (BITS_IN(unsigned) - 1));
sendFetch(remote_ga, &fmbq_ga, 0/*load*/);
+ // Global statistics: count no. of fetches
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_fetch_mess++;
+ }
+
+ IF_DEBUG(sanity,
+ theGlobalFromGA.payload.gc.gtid = (GlobalTaskId)0);
break;
case BlockedOnGA_NoSend:
/* Fetch message has been sent already */
if (RtsFlags.ParFlags.ParStats.Full) {
/* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
tso->par.exectime += CURRENT_TIME - tso->par.blockedat;
tso->par.blockcount++;
tso->par.blockedat = CURRENT_TIME;
/* dump a block event, because fetch has been sent already */
DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, tso, tso->block_info.closure, 0);
+ GR_BLOCK, tso, tso->block_info.closure, 0, 0);
}
break;
+ case BlockedOnMVar:
case BlockedOnBlackHole:
/* the closure must be a BLACKHOLE_BQ or an RBH; tso came in here via
BLACKHOLE(_BQ) or CAF_BLACKHOLE or RBH entry code */
- ASSERT(get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
+ ASSERT(get_itbl(tso->block_info.closure)->type==MVAR ||
+ get_itbl(tso->block_info.closure)->type==BLACKHOLE_BQ ||
get_itbl(tso->block_info.closure)->type==RBH);
/* if collecting stats update the execution time etc */
if (RtsFlags.ParFlags.ParStats.Full) {
/* Note that CURRENT_TIME may perform an unsafe call */
- //rtsTime now = CURRENT_TIME; /* Now */
tso->par.exectime += CURRENT_TIME - tso->par.blockedat;
tso->par.blockcount++;
tso->par.blockedat = CURRENT_TIME;
DumpRawGranEvent(CURRENT_PROC, thisPE,
- GR_BLOCK, tso, tso->block_info.closure, 0);
+ GR_BLOCK, tso, tso->block_info.closure, 0, 0);
}
break;
-
+
+ case BlockedOnDelay:
+ /* Whats sort of stats shall we collect for an explicit threadDelay? */
+ IF_PAR_DEBUG(verbose,
+ belch("##++ blockThread: TSO %d blocked on ThreadDelay",
+ tso->id));
+ break;
+
+ /* Check that the following is impossible to happen, indeed
+ case BlockedOnException:
+ case BlockedOnRead:
+ case BlockedOnWrite:
+ */
default:
barf("blockThread: impossible why_blocked code %d for TSO %d",
tso->why_blocked, tso->id);
}
- IF_PAR_DEBUG(schedule,
- belch("##++ blockThread: TSO %d blocked on closure %p (%s)",
- tso->id, tso->block_info.closure, info_type(tso->block_info.closure)));
+ IF_PAR_DEBUG(verbose,
+ belch("##++ blockThread: TSO %d blocked on closure %p (%s); %s",
+ tso->id, tso->block_info.closure, info_type(tso->block_info.closure),
+ (tso->why_blocked==BlockedOnGA) ? "Sent FETCH for GA" : ""));
+
+ IF_PAR_DEBUG(bq,
+ print_bq(tso->block_info.closure));
}
/*
StgClosure *closure;
closure = GALAlookup(&ga);
- if ((bf = (StgBlockedFetch *)allocate(FIXED_HS + sizeofW(StgBlockedFetch))) == NULL) {
+ if ((bf = (StgBlockedFetch *)allocate(_HS + sizeofW(StgBlockedFetch))) == NULL) {
barf("createBlockedFetch: out of heap while allocating heap for a BlocekdFetch; ToDo: call GC here");
- GarbageCollect(GetRoots);
+ GarbageCollect(GetRoots, rtsFalse);
closure = GALAlookup(&ga);
- bf = (StgBlockedFetch *)allocate(FIXED_HS + sizeofW(StgBlockedFetch));
+ bf = (StgBlockedFetch *)allocate(_HS + sizeofW(StgBlockedFetch));
// ToDo: check whether really guaranteed to succeed 2nd time around
}
- ASSERT(bf != (StgClosure *)NULL);
- SET_INFO((StgClosure *)bf, &BLOCKED_FETCH_info);
+ ASSERT(bf != (StgBlockedFetch *)NULL);
+ SET_INFO((StgClosure *)bf, &stg_BLOCKED_FETCH_info);
// ToDo: check whether other header info is needed
bf->node = closure;
bf->ga.payload.gc.gtid = rga.payload.gc.gtid;
IF_PAR_DEBUG(schedule,
fprintf(stderr, "%%%%// created BF: bf=%p (%s) of closure , GA: ",
- bf, info_type(bf), closure);
+ bf, info_type((StgClosure*)bf));
printGA(&(bf->ga));
fputc('\n',stderr));
- return bf;
+ return (StgClosure *)bf;
}
/*
{
do {
rtsPacket p = GetPacket();
- processUnexpected(p);
+ processUnexpectedMessage(p);
} while (rtsTrue);
}
{
nat i;
- for (i = 0; i < nGAs; ++i, gagamap += 2) {
+ for (i = 0; i < (nat)nGAs; ++i, gagamap += 2) {
ASSERT(looks_like_ga(gagamap));
ASSERT(looks_like_ga(gagamap+1));
}
"prepareFreeMsgBuffers (Buffer)");
for(i = 0; i < nPEs; i++)
- if (i != thisPE)
+ if (i != (thisPE-1))
freeMsgBuffer[i] = (StgPtr) stgMallocWords(RtsFlags.ParFlags.packBufferSize,
"prepareFreeMsgBuffers (Buffer #i)");
+ else
+ freeMsgBuffer[i] = 0;
}
/* Initialize the freeMsg buffer pointers to point to the start of their
sendFree(allPEs[i], freeMsgIndex[i], freeMsgBuffer[i]);
}
+/* synchronises with the other PEs. Receives and records in a global
+ * variable the task-id of SysMan. If this is the main thread (discovered
+ * in main.lc), identifies itself to SysMan. Finally it receives
+ * from SysMan an array of the Global Task Ids of each PE, which is
+ * returned as the value of the function.
+ */
+
+#if defined(PAR_TICKY)
+/* Has to see freeMsgIndex, so must be defined here not in ParTicky.c */
+//@cindex stats_CntFreeGA
+void
+stats_CntFreeGA (void) { // stats only
+
+ // Global statistics: residency of thread and spark pool
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ nat i, s;
+
+ globalParStats.cnt_free_GA++;
+ for (i = 0, s = 0; i < nPEs; i++)
+ s += globalParStats.tot_free_GA += freeMsgIndex[i]/2;
+
+ if ( s > globalParStats.res_free_GA )
+ globalParStats.res_free_GA = s;
+ }
+}
+#endif /* PAR_TICKY */
+
#endif /* PAR -- whole file */
//@node Index, , Miscellaneous Functions, High Level Communications Routines
/* --------------------------------------------------------------------------
- Time-stamp: <Tue Mar 21 2000 20:10:18 Stardate: [-30]4539.20 hwloidl>
- $Id: LLC.h,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Sun Mar 18 2001 21:23:50 Stardate: [-30]6349.45 hwloidl>
+ $Id: LLC.h,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
Low Level Communications Header (LLC.h)
#define PEGROUP "PE"
#define MGRGROUP "MGR"
-#define PECTLGROUP "PECTL"
+#define SYSGROUP "SYS"
#define PETASK "PE"
#define MAX_DATA_WORDS_IN_PACKET 1024
/* basic PVM packing */
-#define PutArg1(a) pvm_pklong(&(a),1,1)
-#define PutArg2(a) pvm_pklong(&(a),1,1)
-#define PutArgN(n,a) pvm_pklong(&(a),1,1)
-#define PutArgs(b,n) pvm_pklong(b,n,1)
+#define PutArg1(a) pvm_pklong((long *)&(a),1,1)
+#define PutArg2(a) pvm_pklong((long *)&(a),1,1)
+#define PutArgN(n,a) pvm_pklong((long *)&(a),1,1)
+#define PutArgs(b,n) pvm_pklong((long *)b,n,1)
#define PutLit(l) { int a = l; PutArgN(?,a); }
/* basic PVM unpacking */
-#define GetArg1(a) pvm_upklong(&(a),1,1)
-#define GetArg2(a) pvm_upklong(&(a),1,1)
-#define GetArgN(n,a) pvm_upklong(&(a),1,1)
-#define GetArgs(b,n) pvm_upklong(b,n,1)
+#define GetArg1(a) pvm_upklong((long *)&(a),1,1)
+#define GetArg2(a) pvm_upklong((long *)&(a),1,1)
+#define GetArgN(n,a) pvm_upklong((long *)&(a),1,1)
+#define GetArgs(b,n) pvm_upklong((long *)b,n,1)
//@node Externs, , PVM macros, Low Level Communications Header
//@subsection Externs
sendOpN (OpCode,GlobalTaskId,int,StgPtr),
sendOpNV (OpCode,GlobalTaskId,int,StgPtr,int,...);
+extern void broadcastOpN(OpCode op, char *group, int n, StgPtr args);
+
/* extracting data out of a packet */
OpCode getOpcode (rtsPacket p);
void getOpcodeAndSender (rtsPacket p, OpCode *popcode,
GlobalTaskId *psender_id);
GlobalTaskId senderTask (rtsPacket p);
-rtsPacket waitForPEOp (OpCode op, GlobalTaskId who);
+rtsPacket waitForPEOp(OpCode op, GlobalTaskId who, void(*processUnexpected)(rtsPacket) );
/* Init and shutdown routines */
-GlobalTaskId *startUpPE (unsigned nPEs);
+void startUpPE (void);
void shutDownPE(void);
+int getExitCode(int nbytes, GlobalTaskId *sender_idp);
/* aux functions */
char *getOpName (unsigned op); // returns string of opcode
-void processUnexpected (rtsPacket);
+void processUnexpectedMessage (rtsPacket);
//void NullException(void);
#endif /*PAR */
/* ----------------------------------------------------------------------------
- * Time-stamp: <Tue Mar 21 2000 20:23:41 Stardate: [-30]4539.24 hwloidl>
- * $Id: LLComms.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ * Time-stamp: <Mon Mar 19 2001 22:10:38 Stardate: [-30]6354.62 hwloidl>
+ * $Id: LLComms.c,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
*
* GUM Low-Level Inter-Task Communication
*
* This module defines PVM Routines for PE-PE communication.
+ *
* P. Trinder, December 5th. 1994.
- * Adapted for the new RTS
* P. Trinder, July 1998
- * H-W. Loidl, November 1999
+ * H-W. Loidl, November 1999 -
--------------------------------------------------------------------------- */
#ifdef PAR /* whole file */
traceSendOp(op, task, 0, 0);
IF_PAR_DEBUG(trace,
- fprintf(stderr,"sendOpNV: op = %x (%s), task = %x, narg = %d, nelem = %d",
+ fprintf(stderr,"~~ sendOpNV: op = %x (%s), task = %x, narg = %d, nelem = %d",
op, getOpName(op), task, narg, nelem));
pvm_initsend(PvmDataRaw);
for (i = 0; i < narg; ++i) {
arg = va_arg(ap, StgWord);
IF_PAR_DEBUG(trace,
- fprintf(stderr,"sendOpNV: arg = %d\n",arg));
+ fprintf(stderr,"~~ sendOpNV: arg = %d\n",arg));
PutArgN(i, arg);
}
arg = (StgWord) nelem;
pvm_send(task, op);
}
+/*
+ * broadcastOpN is as sendOpN but broadcasts to all members of a group.
+ */
+
+void
+broadcastOpN(OpCode op, char *group, int n, StgPtr args)
+{
+ long arg;
+
+ //traceSendOp(op, task, 0, 0);
+
+ pvm_initsend(PvmDataRaw);
+ arg = (long) n;
+ PutArgN(0, arg);
+ PutArgs(args, n);
+ pvm_bcast(group, op);
+}
+
/*
- * waitForPEOp waits for a packet from global task {\em who} with the
- * OpCode {\em op}. Other OpCodes are handled by processUnexpected.
+ waitForPEOp waits for a packet from global task who with the
+ OpCode op. If ignore is true all other messages are simply ignored;
+ otherwise they are handled by processUnexpected.
*/
//@cindex waitForPEOp
rtsPacket
-waitForPEOp(OpCode op, GlobalTaskId who)
+waitForPEOp(OpCode op, GlobalTaskId who, void(*processUnexpected)(rtsPacket) )
{
rtsPacket p;
int nbytes;
GlobalTaskId sender_id;
rtsBool match;
- do {
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"waitForPEOp: op = %x (%s), who = %x\n",
- op, getOpName(op), who));
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"~~ waitForPEOp: expecting op = %x (%s), who = [%x]\n",
+ op, getOpName(op), who));
+ do {
while((p = pvm_recv(ANY_TASK,ANY_OPCODE)) < 0)
pvm_perror("waitForPEOp: Waiting for PEOp");
pvm_bufinfo( p, &nbytes, &opCode, &sender_id );
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"waitForPEOp: received: OpCode = %x, sender_id = %x",
- opCode, getOpName(opCode), sender_id));
-
match = (op == ANY_OPCODE || op == opCode) &&
(who == ANY_TASK || who == sender_id);
- if (match)
+ if (match) {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,
+ "~~waitForPEOp: Qapla! received: OpCode = %#x (%s), sender_id = [%x]",
+ opCode, getOpName(opCode), sender_id));
+
return(p);
+ }
/* Handle the unexpected OpCodes */
- processUnexpected(p);
+ if (processUnexpected!=NULL) {
+ (*processUnexpected)(p);
+ } else {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,
+ "~~ waitForPEOp: ignoring OpCode = %#x (%s), sender_id = [%x]",
+ opCode, getOpName(opCode), sender_id));
+ }
} while(rtsTrue);
}
/*
- * processUnexpected processes unexpected messages. If the message is a
- * FINISH it exits the prgram, and PVM gracefully
+ processUnexpected processes unexpected messages. If the message is a
+ FINISH it exits the prgram, and PVM gracefully
*/
-//@cindex processUnexpected
+//@cindex processUnexpectedMessage
void
-processUnexpected(rtsPacket packet)
-{
+processUnexpectedMessage(rtsPacket packet) {
OpCode opCode = getOpcode(packet);
IF_PAR_DEBUG(verbose,
GlobalTaskId sender = senderTask(packet);
- fprintf(stderr,"== [%x] processUnexpected: Received %x (%s), sender %x\n",
+ fprintf(stderr,"~~ [%x] processUnexpected: Received %x (%s), sender %x\n",
mytid, opCode, getOpName(opCode), sender));
switch (opCode) {
are discarded during termination -- this helps prevent bizarre
race conditions. */
default:
- if (!GlobalStopPending) {
+ // if (!GlobalStopPending)
+ {
GlobalTaskId errorTask;
OpCode opCode;
- getOpcodeAndSender(packet,&opCode,&errorTask);
- fprintf(stderr,"Task %x: Unexpected OpCode %x from %x in processUnexpected",
+ getOpcodeAndSender(packet, &opCode, &errorTask);
+ fprintf(stderr,"== Task %x: Unexpected OpCode %x from %x in processUnexpected",
mytid, opCode, errorTask );
stg_exit(EXIT_FAILURE);
int nbytes;
OpCode OpCode;
GlobalTaskId sender_id;
+ /* read PVM buffer */
pvm_bufinfo(p, &nbytes, &OpCode, &sender_id);
+ /* return tag of the buffer as opcode */
return(OpCode);
}
getOpcodeAndSender(rtsPacket p, OpCode *opCodep, GlobalTaskId *senderIdp)
{
int nbytes;
+ /* read PVM buffer */
pvm_bufinfo(p, &nbytes, opCodep, senderIdp);
}
int nbytes;
OpCode opCode;
GlobalTaskId sender_id;
+ /* read PVM buffer */
pvm_bufinfo(p, &nbytes, &opCode, &sender_id);
return(sender_id);
}
/*
- * PEStartUp does the low-level comms specific startup stuff for a
- * PE. It initialises the comms system, joins the appropriate groups,
- * synchronises with the other PEs. Receives and records in a global
- * variable the task-id of SysMan. If this is the main thread (discovered
- * in main.lc), identifies itself to SysMan. Finally it receives
- * from SysMan an array of the Global Task Ids of each PE, which is
- * returned as the value of the function.
+ * startUpPE does the low-level comms specific startup stuff for a
+ * PE. It initialises the comms system, joins the appropriate groups
+ * allocates the PE buffer
*/
//@cindex startUpPE
-GlobalTaskId *
-startUpPE(nat nPEs)
-{
- int i;
- rtsPacket addr;
- long *buffer = (long *) stgMallocBytes(sizeof(long) * nPEs,
- "PEStartUp (buffer)");
- GlobalTaskId *thePEs = (GlobalTaskId *)
- stgMallocBytes(sizeof(GlobalTaskId) * nPEs,
- "PEStartUp (PEs)");
-
+void
+startUpPE(void)
+{
mytid = _my_gtid; /* Initialise PVM and get task id into global var.*/
-
+
IF_PAR_DEBUG(verbose,
fprintf(stderr,"== [%x] PEStartup: Task id = [%x], No. PEs = %d \n",
mytid, mytid, nPEs));
checkComms(pvm_joingroup(PEGROUP), "PEStartup");
IF_PAR_DEBUG(verbose,
fprintf(stderr,"== [%x] PEStartup: Joined PEGROUP\n", mytid));
- checkComms(pvm_joingroup(PECTLGROUP), "PEStartup");
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] PEStartup: Joined PECTLGROUP\n", mytid));
- checkComms(pvm_barrier(PECTLGROUP, nPEs+1), "PEStartup");
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] PEStartup, Passed PECTLGROUP barrier\n", mytid));
-
- addr = waitForPEOp(PP_SYSMAN_TID, ANY_GLOBAL_TASK);
- SysManTask = senderTask(addr);
- if (IAmMainThread) { /* Main Thread Identifies itself to SysMan */
- pvm_initsend(PvmDataDefault);
- pvm_send(SysManTask, PP_MAIN_TASK);
- }
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Thread waits for %s\n",
- mytid, getOpName(PP_PETIDS)));
- addr = waitForPEOp(PP_PETIDS, ANY_GLOBAL_TASK);
- GetArgs(buffer, nPEs);
- for (i = 0; i < nPEs; ++i) {
- thePEs[i] = (GlobalTaskId) buffer[i];
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] PEStartup: PEs[%d] = %x \n",
- mytid, i, thePEs[i]));
- }
- free(buffer);
- return thePEs;
}
/*
fprintf(stderr, "== [%x] PEshutdown\n", mytid));
checkComms(pvm_lvgroup(PEGROUP),"PEShutDown");
- checkComms(pvm_lvgroup(PECTLGROUP),"PEShutDown");
checkComms(pvm_exit(),"PEShutDown");
}
+/*
+ Extract the exit code out of a PP_FINISH packet (used in SysMan)
+*/
+int
+getExitCode(int nbytes, GlobalTaskId *sender_idp) {
+ int exitCode=0;
+
+ if (nbytes==4) { // Notification from a task doing pvm_exit
+ GetArgs(sender_idp,1); // Presumably this must be MainPE Id
+ exitCode = -1;
+ } else if (nbytes==8) { // Doing a controlled shutdown
+ GetArgs(&exitCode,1); // HACK: controlled shutdown == 2 values
+ GetArgs(&exitCode,1);
+ } else {
+ exitCode = -2; // everything else
+ }
+ return exitCode;
+}
+
#endif /* PAR -- whole file */
//@node Index, , Auxiliary functions, GUM Low-Level Inter-Task Communication
//* sendOpNV:: @cindex\s-+sendOpNV
//* sendOpN:: @cindex\s-+sendOpN
//* waitForPEOp:: @cindex\s-+waitForPEOp
-//* processUnexpected:: @cindex\s-+processUnexpected
+//* processUnexpectedMessage:: @cindex\s-+processUnexpectedMessage
//* getOpcode:: @cindex\s-+getOpcode
//* getOpcodeAndSender:: @cindex\s-+getOpcodeAndSender
//* senderTask:: @cindex\s-+senderTask
#define REPLY_OK 0x00
/*Startup + Shutdown*/
-#define PP_SYSMAN_TID 0x50
-#define PP_MAIN_TASK 0x51
-#define PP_FINISH 0x52
-#define PP_PETIDS 0x53
+#define PP_READY 0x50 /* sent PEs -> SysMan */
+#define PP_NEWPE 0x51 /* sent via newHost notify -> SysMan */
+#define PP_FINISH 0x52 /* sent PEs & via taskExit notfiy -> SysMan */
+#define PP_PETIDS 0x53 /* sent sysman -> PEs */
/* Stats stuff */
#define PP_STATS 0x54
#define PP_STATS_ON 0x55
#define PP_STATS_OFF 0x56
-#define PP_FAIL 0x57
+//#define PP_FAIL 0x57
/*Garbage Collection*/
#define PP_GC_INIT 0x58
#define PP_FISH 0x5e
#define PP_SCHEDULE 0x5f
#define PP_FREE 0x60
+#define PP_REVAL 0x61
+
#define MIN_PEOPS 0x50
-#define MAX_PEOPS 0x60
+#define MAX_PEOPS 0x61
-#define PEOP_NAMES "Init", "IOInit", \
+#define PEOP_NAMES "Ready", "NewPE", \
"Finish", "PETIDS", \
"Stats", "Stats_On", "Stats_Off", \
"Fail", \
"GCInit", "FullSystem", "GCPoll", \
"Fetch","Resume","ACK","Fish","Schedule", \
- "Free"
+ "Free","REval"
#endif /* PEOPCODES_H */
/*
- Time-stamp: <Thu Mar 30 2000 22:53:32 Stardate: [-30]4584.56 hwloidl>
- $Id: Pack.c,v 1.5 2000/08/07 23:37:24 qrczak Exp $
+ Time-stamp: <Wed Mar 21 2001 16:32:47 Stardate: [-30]6363.44 hwloidl>
+ $Id: Pack.c,v 1.6 2001/03/22 03:51:11 hwloidl Exp $
Graph packing and unpacking code for sending it to another processor
and retrieving the original graph structure from the packet.
#include "GranSimRts.h"
#include "ParallelRts.h"
# if defined(DEBUG)
+# include "Sanity.h"
+# include "Printer.h"
# include "ParallelDebug.h"
# endif
#include "FetchMe.h"
static void AmPacking(StgClosure *closure);
static int OffsetFor(StgClosure *closure);
static rtsBool NotYetPacking(int offset);
-static rtsBool RoomToPack (nat size, nat ptrs);
- rtsBool isOffset(globalAddr *ga);
- rtsBool isFixed(globalAddr *ga);
- rtsBool isConstr(globalAddr *ga);
+static inline rtsBool RoomToPack (nat size, nat ptrs);
+static inline rtsBool isOffset(globalAddr *ga);
+static inline rtsBool isFixed(globalAddr *ga);
+static inline rtsBool isConstr(globalAddr *ga);
+static inline rtsBool isUnglobalised(globalAddr *ga);
# elif defined(GRAN)
static void DonePacking(void);
static rtsBool NotYetPacking(StgClosure *closure);
buf_id = 1; /* identifier for buffer */
static nat unpacked_size;
static rtsBool roomInBuffer;
+#if defined(PAR)
+static GlobalTaskId dest_gtid=0; /* destination for message to send */
+#endif
/*
The pack buffer
static StgClosure **ClosureQueue = NULL; /* HWL: init in main */
+#if defined(DEBUG)
+static char graphFingerPrint[MAX_FINGER_PRINT_LEN];
+#endif
+
//@node Init routines, Basic routines, Closure Queues, ADT of Closure Queues
//@subsubsection Init routines
"InitClosureQueue");
}
-//@node Basic routines, , Init routines, ADT of Closure Queues
+//@node Basic routines, Types of Global Addresses, Init routines, ADT of Closure Queues
//@subsubsection Basic routines
/*
QueueClosure(closure)
StgClosure *closure;
{
- if(clq_size < RTS_PACK_BUFFER_SIZE )
+ if(clq_size < RTS_PACK_BUFFER_SIZE ) {
+ IF_PAR_DEBUG(paranoia,
+ belch(">__> <<%d>> Q: %p (%s); %d elems in q",
+ globalPackBuffer->id, closure, info_type(closure), clq_size-clq_pos));
ClosureQueue[clq_size++] = closure;
- else
+ } else {
barf("Closure Queue Overflow (EnQueueing %p (%s))",
closure, info_type(closure));
+ }
}
/* DeQueueClosure returns the head of the closure queue. */
static inline StgClosure *
DeQueueClosure(void)
{
- if(!QueueEmpty())
+ if(!QueueEmpty()) {
+ IF_PAR_DEBUG(paranoia,
+ belch(">__> <<%d>> DeQ: %p (%s); %d elems in q",
+ globalPackBuffer->id, ClosureQueue[clq_pos], info_type(ClosureQueue[clq_pos]),
+ clq_size-clq_pos));
return(ClosureQueue[clq_pos++]);
- else
+ } else {
return((StgClosure*)NULL);
+ }
}
/* DeQueueClosure returns the head of the closure queue. */
-//@cindex DeQueueClosure
-static inline StgClosure *
+#if defined(DEBUG)
+//@cindex PrintQueueClosure
+static void
PrintQueueClosure(void)
{
nat i;
fputs("Closure queue:", stderr);
for (i=clq_pos; i < clq_size; i++)
fprintf(stderr, "%p (%s), ",
- ClosureQueue[clq_pos++], info_type(ClosureQueue[clq_pos++]));
+ (StgClosure *)ClosureQueue[clq_pos++],
+ info_type(ClosureQueue[clq_pos++]));
fputc('\n', stderr);
}
+#endif
+
+//@node Types of Global Addresses, , Basic routines, ADT of Closure Queues
+//@subsubsection Types of Global Addresses
+
+/*
+ Types of Global Addresses
+
+ These routines determine whether a GA is one of a number of special types
+ of GA.
+*/
+
+# if defined(PAR)
+//@cindex isOffset
+static inline rtsBool
+isOffset(globalAddr *ga)
+{
+ return (ga->weight == 1U && ga->payload.gc.gtid == (GlobalTaskId)0);
+}
+
+//@cindex isFixed
+static inline rtsBool
+isFixed(globalAddr *ga)
+{
+ return (ga->weight == 0U);
+}
+
+//@cindex isConstr
+static inline rtsBool
+isConstr(globalAddr *ga)
+{
+ return (ga->weight == 2U);
+}
+
+//@cindex isUnglobalised
+static inline rtsBool
+isUnglobalised(globalAddr *ga)
+{
+ return (ga->weight == 2U);
+}
+# endif
//@node Initialisation for packing, Packing Functions, ADT of Closure Queues, Graph packing
//@subsection Initialisation for packing
{
if (globalPackBuffer==(rtsPackBuffer*)NULL) {
if ((globalPackBuffer = (rtsPackBuffer *)
- stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize,
+ stgMallocWords(sizeofW(rtsPackBuffer)+RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM,
"InitPackBuffer")) == NULL)
return rtsFalse;
}
/* NB: this code is shared between GranSim and GUM;
tso only used in GranSim */
rtsPackBuffer *
-PackNearbyGraph(closure, tso, packBufferSize)
+PackNearbyGraph(closure, tso, packBufferSize, dest)
StgClosure* closure;
StgTSO* tso;
nat *packBufferSize;
+GlobalTaskId dest;
{
+ IF_PAR_DEBUG(resume,
+ graphFingerPrint[0] = '\0');
+
ASSERT(RTS_PACK_BUFFER_SIZE > 0);
+ ASSERT(_HS==1); // HWL HACK; compile time constant
+
+#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
+ PAR_TICKY_PACK_NEARBY_GRAPH_START();
+#endif
/* ToDo: check that we have enough heap for the packet
ngoq ngo'
if (Hp + PACK_HEAP_REQUIRED > HpLim)
return NULL;
*/
-
InitPacking(rtsFalse);
-# if defined(GRAN)
+# if defined(PAR)
+ dest_gtid=dest; //-1 to disable
+# elif defined(GRAN)
graph_root = closure;
# endif
belch("** PrintGraph of %p is:", closure);
PrintGraph(closure,0));
- IF_PAR_DEBUG(packet,
- belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n demanded by TSO %d (%p)",
+ IF_PAR_DEBUG(resume,
+ GraphFingerPrint(closure, graphFingerPrint);
+ ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
+ belch(">>> Packing <<%d>> (buffer @ %p); graph root @ %p [%x]\n demanded by TSO %d (%p); Finger-print is\n {%s}",
globalPackBuffer->id, globalPackBuffer, closure, mytid,
- tso->id, tso));
+ tso->id, tso, graphFingerPrint));
IF_PAR_DEBUG(packet,
belch("** PrintGraph of %p is:", closure);
# if defined(PAR)
- /* Record how much space is needed to unpack the graph */
- globalPackBuffer->tso = tso; // ToDo: check: used in GUM or only for debugging?
+ /* Record how much space the graph needs in packet and in heap */
+ globalPackBuffer->tso = tso; // currently unused, I think (debugging?)
globalPackBuffer->unpacked_size = unpacked_size;
globalPackBuffer->size = pack_locn;
- /* Set the size parameter */
- ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize);
+ /* Check for buffer overflow (again) */
+ ASSERT(pack_locn <= RtsFlags.ParFlags.packBufferSize+DEBUG_HEADROOM);
+ IF_DEBUG(sanity, // write magic end-of-buffer word
+ globalPackBuffer->buffer[pack_locn] = END_OF_BUFFER_MARKER);
*packBufferSize = pack_locn;
# else /* GRAN */
IF_GRAN_DEBUG(pack, PrintPacket(globalPackBuffer));
# elif defined(PAR)
IF_PAR_DEBUG(packet,
- belch("** Finished <<%d>> packing graph %p; closures packed: %d; thunks packed: %d; size of graph: %d",
- globalPackBuffer->id, closure, globalPackBuffer->size, packed_thunks, globalPackBuffer->unpacked_size);
- PrintPacket(globalPackBuffer));
+ belch("** Finished <<%d>> packing graph %p (%s); closures packed: %d; thunks packed: %d; size of graph: %d",
+ globalPackBuffer->id, closure, info_type(closure),
+ globalPackBuffer->size, packed_thunks,
+ globalPackBuffer->unpacked_size));;
IF_DEBUG(sanity, // do a sanity check on the packet just constructed
checkPacket(globalPackBuffer));
# endif /* GRAN */
+
+#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
+ PAR_TICKY_PACK_NEARBY_GRAPH_END(globalPackBuffer->size, packed_thunks);
+#endif
return (globalPackBuffer);
}
StgInfoTable *ip;
nat i;
int offset;
+#if defined(DEBUG)
+ nat x = pack_locn;
+#endif
#if defined(GRAN)
barf("{PackFetchMe}Daq Qagh: no FetchMe closures in GRAN!");
belch("*>.. Packing FETCH_ME for closure %p (s) as offset to %d",
closure, info_type(closure), offset));
PackOffset(offset);
- unpacked_size += 2;
+ // unpacked_size += 0; // unpacked_size unchanged (closure is shared!!)
return;
}
/* Need a GA even when packing a constructed FETCH_ME (cruel world!) */
AmPacking(closure);
+ /* FMs must be always globalised */
GlobaliseAndPackGA(closure);
IF_PAR_DEBUG(pack,
globalPackBuffer->buffer[pack_locn-3]));
/* Pack a FetchMe closure instead of closure */
- ip = &FETCH_ME_info;
+ ip = &stg_FETCH_ME_info;
/* this assumes that the info ptr is always the first word in a closure*/
Pack((StgWord)ip);
for (i = 1; i < _HS; ++i) // pack rest of fixed header
Pack((StgWord)*(((StgPtr)closure)+i));
- unpacked_size += PACK_FETCHME_SIZE;
+ unpacked_size += sizeofW(StgFetchMe);
+ /* size of FETCHME in packed is the same as that constant */
+ ASSERT(pack_locn-x==PACK_FETCHME_SIZE);
+ /* In the pack buffer the pointer to a GA (in the FetchMe closure)
+ is expanded to the full GA; this is a compile-time const */
+ //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
#endif
}
#endif
+#ifdef DIST
+static void
+PackRemoteRef(StgClosure *closure)
+{
+ StgInfoTable *ip;
+ nat i;
+ int offset;
+
+ offset = OffsetFor(closure);
+ if (!NotYetPacking(offset)) {
+ PackOffset(offset);
+ unpacked_size += 2;
+ return;
+ }
+
+ /* Need a GA even when packing a constructed REMOTE_REF (cruel world!) */
+ AmPacking(closure);
+
+ /* basically we just Globalise, but for sticky things we can't have multiple GAs,
+ so we must prevent the GAs being split.
+
+ In returning things to the true sticky owner, this case is already handled, but for
+ anything else we just give up at the moment... This needs to be fixed!
+ */
+ { globalAddr *ga;
+ ga = LAGAlookup(closure); // surely this ga must exist?
+
+ // ***************************************************************************
+ // ***************************************************************************
+ // REMOTE_REF HACK - dual is in SetGAandCommonUp
+ // - prevents the weight from ever reaching zero
+ if(ga != NULL)
+ ga->weight=0x06660666; //anything apart from 0 really...
+ // ***************************************************************************
+ // ***************************************************************************
+
+ if((ga != NULL)&&(ga->weight / 2 <= 2))
+ barf("Cant split the weight any further when packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
+ closure, info_type(closure),
+ ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight);
+ }
+ GlobaliseAndPackGA(closure);
+
+ IF_PAR_DEBUG(pack,
+ belch("*>.. Packing REMOTE_REF for closure %p (%s) with GA: ((%x, %d, %x))",
+ closure, info_type(closure),
+ globalPackBuffer->buffer[pack_locn-2],
+ globalPackBuffer->buffer[pack_locn-1],
+ globalPackBuffer->buffer[pack_locn-3]));
+
+ /* Pack a REMOTE_REF closure instead of closure */
+ ip = &stg_REMOTE_REF_info;
+ /* this assumes that the info ptr is always the first word in a closure*/
+ Pack((StgWord)ip);
+ for (i = 1; i < _HS; ++i) // pack rest of fixed header
+ Pack((StgWord)*(((StgPtr)closure)+i));
+
+ unpacked_size += PACK_FETCHME_SIZE;
+}
+#endif DIST
+
//@node Packing Closures, , Packing Sections of Nearby Graph, Packing Functions
//@subsubsection Packing Closures
/*
StgClosure *closure;
{
StgInfoTable *info;
- StgClosure *indirectee;
nat clpack_locn;
ASSERT(LOOKS_LIKE_GHC_INFO(get_itbl(closure)));
switch (info->type) {
case CONSTR_CHARLIKE:
- {
- StgChar val = ((StgIntCharlikeClosure*)closure)->data;
-
- if ((val <= MAX_CHARLIKE) && (val >= MIN_CHARLIKE)) {
- IF_PAR_DEBUG(pack,
- belch("*>^^ Packing a small charlike %d as a PLC", val));
- PackPLC((StgPtr)CHARLIKE_CLOSURE(val));
- } else {
- IF_PAR_DEBUG(pack,
- belch("*>^^ Packing a big charlike %d as a normal closure",
- val));
- PackGeneric(closure);
- }
- return;
- }
+ IF_PAR_DEBUG(pack,
+ belch("*>^^ Packing a charlike closure %d",
+ ((StgIntCharlikeClosure*)closure)->data));
+
+ PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)closure)->data));
+ // NB: unpacked_size of a PLC is 0
+ return;
case CONSTR_INTLIKE:
{
StgInt val = ((StgIntCharlikeClosure*)closure)->data;
-
+
if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
IF_PAR_DEBUG(pack,
- belch("*>^^ Packing a small intlike %d as a PLC", val));
+ belch("*>^^ Packing a small intlike %d as a PLC",
+ val));
PackPLC((StgPtr)INTLIKE_CLOSURE(val));
+ // NB: unpacked_size of a PLC is 0
+ return;
} else {
IF_PAR_DEBUG(pack,
belch("*>^^ Packing a big intlike %d as a normal closure",
val));
PackGeneric(closure);
+ return;
}
- return;
}
case CONSTR:
case CONSTR_NOCAF_STATIC:// For now we ship indirections to CAFs: They are
// evaluated on each PE if needed
IF_PAR_DEBUG(pack,
- belch("*>~~ Packing a %p (%s) as a PLC",
- closure, info_type(closure)));
+ belch("*>~~ Packing a %p (%s) as a PLC",
+ closure, info_type(closure)));
PackPLC((StgPtr)closure);
+ // NB: unpacked_size of a PLC is 0
return;
case THUNK_SELECTOR:
PackPAP((StgPAP *)closure);
return;
- case CAF_UNENTERED:
- case CAF_ENTERED:
case CAF_BLACKHOLE:
case BLACKHOLE:
case BLACKHOLE_BQ:
PackFetchMe(closure);
return;
- case MVAR:
- barf("*> Pack: packing of MVARs not implemented",
- closure, info_type(closure));
-
- /* MVARs may not be copied; they are sticky objects in the new RTS */
- /* therefore we treat them just as RBHs etc (what a great system!)
- IF_PAR_DEBUG(pack,
- belch("** Found an MVar at %p (%s)",
- closure, info_type(closure))); */
+#ifdef DIST
+ case REMOTE_REF:
IF_PAR_DEBUG(pack,
- belch("*>.. Packing an MVAR at %p (%s) as a FETCH_ME",
+ belch("*>.. Packing %p (%s) as a REMOTE_REF",
closure, info_type(closure)));
- /* NB: in case of a FETCH_ME this might build up a chain of FETCH_MEs;
- phps short-cut the GA here */
- PackFetchMe(closure);
- return;
+ PackRemoteRef(closure);
+ /* we hopefully don't end up with a chain of REMOTE_REFs!!!!!!!!!! */
+ return;
+#endif
+
+ case TSO:
+ case MVAR:
+#ifdef DIST
+ IF_PAR_DEBUG(pack,
+ belch("*>.. Packing %p (%s) as a RemoteRef",
+ closure, info_type(closure)));
+ PackRemoteRef(closure);
+#else
+ barf("{Pack}Daq Qagh: Only GdH can pack %p (%s)",
+ closure, info_type(closure));
+#endif
+ return;
+
case ARR_WORDS:
PackArray(closure);
return;
closure, info_type(closure));
/* never reached */
- case TSO:
case BLOCKED_FETCH:
case EVACUATED:
/* something's very wrong */
ASSERT(!IS_BLACK_HOLE(closure));
IF_PAR_DEBUG(pack,
- fprintf(stderr, "*>== generic packing of %p (%s) (size=%d, ptrs=%d, nonptrs=%d)\n",
+ fprintf(stderr, "*>== %p (%s): generic packing (size=%d, ptrs=%d, nonptrs=%d)\n",
closure, info_type(closure), size, ptrs, nonptrs));
+ /* packing strategies: how many thunks to add to a packet;
+ default is infinity i.e. RtsFlags.ParFlags.thunksToPack==0 */
+ if (RtsFlags.ParFlags.thunksToPack &&
+ packed_thunks >= RtsFlags.ParFlags.thunksToPack &&
+ closure_THUNK(closure)) {
+ IF_PAR_DEBUG(pack,
+ belch("*>&& refusing to pack more than %d thunks per packet; packing FETCH_ME for closure %p (%s)",
+ packed_thunks, closure, info_type(closure)));
+ PackFetchMe(closure);
+ return;
+ }
+
/* Primitive arrays have gone; now we have (MUT_)ARR_WORDS etc */
if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
/* Record the location of the GA */
AmPacking(closure);
/* Allocate a GA for this closure and put it into the buffer */
- GlobaliseAndPackGA(closure);
+ /* Checks for globalisation scheme; default: globalise everything thunks */
+ if ( RtsFlags.ParFlags.globalising == 0 ||
+ (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
+ GlobaliseAndPackGA(closure);
+ else
+ Pack((StgWord)2); // marker for unglobalised closure
+
ASSERT(!(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR));
/* At last! A closure we can actually pack! */
- if (ip_MUTABLE(info) && (info->type != FETCH_ME))
- barf("*>// PackClosure: trying to replicate a Mutable closure!");
+ if (ip_MUTABLE(info) && ((info->type != FETCH_ME)||(info->type != REMOTE_REF)))
+ barf("*>// %p (%s) PackClosure: trying to replicate a Mutable closure!",
+ closure, info_type(closure));
/*
Remember, the generic closure layout is as follows:
}
unpacked_size += size;
- // unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
+ //unpacked_size += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
/*
* Record that this is a revertable black hole so that we can fill in
* ACK.
*/
- // IS_UPDATABLE(closure) == !closure_UNPOINTED(closure) !? HWL
if (closure_THUNK(closure) && !closure_UNPOINTED(closure)) {
rbh = convertToRBH(closure);
- ASSERT(rbh == closure); // rbh at the same position (minced version)
+ ASSERT(size>=_HS+MIN_UPD_SIZE); // min size for any updatable closure
+ ASSERT(rbh == closure); // rbh at the same position (minced version)
packed_thunks++;
+ } else if ( closure==graph_root ) {
+ packed_thunks++; // root of graph is counted as a thunk
}
}
/*
PackArray(StgClosure *closure)
{
StgInfoTable *info;
- nat size, ptrs, nonptrs, vhs, i, n;
+ nat size, ptrs, nonptrs, vhs;
+ nat i, n;
char str[80];
-#if DEBUG
- /* we don't really need all that get_closure_info delivers; however, for
- debugging it's useful to have the stuff anyway */
-
/* get info about basic layout of the closure */
info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
ASSERT(info->type == ARR_WORDS || info->type == MUT_ARR_PTRS ||
info->type == MUT_ARR_PTRS_FROZEN || info->type == MUT_VAR);
-#endif
- /* record offset of the closure and allocate a GA */
- AmPacking(closure);
- GlobaliseAndPackGA(closure);
n = ((StgArrWords *)closure)->words;
// this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
IF_PAR_DEBUG(pack,
- belch("*>== packing an array of %d words %p (%s) (size=%d)\n",
- n, closure, info_type(closure),
+ belch("*>== %p (%s): packing an array of %d words (size=%d)\n",
+ closure, info_type(closure), n,
arr_words_sizeW((StgArrWords *)closure)));
+ /* check that we have enough room in the pack buffer */
+ if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
+ IF_PAR_DEBUG(pack,
+ belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
+ closure, info_type(closure)));
+ PackFetchMe(closure);
+ return;
+ }
+
+ /* global stats about arrays sent */
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_arrs++;
+ globalParStats.tot_arr_size += ((StgArrWords *)closure)->words;
+ }
+
+ /* record offset of the closure and allocate a GA */
+ AmPacking(closure);
+ /* Checks for globalisation scheme; default: globalise everything thunks */
+ if ( RtsFlags.ParFlags.globalising == 0 ||
+ (closure_THUNK(closure) && !closure_UNPOINTED(closure)) )
+ GlobaliseAndPackGA(closure);
+ else
+ Pack((StgWord)2); // marker for unglobalised closure
+
/* Pack the header (2 words: info ptr and the number of words to follow) */
Pack((StgWord)*(StgPtr)closure);
Pack(((StgArrWords *)closure)->words);
//@cindex PackPAP
static void
PackPAP(StgPAP *pap) {
- nat m, n, i, j, pack_start;
- StgPtr p, q, end/*dbg*/;
+ nat n, i, j, pack_start;
+ StgPtr p, q;
const StgInfoTable* info;
StgWord32 bitmap;
/* debugging only */
+ StgPtr end;
nat size, ptrs, nonptrs, vhs;
char str[80];
+ nat unpacked_size_before_PAP, FMs_in_PAP=0; // debugging only
/* This is actually a setup invariant; checked here 'cause it affects PAPs*/
- ASSERT(PACK_FETCHME_SIZE == 1 + sizeofW(StgFetchMe));
+ //ASSERT(PACK_FETCHME_SIZE == sizeofW(StgFetchMe)-1+PACK_GA_SIZE);
ASSERT(NotYetPacking(OffsetFor((StgClosure *)pap)));
+ IF_DEBUG(sanity,
+ unpacked_size_before_PAP = unpacked_size);
- /* record offset of the closure and allocate a GA */
- AmPacking((StgClosure *)pap);
- GlobaliseAndPackGA((StgClosure *)pap);
+ n = (nat)(pap->n_args);
/* get info about basic layout of the closure */
info = get_closure_info((StgClosure *)pap, &size, &ptrs, &nonptrs, &vhs, str);
ASSERT(ptrs==0 && nonptrs==0 && size==pap_sizeW(pap));
- n = (nat)(pap->n_args);
-
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP: packing PAP @ %p with %d words (size=%d; ptrs=%d; nonptrs=%d:",
- (StgClosure *)pap, n, size, ptrs, nonptrs);
+ belch("*>** %p (%s): PackPAP: packing PAP with %d words (size=%d; ptrs=%d; nonptrs=%d:",
+ (StgClosure *)pap, info_type((StgClosure *)pap),
+ n, size, ptrs, nonptrs);
printClosure((StgClosure *)pap));
+ /* check that we have enough room in the pack buffer */
+ if (!RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)) {
+ IF_PAR_DEBUG(pack,
+ belch("*>&& pack buffer is full; packing FETCH_ME for closure %p (%s)",
+ (StgClosure *)pap, info_type((StgClosure *)pap)));
+ PackFetchMe((StgClosure *)pap);
+ return;
+ }
+
+ /* record offset of the closure and allocate a GA */
+ AmPacking((StgClosure *)pap);
+ /* Checks for globalisation scheme; default: globalise everything thunks */
+ if ( RtsFlags.ParFlags.globalising == 0 ||
+ (closure_THUNK(pap) && !closure_UNPOINTED(pap)) )
+ GlobaliseAndPackGA((StgClosure *)pap);
+ else
+ Pack((StgWord)2); // marker for unglobalised closure
+
/* Pack the PAP header */
Pack((StgWord)(pap->header.info));
Pack((StgWord)(pap->n_args));
/* If we've got a tag, pack all words in that block */
if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
- nat m = ARG_TAG(q); // first word after this block
+ nat m = ARG_TAG((W_)q); // first word after this block
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
+ belch("*>** PackPAP @ %p: packing %d words (tagged), starting @ %p",
p, m, p));
for (i=0; i<m+1; i++)
Pack((StgWord)*(p+i));
/* distinguish static closure (PLC) from other closures (FM) */
switch (get_itbl((StgClosure*)q)->type) {
case CONSTR_CHARLIKE:
- {
- StgChar val = ((StgIntCharlikeClosure*)q)->data;
-
- if ((val <= MAX_CHARLIKE) && (val >= MIN_CHARLIKE)) {
- IF_PAR_DEBUG(pack,
- belch("*>** PackPAP: Packing ptr to a small charlike %d as a PLC", val));
- PackPLC((StgPtr)CHARLIKE_CLOSURE(val));
- } else {
- IF_PAR_DEBUG(pack,
- belch("*>** PackPAP: Packing a ptr to a big charlike %d as a FM",
- val));
- Pack((StgWord)(ARGTAG_MAX+1));
- PackFetchMe((StgClosure *)q);
- }
- p++;
- break;
- }
+ IF_PAR_DEBUG(pack,
+ belch("*>** PackPAP: packing a charlike closure %d",
+ ((StgIntCharlikeClosure*)q)->data));
+
+ PackPLC((StgPtr)CHARLIKE_CLOSURE(((StgIntCharlikeClosure*)q)->data));
+ p++;
+ break;
case CONSTR_INTLIKE:
{
if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
+ belch("*>** PackPAP: Packing ptr to a small intlike %d as a PLC", val));
PackPLC((StgPtr)INTLIKE_CLOSURE(val));
+ p++;
+ break;
} else {
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
+ belch("*>** PackPAP: Packing a ptr to a big intlike %d as a FM",
val));
Pack((StgWord)(ARGTAG_MAX+1));
PackFetchMe((StgClosure *)q);
+ p++;
+ IF_DEBUG(sanity, FMs_in_PAP++);
+ break;
}
- p++;
- break;
}
case THUNK_STATIC: // ToDo: check whether that's ok
case FUN_STATIC: // ToDo: check whether that's ok
case CONSTR_NOCAF_STATIC:
{
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
+ belch("*>** PackPAP: packing a ptr to a %p (%s) as a PLC",
q, info_type((StgClosure *)q)));
PackPLC((StgPtr)q);
}
default:
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: packing FM to %p (%s)",
+ belch("*>** PackPAP @ %p: packing FM to %p (%s)",
p, q, info_type((StgClosure*)q)));
Pack((StgWord)(ARGTAG_MAX+1));
PackFetchMe((StgClosure *)q);
p++;
+ IF_DEBUG(sanity, FMs_in_PAP++);
break;
}
continue;
/* Dynamic bitmap: the mask is stored on the stack */
case RET_DYN:
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: RET_DYN",
+ belch("*>** PackPAP @ %p: RET_DYN",
p));
/* Pack the header as is */
case FUN_STATIC:
{
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
+ belch("*>** PackPAP @ %p: FUN or FUN_STATIC",
p));
Pack((StgWord)(((StgClosure *)p)->header.info));
ASSERT(type==BLACKHOLE || type==CAF_BLACKHOLE || type==BLACKHOLE_BQ);
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
+ belch("*>** PackPAP @ %p: UPDATE_FRAME (updatee=%p; link=%p)",
p, frame->updatee, frame->link));
Pack((StgWord)(frame->header.info));
case STOP_FRAME:
{
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: STOP_FRAME",
+ belch("*>** PackPAP @ %p: STOP_FRAME",
p));
Pack((StgWord)((StgStopFrame *)p)->header.info);
p++;
case CATCH_FRAME:
{
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
+ belch("*>** PackPAP @ %p: CATCH_FRAME (handler=%p)",
p, ((StgCatchFrame *)p)->handler));
Pack((StgWord)((StgCatchFrame *)p)->header.info);
case SEQ_FRAME:
{
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
+ belch("*>** PackPAP @ %p: UPDATE_FRAME (link=%p)",
p, ((StgSeqFrame *)p)->link));
Pack((StgWord)((StgSeqFrame *)p)->header.info);
case RET_SMALL:
case RET_VEC_SMALL:
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
+ belch("*>** PackPAP @ %p: RET_{BCO,SMALL,VEC_SMALL} (bitmap=%o)",
p, info->layout.bitmap));
if ((bitmap & 1) == 0) {
Pack((StgWord)(ARGTAG_MAX+1));
PackFetchMe((StgClosure *)*p++); // pack a FetchMe to the closure
+ IF_DEBUG(sanity, FMs_in_PAP++);
} else {
Pack((StgWord)*p++);
}
}
follow_srt:
- belch("*>-- PackPAP: nothing to do for follow_srt");
+ IF_PAR_DEBUG(pack,
+ belch("*>-- PackPAP: nothing to do for follow_srt"));
continue;
/* large bitmap (> 32 entries) */
StgLargeBitmap *large_bitmap;
IF_PAR_DEBUG(pack,
- belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
+ belch("*>** PackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
p, info->layout.large_bitmap));
if ((bitmap & 1) == 0) {
Pack((StgWord)(ARGTAG_MAX+1));
PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer(StgClosure *)*p = evacuate((StgClosure *)*p);
+ IF_DEBUG(sanity, FMs_in_PAP++);
} else {
Pack((StgWord)*p++);
}
while (p < q) {
Pack((StgWord)(ARGTAG_MAX+1));
PackFetchMe((StgClosure *)*p++); // ToDo: pack pointer (StgClosure *)*p = evacuate((StgClosure *)*p);
+ IF_DEBUG(sanity, FMs_in_PAP++);
}
}
}
}
// fill in size of the PAP (only the payload!) in buffer
globalPackBuffer->buffer[pack_start] = (StgWord)(pack_locn - pack_start - 1*sizeofW(StgWord));
- // add the size of the whole packed closure; this relies on the fact that
- // the size of the unpacked PAP + size of all unpacked FMs is the same as
- // the size of the packed PAP!!
- unpacked_size += sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
+ /*
+ We can use the generic pap_sizeW macro to compute the size of the
+ unpacked PAP because whenever we pack a new FETCHME as part of the
+ PAP's payload we also adjust unpacked_size accordingly (smart, aren't we?)
+
+ NB: the current PAP (un-)packing code relies on the fact that
+ the size of the unpacked PAP + size of all unpacked FMs is the same as
+ the size of the packed PAP!!
+ */
+ unpacked_size += pap_sizeW(pap); // sizeofW(pap) + (nat)(globalPackBuffer->buffer[pack_start]);
+ IF_DEBUG(sanity,
+ ASSERT(unpacked_size-unpacked_size_before_PAP==pap_sizeW(pap)+FMs_in_PAP*sizeofW(StgFetchMe)));
}
# else /* GRAN */
/* partial applications; special treatment necessary? */
break;
- case CAF_UNENTERED: /* # of ptrs, nptrs: 1,3 */
- case CAF_ENTERED: /* # of ptrs, nptrs: 0,4 (allegedly bogus!!) */
- /* CAFs; special treatment necessary? */
- break;
-
case MVAR:
barf("{PackClosure}Daq Qagh: found an MVAR (%p, %s); ToDo: implement proper treatment of MVARs",
closure, info_type(closure));
P_ childInfo;
W_ childSize, childPtrs, childNonPtrs, childVhs;
- childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
+ childInfo = get_closure_info(((StgPtrPtr) (closure))[i + _HS + vhs],
&childSize, &childPtrs, &childNonPtrs,
&childVhs, junk_str);
if (IS_BIG_MOTHER(childInfo)) {
- reservedPAsize += PACK_GA_SIZE + FIXED_HS +
+ reservedPAsize += PACK_GA_SIZE + _HS +
childVhs + childNonPtrs +
childPtrs * PACK_FETCHME_SIZE;
- PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
+ PAsize += PACK_GA_SIZE + _HS + childSize;
PAptrs += childPtrs;
}
}
/*
ToDo: fix this code
||
- !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
+ !(RoomToPack(PACK_GA_SIZE + _HS + vhs + nonptrs, ptrs)
|| IS_BIG_MOTHER(info)))
*/
return;
QueueClosure((StgClosure *)(closure->payload[i]));
IF_GRAN_DEBUG(pack,
belch("** [%p (%s) (Queueing closure) ....]",
- closure->payload[i], info_type(payloadPtr(closure,i))));
+ closure->payload[i],
+ info_type(*stgCast(StgPtr*,((closure)->payload+(i))))));
+ //^^^^^^^^^^^ payloadPtr(closure,i))));
}
/*
globalAddr *ga;
globalAddr packGA;
- if ((ga = LAGAlookup(closure)) == NULL)
+ if ((ga = LAGAlookup(closure)) == NULL) {
ga = makeGlobal(closure, rtsTrue);
- ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
- splitWeight(&packGA, ga);
- ASSERT(packGA.weight > 0);
+ // Global statistics: increase amount of global data by closure-size
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i, m; // stats only!!
+ char str[80]; // stats only!!
+
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+ globalParStats.tot_global += size;
+ }
+ }
+ ASSERT(ga->weight==MAX_GA_WEIGHT || ga->weight > 2);
+
+ if(dest_gtid==ga->payload.gc.gtid)
+ { packGA.payload = ga->payload;
+ packGA.weight = 0xFFFFFFFF; // 0,1,2 are used already
+ }
+ else
+ { splitWeight(&packGA, ga);
+ ASSERT(packGA.weight > 0);
+ }
+
IF_PAR_DEBUG(pack,
- fprintf(stderr, "*>## Globalising closure %p (%s) with GA ",
- closure, info_type(closure));
+ fprintf(stderr, "*>## %p (%s): Globalising (%s) closure with GA ",
+ closure, info_type(closure),
+ ( (ga->payload.gc.gtid==dest_gtid)?"returning":
+ ( (ga->payload.gc.gtid==mytid)?"creating":"sharing" ) ));
printGA(&packGA);
fputc('\n', stderr));
unpacking of closures as it is done in the parallel runtime system.
*/
-//@node GUM code, Local Definitions, Unpacking routines, Unpacking routines
+//@node GUM code, GranSim Code, Unpacking routines, Unpacking routines
//@subsubsection GUM code
#if defined(PAR)
CommonUp(StgClosure *src, StgClosure *dst)
{
StgBlockingQueueElement *bqe;
+#if defined(DEBUG)
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i;
+ char str[80];
+
+ /* get info about basic layout of the closure */
+ info = get_closure_info(src, &size, &ptrs, &nonptrs, &vhs, str);
+#endif
ASSERT(src != (StgClosure *)NULL && dst != (StgClosure *)NULL);
ASSERT(src != dst);
IF_PAR_DEBUG(pack,
- belch("*___ CommonUp %p (%s) --> %p (%s)",
+ belch("*___ CommonUp %p (%s) --> %p (%s)",
src, info_type(src), dst, info_type(dst)));
switch (get_itbl(src)->type) {
bqe = END_BQ_QUEUE;
break;
+ /* These closures are too small to be updated with an indirection!!! */
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ ASSERT(size<_HS+MIN_UPD_SIZE); // that's why we have to avoid UPD_IND
+ return;
+
/* currently we also common up 2 CONSTRs; this should reduce heap
* consumption but also does more work; not sure whether it's worth doing
*/
case CONSTR:
- case CONSTR_1_0:
- case CONSTR_0_1:
case CONSTR_2_0:
case CONSTR_1_1:
case CONSTR_0_2:
/* Don't common up anything else */
return;
}
+
+ /* closure must be big enough to permit update with ind */
+ ASSERT(size>=_HS+MIN_UPD_SIZE);
/* NB: this also awakens the blocking queue for src */
UPD_IND(src, dst);
- // updateWithIndirection(src, dst);
- /*
- ASSERT(!IS_BIG_MOTHER(INFO_PTR(dst)));
- if (bqe != END_BQ_QUEUE)
- awakenBlockedQueue(bqe, src);
- */
}
/*
if (!hasGA)
return closure;
-
+
+ /* should we already have a local copy? */
+ if (ga->weight==0xFFFFFFFF) {
+ ASSERT(ga->payload.gc.gtid==mytid); //sanity
+ ga->weight=0;
+ /* probably should also ASSERT that a commonUp takes place...*/
+ }
+
ip = get_itbl(closure);
if ((existing = GALAlookup(ga)) == NULL) {
/* Just keep the new object */
IF_PAR_DEBUG(pack,
- belch("*<## Unpacking new GA ((%x, %d, %x))",
- ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight));
+ belch("*<## New local object for GA ((%x, %d, %x)) is %p (%s)",
+ ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
+ closure, info_type(closure)));
// make an entry binding closure to ga in the RemoteGA table
newGA = setRemoteGA(closure, ga, rtsTrue);
- if (ip->type == FETCH_ME)
+ // if local closure is a FETCH_ME etc fill in the global indirection
+ if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
((StgFetchMe *)closure)->ga = newGA;
} else {
+
+
+#ifdef DIST
+// ***************************************************************************
+// ***************************************************************************
+// REMOTE_REF HACK - dual is in PackRemoteRef
+// - prevents the weight ever being updated
+ if (ip->type == REMOTE_REF)
+ ga->weight=0;
+// ***************************************************************************
+// ***************************************************************************
+#endif DIST
+
/* Two closures, one global name. Someone loses */
oldip = get_itbl(existing);
if ((oldip->type == FETCH_ME ||
- /* If we pack GAs for CONSTRs we have to check for them, too */
- IS_BLACK_HOLE(existing)) &&
+ IS_BLACK_HOLE(existing) ||
+ /* try to share evaluated closures */
+ oldip->type == CONSTR ||
+ oldip->type == CONSTR_1_0 ||
+ oldip->type == CONSTR_0_1 ||
+ oldip->type == CONSTR_2_0 ||
+ oldip->type == CONSTR_1_1 ||
+ oldip->type == CONSTR_0_2
+ ) &&
ip->type != FETCH_ME)
{
IF_PAR_DEBUG(pack,
- belch("*<#- Unpacking old GA ((%x, %d, %x)); redirecting %p -> %p",
+ belch("*<#- Duplicate local object for GA ((%x, %d, %x)); redirecting %p (%s) -> %p (%s)",
ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
- existing, closure));
+ existing, info_type(existing), closure, info_type(closure)));
/*
* What we had wasn't worth keeping, so make the old closure an
*/
CommonUp(existing, closure);
//GALAdeprecate(ga);
- /* now ga indirectly refers to the new closure */
- ASSERT(UNWIND_IND(GALAlookup(ga))==closure);
+#if defined(DEBUG)
+ {
+ StgInfoTable *info;
+ nat size, ptrs, nonptrs, vhs, i;
+ char str[80];
+
+ /* get info about basic layout of the closure */
+ info = get_closure_info(GALAlookup(ga), &size, &ptrs, &nonptrs, &vhs, str);
+
+ /* now ga indirectly refers to the new closure */
+ ASSERT(size<_HS+MIN_UPD_SIZE ||
+ UNWIND_IND(GALAlookup(ga))==closure);
+ }
+#endif
} else {
/*
* Either we already had something worthwhile by this name or
* the same as when they were packed.
*/
IF_PAR_DEBUG(pack,
- belch("*<#@ Unpacking old GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
+ belch("*<#@ Duplicate local object for GA ((%x, %d, %x)); keeping %p (%s) nuking unpacked %p (%s)",
ga->payload.gc.gtid, ga->payload.gc.slot, ga->weight,
existing, info_type(existing), closure, info_type(closure)));
+ /* overwrite 2nd word; indicates that the closure is garbage */
+ IF_DEBUG(sanity,
+ ((StgFetchMe*)closure)->ga = (globalAddr*)GARBAGE_MARKER;
+ IF_PAR_DEBUG(pack,
+ belch("++++ unpacked closure %p (%s) is garbage: %p",
+ closure, info_type(closure), *(closure+1))));
+
closure = existing;
#if 0
// HACK
CommonUp(closure, graph);
#endif
}
- /* Pool the total weight in the stored ga */
+ /* We don't use this GA after all, so give back the weight */
(void) addWeight(ga);
}
- /* ToDo: check this assertion!!
- if we have unpacked a FETCH_ME, we have a GA, too
- ASSERT(get_itbl(*closureP)->type!=FETCH_ME ||
- looks_like_ga(((StgFetchMe *)*closureP)->ga));
- */
+ /* if we have unpacked a FETCH_ME, we have a GA, too */
+ ASSERT(get_itbl(closure)->type!=FETCH_ME ||
+ looks_like_ga(((StgFetchMe*)closure)->ga));
+
/* Sort out the global address mapping */
if (ip_THUNK(ip)){
// || // (ip_THUNK(ip) && !ip_UNPOINTED(ip)) ||
newGA->weight = gaga->weight = 1L << (BITS_IN(unsigned) - 1);
gaga->payload = newGA->payload;
*/
- ASSERT(gaga->weight == 1L << (BITS_IN(unsigned) - 1));
+ ASSERT(gaga->weight == 1U << (BITS_IN(unsigned) - 1));
gaga++;
}
return closure;
/* Make sure that nothing sans the fixed header is filled in
The ga field of the FETCH_ME is filled in in SetGAandCommonUp */
- if (ip->type == FETCH_ME) {
- ASSERT(size>=MIN_UPD_SIZE); // size of the FM in the heap
+ if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
+ ASSERT(size>=_HS+MIN_UPD_SIZE); // size of the FM in the heap
ptrs = nonptrs = vhs = 0; // i.e. only unpack FH from buffer
}
/* ToDo: check whether this is really needed */
// ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
// return bufptr;
*bufptrP = bufptr;
- ASSERT((ip->type==FETCH_ME && sizeofW(StgFetchMe)==size) ||
+ ASSERT(((ip->type==FETCH_ME || ip->type==REMOTE_REF)&& sizeofW(StgFetchMe)==size) ||
_HS+vhs+ptrs+nonptrs == size);
return size;
}
while (*pptrP + 1 > *pptrsP) {
/* *parentP has been constructed (all pointer set); so check it now */
IF_DEBUG(sanity,
- if (*parentP!=(StgClosure*)NULL &&
- get_itbl(*parentP)->type != FETCH_ME)
+ if ((*parentP!=(StgClosure*)NULL) && // not root
+ (*((StgPtr)(*parentP)+1)!=GARBAGE_MARKER) && // not commoned up
+ (get_itbl(*parentP)->type != FETCH_ME))
checkClosure(*parentP));
*parentP = DeQueueClosure();
UnpackClosure (StgWord ***bufptrP, StgClosure **graphP, globalAddr *ga) {
StgClosure *closure;
nat size;
- rtsBool hasGA = rtsFalse;
+ rtsBool hasGA = rtsFalse, unglobalised = rtsFalse;
/* Now unpack the closure body, if there is one; three cases:
- PLC: closure is just a pointer to a static closure
} else if (isOffset(ga)) {
closure = UnpackOffset(ga);
} else {
- ASSERT(LOOKS_LIKE_GA(ga));
+ /* if not PLC or Offset it must be a GA and then the closure */
+ ASSERT(RtsFlags.ParFlags.globalising!=0 || LOOKS_LIKE_GA(ga));
+ /* check whether this is an unglobalised closure */
+ unglobalised = isUnglobalised(ga);
/* Now we have to build something. */
hasGA = !isConstr(ga);
/* the new closure will be built here */
closure = *graphP;
-
+
/* fill in the closure from the buffer */
size = FillInClosure(/*in/out*/bufptrP, /*in*/closure);
+ /* if it is unglobalised, it may not be a thunk!! */
+ ASSERT(!unglobalised || !closure_THUNK(closure));
- /* Add to queue for processing */
+ /* Add to queue for processing */
QueueClosure(closure);
-
+
/* common up with other graph if necessary */
- closure = SetGAandCommonUp(ga, closure, hasGA);
+ if (!unglobalised)
+ closure = SetGAandCommonUp(ga, closure, hasGA);
/* if we unpacked a THUNK, check that it is large enough to update */
- ASSERT(!closure_THUNK(closure) || size>=MIN_UPD_SIZE);
+ ASSERT(!closure_THUNK(closure) || size>=_HS+MIN_UPD_SIZE);
/* graph shall point to next free word in the heap */
*graphP += size;
- //graph += (size < MIN_UPD_SIZE) ? MIN_UPD_SIZE : size;
+ //*graphP += (size < _HS+MIN_UPD_SIZE) ? _HS+MIN_UPD_SIZE : size; // see ASSERT
}
return closure;
}
StgClosure *closure, *graphroot, *graph, *parent;
nat size, heapsize, bufsize,
pptr = 0, pptrs = 0, pvhs = 0;
+ nat unpacked_closures = 0, unpacked_thunks = 0; // stats only
+
+ IF_PAR_DEBUG(resume,
+ graphFingerPrint[0] = '\0');
+
+ ASSERT(_HS==1); // HWL HACK; compile time constant
+#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
+ PAR_TICKY_UNPACK_GRAPH_START();
+#endif
+
/* Initialisation */
InitPacking(rtsTrue); // same as in PackNearbyGraph
globalUnpackBuffer = packBuffer;
if (heapsize > 0) {
graph = (StgClosure *)allocate(heapsize);
ASSERT(graph != NULL);
+ // parallel global statistics: increase amount of global data
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.tot_global += heapsize;
+ }
}
/* iterate over the buffer contents and unpack all closures */
parent = (StgClosure *)NULL;
do {
+ /* check that we aren't at the end of the buffer, yet */
+ IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
+
/* This is where we will ultimately save the closure's address */
slotptr = bufptr;
/* this allocates heap space, updates LAGA tables etc */
closure = UnpackClosure (/*in/out*/&bufptr, /*in/out*/&graph, /*in*/&gaS);
+ unpacked_closures++; // stats only; doesn't count FMs in PAP!!!
+ unpacked_thunks += (closure_THUNK(closure)) ? 1 : 0; // stats only
/*
* Set parent pointer to point to chosen closure. If we're at the top of
((StgPtr)parent)[_HS + pvhs + pptr] = (StgWord) closure;
/* Save closure pointer for resolving offsets */
- *slotptr = (StgWord) closure;
+ *slotptr = (StgWord*) closure;
/* Locate next parent pointer */
LocateNextParent(&parent, &pptr, &pptrs, &size);
gaS.payload.gc.slot = 0xdeadbeef;);
} while (parent != NULL);
+ IF_PAR_DEBUG(resume,
+ GraphFingerPrint(graphroot, graphFingerPrint);
+ ASSERT(strlen(graphFingerPrint)<=MAX_FINGER_PRINT_LEN);
+ belch(">>> Fingerprint of graph rooted at %p (after unpacking <<%d>>:\n {%s}",
+ graphroot, packBuffer->id, graphFingerPrint));
+
/* we unpacked exactly as many words as there are in the buffer */
- ASSERT(bufsize == bufptr-(packBuffer->buffer) &&
- heapsize >= graph-graphroot); // should be ==
+ ASSERT(bufsize == (nat) (bufptr-(packBuffer->buffer)));
+ /* we filled no more heap closure than we allocated at the beginning;
+ ideally this should be a ==;
+ NB: test is only valid if we unpacked anything at all (graphroot might
+ end up to be a PLC!), therfore the strange test for HEAP_ALLOCED
+ */
+
+ /*
+ {
+ StgInfoTable *info = get_itbl(graphroot);
+ ASSERT(!HEAP_ALLOCED(graphroot) || heapsize >= (nat) (graph-graphroot) ||
+ // ToDo: check whether CAFs are really a special case here!!
+ info->type==CAF_BLACKHOLE || info->type==FETCH_ME || info->type==FETCH_ME_BQ);
+ }
+ */
+
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
*gamap = PendingGABuffer;
*nGAs = (gaga - PendingGABuffer) / 2;
StgPtr p;
/* check the unpacked graph */
- checkHeapChunk(graphroot,graph-sizeof(StgWord));
+ //checkHeapChunk(graphroot,graph-sizeof(StgWord));
// if we do sanity checks, then wipe the pack buffer after unpacking
- for (p=packBuffer->buffer; p<(packBuffer->buffer)+(packBuffer->size); )
+ for (p=(StgPtr)packBuffer->buffer; p<(StgPtr)(packBuffer->buffer)+(packBuffer->size); )
*p++ = 0xdeadbeef;
});
/* reset the global variable */
globalUnpackBuffer = (rtsPackBuffer*)NULL;
+
+#if defined(PAR_TICKY) // HWL HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACK
+ PAR_TICKY_UNPACK_GRAPH_END(unpacked_closures, unpacked_thunks);
+#endif
+
return (graphroot);
}
/* First, unpack the next GA or PLC */
ga->weight = (rtsWeight) *bufptr++;
- if (ga->weight > 0) {
+ if (ga->weight == 2) { // unglobalised closure to follow
+ // nothing to do; closure starts at *bufptr
+ } else if (ga->weight > 0) { // fill in GA
ga->payload.gc.gtid = (GlobalTaskId) *bufptr++;
ga->payload.gc.slot = (int) *bufptr++;
} else {
/* No more to unpack; just set closure to local address */
IF_PAR_DEBUG(pack,
belch("*<^^ Unpacked PLC at %x", ga->payload.plc));
- return ga->payload.plc;
+ return (StgClosure*)ga->payload.plc;
}
//@cindex UnpackOffset
ASSERT(globalUnpackBuffer!=(rtsPackBuffer*)NULL);
/* No more to unpack; just set closure to cached address */
IF_PAR_DEBUG(pack,
- belch("*<__ Unpacked indirection to %p (was offset %d)",
+ belch("*<__ Unpacked indirection to %p (was OFFSET %d)",
(StgClosure *)((globalUnpackBuffer->buffer)[ga->payload.gc.slot]),
ga->payload.gc.slot));
-return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
+ return (StgClosure *)(globalUnpackBuffer->buffer)[ga->payload.gc.slot];
}
/*
IF_DEBUG(sanity,
if (isFixed(&gaS))
barf("*< UnpackFetchMe: found PLC where FM was expected %p (%s)",
- *bufptrP, info_type(*bufptrP)));
+ *bufptrP, info_type((StgClosure*)*bufptrP)));
IF_PAR_DEBUG(pack,
belch("*<_- Unpacked @ %p a FETCH_ME to GA ",
*graphP);
- printGA(&gaS));
+ printGA(&gaS);
+ fputc('\n', stderr));
/* the next thing must be the IP to a FETCH_ME closure */
ASSERT(get_itbl((StgClosure *)*bufptrP)->type == FETCH_ME);
ASSERT(foo!=closure || LOOKS_LIKE_GA(((StgFetchMe*)closure)->ga));
IF_PAR_DEBUG(pack,
- belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
- *graphP, *graphP+sizeofW(StgFetchMe), closure);
- printClosure(closure));
+ if (foo==closure) { // only if not commoned up
+ belch("*<_- current FM @ %p next FM @ %p; unpacked FM @ %p is ",
+ *graphP, *graphP+sizeofW(StgFetchMe), closure);
+ printClosure(closure);
+ });
*graphP += sizeofW(StgFetchMe);
return foo;
}
// this includes the header!: arr_words_sizeW(stgCast(StgArrWords*,q));
IF_PAR_DEBUG(pack,
- belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
+ if (n<100)
+ belch("*<== unpacking an array of %d words %p (%s) (size=%d) |%s|\n",
+ n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
+ arr_words_sizeW((StgArrWords *)bufptr),
+ /* print array (string?) */
+ ((StgArrWords *)graph)->payload);
+ else
+ belch("*<== unpacking an array of %d words %p (%s) (size=%d)\n",
n, (StgClosure*)bufptr, info_type((StgClosure*)bufptr),
arr_words_sizeW((StgArrWords *)bufptr)));
/* Unpack the header (2 words: info ptr and the number of words to follow) */
- ((StgArrWords *)graph)->header.info = *bufptr++; // assumes _HS==1; yuck!
- ((StgArrWords *)graph)->words = *bufptr++;
+ ((StgArrWords *)graph)->header.info = (StgInfoTable*)*bufptr++; // assumes _HS==1; yuck!
+ ((StgArrWords *)graph)->words = (StgWord)*bufptr++;
/* unpack the payload of the closure (all non-ptrs) */
for (i=0; i<n; i++)
- ((StgArrWords *)graph)->payload[i] = *bufptr++;
+ ((StgArrWords *)graph)->payload[i] = (StgWord)*bufptr++;
ASSERT(bufptr==*bufptrP+arr_words_sizeW((StgArrWords *)*bufptrP));
*bufptrP = bufptr;
const StgInfoTable* info;
StgWord32 bitmap;
StgWord **bufptr = *bufptrP;
+#if defined(DEBUG)
+ nat FMs_in_PAP=0;
+ void checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end);
+#endif
IF_PAR_DEBUG(pack,
belch("*<** UnpackPAP: unpacking PAP @ %p with %d words to closure %p",
*bufptr, *(bufptr+1), graph));
/* Unpack the PAP header (both fixed and variable) */
- ((StgPAP *)graph)->header.info = *bufptr++;
- n = ((StgPAP *)graph)->n_args = *bufptr++;
- ((StgPAP *)graph)->fun = *bufptr++;
- packed_size = *bufptr++;
+ ((StgPAP *)graph)->header.info = (StgInfoTable*)*bufptr++;
+ n = ((StgPAP *)graph)->n_args = (StgWord)*bufptr++;
+ ((StgPAP *)graph)->fun = (StgClosure*)*bufptr++;
+ packed_size = (nat)*bufptr++;
IF_PAR_DEBUG(pack,
belch("*<** UnpackPAP: PAP header is [%p, %d, %p] %d",
((StgPAP *)graph)->fun,
packed_size));
- payload_start = bufptr;
+ payload_start = (StgPtr)bufptr;
/* p points to the current word in the heap */
- p = ((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
- p_FMs = graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
+ p = (StgPtr)((StgPAP *)graph)->payload; // payload of PAP will be unpacked here
+ p_FMs = (StgPtr)graph+pap_sizeW((StgPAP*)graph); // FMs will be unpacked here
end = (StgPtr) payload_start+packed_size;
/*
The main loop unpacks the PAP in *bufptr into *p, with *p_FMS as the
FM area for unpacking all FETCHMEs encountered during unpacking.
*/
- while (bufptr<end) {
+ while ((StgPtr)bufptr<end) {
/* be sure that we don't write more than we allocated for this closure */
- ASSERT(p_FMs <= graph+_HS+2+packed_size);
+ ASSERT(p_FMs <= (StgPtr)(graph+_HS+2+packed_size));
/* be sure that the unpacked PAP doesn't run into the FM area */
- ASSERT(p < graph+pap_sizeW((StgPAP*)graph));
+ ASSERT(p < (StgPtr)(graph+pap_sizeW((StgPAP*)graph)));
/* the loop body has been borrowed from scavenge_stack */
q = *bufptr; // let q be the contents of the current pointer into the buffer
*/
if (q==(StgPtr)(ARGTAG_MAX+1)) {
IF_PAR_DEBUG(pack,
- belch("*<** UnpackPAP @ %p: unpacking FM to %p",
- p, q));
+ belch("*<** UnpackPAP @ %p: unpacking FM; filling in ptr to FM area: %p",
+ p, p_FMs));
bufptr++; // skip ARGTAG_MAX+1 marker
// Unpack a FM into the FM area after the PAP proper and insert pointer
- *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
+ IF_DEBUG(sanity, FMs_in_PAP++);
continue;
}
belch("*<** UnpackPAP @ %p: unpacking PLC to %p",
p, *(bufptr+1)));
bufptr++; // skip 0 marker
- *p++ = *bufptr++;
+ *p++ = (StgWord)*bufptr++;
continue;
}
/* If we've got a tag, pack all words in that block */
if (IS_ARG_TAG((W_)q)) { // q stands for the no. of non-ptrs to follow
- nat m = i+ARG_SIZE(q); // first word after this block
+ nat m = ARG_SIZE(q); // first word after this block
IF_PAR_DEBUG(pack,
belch("*<** UnpackPAP @ %p: unpacking %d words (tagged), starting @ %p",
p, m, p));
for (i=0; i<m+1; i++)
- *p++ = *bufptr++;
+ *p++ = (StgWord)*bufptr++;
continue;
}
p));
/* Pack the header as is */
- ((StgRetDyn *)p)->info = *bufptr++;
- ((StgRetDyn *)p)->liveness = *bufptr;
- ((StgRetDyn *)p)->ret_addr= *bufptr;
+ ((StgRetDyn *)p)->info = (StgWord)*bufptr++;
+ ((StgRetDyn *)p)->liveness = (StgWord)*bufptr++;
+ ((StgRetDyn *)p)->ret_addr = (StgWord)*bufptr++;
+ p += 3;
//bitmap = ((StgRetDyn *)p)->liveness;
//p = (P_)&((StgRetDyn *)p)->payload[0];
belch("*<** UnpackPAP @ %p: FUN or FUN_STATIC",
p));
- ((StgClosure *)p)->header.info = *bufptr;
+ ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr;
p++;
goto follow_srt; //??
belch("*<** UnackPAP @ %p: UPDATE_FRAME",
p));
- ((StgUpdateFrame *)p)->header.info = *bufptr;
- ((StgUpdateFrame *)p)->link= *bufptr++; // ToDo: fix intra-stack pointer
- ((StgUpdateFrame *)p)->updatee = *bufptr; // ToDo: follow link
+ ((StgUpdateFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
+ ((StgUpdateFrame *)p)->link = (StgUpdateFrame*)*bufptr++; // ToDo: fix intra-stack pointer
+ ((StgUpdateFrame *)p)->updatee = (StgClosure*)*bufptr++; // ToDo: follow link
p += 3;
}
IF_PAR_DEBUG(pack,
belch("*<** UnpackPAP @ %p: STOP_FRAME",
p));
- ((StgStopFrame *)p)->header.info = *bufptr;
+ ((StgStopFrame *)p)->header.info = (StgInfoTable*)*bufptr;
p++;
}
belch("*<** UnpackPAP @ %p: CATCH_FRAME",
p));
- ((StgCatchFrame *)p)->header.info = *bufptr++;
- ((StgCatchFrame *)p)->link = *bufptr++;
- ((StgCatchFrame *)p)->exceptions_blocked = *bufptr++;
- ((StgCatchFrame *)p)->handler = *bufptr++;
+ ((StgCatchFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
+ ((StgCatchFrame *)p)->link = (StgUpdateFrame*)*bufptr++;
+ ((StgCatchFrame *)p)->exceptions_blocked = (StgInt)*bufptr++;
+ ((StgCatchFrame *)p)->handler = (StgClosure*)*bufptr++;
p += 4;
}
belch("*<** UnpackPAP @ %p: UPDATE_FRAME",
p));
- ((StgSeqFrame *)p)->header.info = *bufptr++;
- ((StgSeqFrame *)p)->link = *bufptr++;
+ ((StgSeqFrame *)p)->header.info = (StgInfoTable*)*bufptr++;
+ ((StgSeqFrame *)p)->link = (StgUpdateFrame*)*bufptr++;
// ToDo: handle bitmap
bitmap = info->layout.bitmap;
p));
- ((StgClosure *)p)->header.info = *bufptr++;
+ ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
p++;
// ToDo: handle bitmap
bitmap = info->layout.bitmap;
small_bitmap:
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
- *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
+ IF_DEBUG(sanity, FMs_in_PAP++);
} else {
- *p++ = *bufptr++;
+ *p++ = (StgWord)*bufptr++;
}
bitmap = bitmap >> 1;
}
{
StgPtr q;
StgLargeBitmap *large_bitmap;
- nat i;
IF_PAR_DEBUG(pack,
belch("*<** UnpackPAP @ %p: RET_{BIG,VEC_BIG} (large_bitmap=%p)",
p, info->layout.large_bitmap));
- ((StgClosure *)p)->header.info = *bufptr++;
+ ((StgClosure *)p)->header.info = (StgInfoTable*)*bufptr++;
p++;
large_bitmap = info->layout.large_bitmap;
q = p + sizeof(W_) * 8;
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
- *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
+ IF_DEBUG(sanity, FMs_in_PAP++);
} else {
- *p++ = *bufptr;
+ *p++ = (StgWord)*bufptr;
}
bitmap = bitmap >> 1;
}
if (j+1 < large_bitmap->size) {
while (p < q) {
- *p++ = UnpackFetchMe(&bufptr, &p_FMs);
+ *p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
+ IF_DEBUG(sanity, FMs_in_PAP++);
}
}
}
checkClosure(graph));
*bufptrP = bufptr;
- return _HS+2+packed_size;
+ /*
+ Now p points to the first word after the PAP proper and p_FMs points
+ to the next free word in the heap; everything between p and p_FMs are
+ FETCHMEs
+ */
+ IF_DEBUG(sanity,
+ checkPAPSanity(graph, p, p_FMs));
+
+ /* we have to return the size of PAP + FMs as size of the unpacked thing */
+ ASSERT(graph+pap_sizeW((StgPAP*)graph)==p);
+ return (nat)((StgClosure*)p_FMs-graph);
}
+#if defined(DEBUG)
+/*
+ Check sanity of a PAP after unpacking the PAP.
+ This means that there is slice of heap after the PAP containing FETCHMEs
+*/
+void
+checkPAPSanity(StgPAP *graph, StgPtr p_FM_begin, StgPtr p_FM_end)
+{
+ StgPtr xx;
+
+ /* check that the main unpacked closure is a PAP */
+ ASSERT(graph->header.info = &stg_PAP_info);
+ checkClosure(graph);
+ /* check that all of the closures in the FM-area are FETCHMEs */
+ for (xx=p_FM_begin; xx<p_FM_end; xx += sizeofW(StgFetchMe)) {
+ /* must be a FETCHME closure */
+ ASSERT(((StgClosure*)xx)->header.info == &stg_FETCH_ME_info);
+ /* it might have been commoned up (=> marked as garbage);
+ otherwise it points to a GA */
+ ASSERT((((StgFetchMe*)xx)->ga)==GARBAGE_MARKER ||
+ LOOKS_LIKE_GA(((StgFetchMe*)xx)->ga));
+ }
+ /* traverse the payload of the PAP */
+ for (xx=graph->payload; xx-(StgPtr)(graph->payload)<graph->n_args; xx++) {
+ /* if the current elem is a pointer into the FM area, check that
+ the GA field is ok */
+ ASSERT(!(p_FM_begin<(StgPtr)*xx && (StgPtr)*xx<p_FM_end) ||
+ LOOKS_LIKE_GA(((StgFetchMe*)*xx)->ga));
+ }
+}
+#endif /* DEBUG */
#endif /* PAR */
-//@node GranSim Code, , Local Definitions, Unpacking routines
+//@node GranSim Code, , GUM code, Unpacking routines
//@subsubsection GranSim Code
/*
}
# endif
-//@node Packet size, Types of Global Addresses, Offset table, Aux fcts for packing
+//@node Packet size, Closure Info, Offset table, Aux fcts for packing
//@subsubsection Packet size
+/*
+ The size needed if all currently queued closures are packed as FETCH_ME
+ closures. This represents the headroom we must have when packing the
+ buffer in order to maintain all links in the graphs.
+*/
+// ToDo: check and merge cases
+#if defined(PAR)
+static nat
+QueuedClosuresMinSize (nat ptrs) {
+ return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
+}
+#else /* GRAN */
+static nat
+QueuedClosuresMinSize (nat ptrs) {
+ return ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE;
+}
+#endif
+
/*
RoomToPack determines whether there's room to pack the closure into
the pack buffer based on
{
# if defined(PAR)
if (roomInBuffer &&
- (pack_locn + // where we are in the buffer right now
- size + // space needed for the current closure
- ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE // space for queued closures
+ (pack_locn + // where we are in the buffer right now
+ size + // space needed for the current closure
+ QueuedClosuresMinSize(ptrs) // space for queued closures as FETCH_MEs
+ + 1 // headroom (DEBUGGING only)
>=
RTS_PACK_BUFFER_SIZE))
{
- IF_PAR_DEBUG(pack,
- belch("*>** pack buffer full"));
roomInBuffer = rtsFalse;
}
# else /* GRAN */
if (roomInBuffer &&
- (unpacked_size + size +
- ((clq_size - clq_pos) + ptrs) * PACK_FETCHME_SIZE >= RTS_PACK_BUFFER_SIZE))
+ (unpacked_size +
+ size +
+ QueuedClosuresMinSize(ptrs)
+ >=
+ RTS_PACK_BUFFER_SIZE))
{
- IF_GRAN_DEBUG(pack,
- belch("*>** pack buffer full"));
roomInBuffer = rtsFalse;
}
# endif
return (roomInBuffer);
}
-//@node Types of Global Addresses, Closure Info, Packet size, Aux fcts for packing
-//@subsubsection Types of Global Addresses
-
-/*
- Types of Global Addresses
-
- These routines determine whether a GA is one of a number of special types
- of GA.
-*/
-
-# if defined(PAR)
-//@cindex isOffset
-rtsBool inline
-isOffset(globalAddr *ga)
-{
- return (ga->weight == 1 && ga->payload.gc.gtid == 0);
-}
-
-//@cindex isFixed
-rtsBool inline
-isFixed(globalAddr *ga)
-{
- return (ga->weight == 0);
-}
-
-//@cindex isConstr
-rtsBool inline
-isConstr(globalAddr *ga)
-{
- return (ga->weight == 2);
-}
-# endif
-
-//@node Closure Info, , Types of Global Addresses, Aux fcts for packing
+//@node Closure Info, , Packet size, Aux fcts for packing
//@subsubsection Closure Info
/*
StgClosure *parent, *graphroot, *closure_start;
const StgInfoTable *ip;
globalAddr ga;
- StgWord **buffer, **bufptr, **slotptr;
+ StgWord **bufptr, **slotptr;
nat bufsize;
nat pptr = 0, pptrs = 0, pvhs;
nat size, ptrs, nonptrs, vhs;
char str[80];
+ /* disable printing if a non-std globalisation scheme is used; ToDo: FIX */
+ if (RtsFlags.ParFlags.globalising != 0)
+ return;
+
/* NB: this whole routine is more or less a copy of UnpackGraph with all
unpacking components replaced by printing fcts
Long live higher-order fcts!
/* First, unpack the next GA or PLC */
ga.weight = (rtsWeight) *bufptr++;
- if (ga.weight > 0) {
+ if (ga.weight == 2) { // unglobalised closure to follow
+ // nothing to do; closure starts at *bufptr
+ } else if (ga.weight > 0) { // fill in GA
ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
ga.payload.gc.slot = (int) *bufptr++;
} else
fprintf(stderr, "*. %u: ((%x, %d, %x)) ", locn,
ga.payload.gc.gtid, ga.payload.gc.slot, ga.weight);
- closure_start = bufptr;
+ closure_start = (StgClosure*)bufptr;
ip = get_closure_info((StgClosure *)bufptr,
&size, &ptrs, &nonptrs, &vhs, str);
/* ToDo: check whether this is really needed */
- if (ip->type == FETCH_ME) {
+ if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
size = _HS;
ptrs = nonptrs = vhs = 0;
}
if (ip->type == PAP || ip->type == AP_UPD) {
vhs = 3;
ptrs = 0;
- nonptrs = ((StgPAP *)bufptr)->payload[0];
+ nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
size = _HS+vhs+ptrs+nonptrs;
}
for (i = 0; i < _HS; i++)
fprintf(stderr, " %p", *bufptr++);
- if (ip->type == FETCH_ME)
+ if (ip->type == FETCH_ME || ip->type == REMOTE_REF)
size = ptrs = nonptrs = vhs = 0;
// VH is always empty in the new RTS
StgClosure *parent, *graphroot, *closure_start;
const StgInfoTable *ip;
globalAddr ga;
- StgWord **buffer, **bufptr, **slotptr;
+ StgWord **bufptr, **slotptr;
nat bufsize;
nat pptr = 0, pptrs = 0, pvhs;
parent = (StgClosure *)NULL;
ASSERT(bufsize > 0);
do {
+ /* check that we are not at the end of the buffer, yet */
+ IF_DEBUG(sanity, ASSERT(*bufptr != END_OF_BUFFER_MARKER));
+
/* This is where we will ultimately save the closure's address */
slotptr = bufptr;
locn = slotptr-(packBuffer->buffer); // index of closure in buffer
/* First, check whether we have a GA, a PLC, or an OFFSET at hand */
ga.weight = (rtsWeight) *bufptr++;
- if (ga.weight > 0) {
+
+ if (ga.weight == 2) { // unglobalised closure to follow
+ // nothing to do; closure starts at *bufptr
+ } else if (ga.weight > 0) { // fill in GA
ga.payload.gc.gtid = (GlobalTaskId) *bufptr++;
ga.payload.gc.slot = (int) *bufptr++;
} else
/* It's a PLC */
ASSERT(LOOKS_LIKE_STATIC(ga.payload.plc));
} else if (isOffset(&ga)) {
- ASSERT(ga.payload.gc.slot<=bufsize);
+ ASSERT(ga.payload.gc.slot<=(int)bufsize);
} else {
/* normal closure */
- ASSERT(LOOKS_LIKE_GA(&ga));
+ ASSERT(!RtsFlags.ParFlags.globalising==0 || LOOKS_LIKE_GA(&ga));
- closure_start = bufptr;
+ closure_start = (StgClosure*)bufptr;
ASSERT(LOOKS_LIKE_GHC_INFO((StgPtr)*bufptr));
ip = get_closure_info((StgClosure *)bufptr,
&size, &ptrs, &nonptrs, &vhs, str);
/* ToDo: check whether this is really needed */
- if (ip->type == FETCH_ME) {
+ if (ip->type == FETCH_ME || ip->type == REMOTE_REF) {
size = _HS;
ptrs = nonptrs = vhs = 0;
}
if (ip->type == PAP || ip->type == AP_UPD) {
vhs = 3;
ptrs = 0;
- nonptrs = ((StgPAP *)bufptr)->payload[0];
+ nonptrs = (nat)((StgPAP *)bufptr)->payload[0];
size = _HS+vhs+ptrs+nonptrs;
}
} while (parent != NULL);
/* we unpacked exactly as many words as there are in the buffer */
ASSERT(packBuffer->size == bufptr-(packBuffer->buffer));
+ /* check for magic end-of-buffer word */
+ IF_DEBUG(sanity, ASSERT(*bufptr == END_OF_BUFFER_MARKER));
}
#else /* GRAN */
void
/* --------------------------------------------------------------------------
- Time-stamp: <Fri Mar 24 2000 17:42:24 Stardate: [-30]4553.68 hwloidl>
- $Id: ParInit.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Wed Mar 21 2001 16:37:16 Stardate: [-30]6363.46 hwloidl>
+ $Id: ParInit.c,v 1.4 2001/03/22 03:51:11 hwloidl Exp $
Initialising the parallel RTS
//@node Includes, Global variables
//@subsection Includes
+#include <setjmp.h>
#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
#include "ParallelRts.h"
-#include <setjmp.h>
+#include "Sparks.h"
#include "LLC.h"
#include "HLC.h"
/* Global conditions defined here. */
-rtsBool IAmMainThread = rtsFalse, /* Set for the main thread */
- GlobalStopPending = rtsFalse; /* Terminating */
+rtsBool IAmMainThread = rtsFalse; /* Set for the main thread */
/* Task identifiers for various interesting global tasks. */
//@cindex advisory_thread_count
nat advisory_thread_count = 0;
+globalAddr theGlobalFromGA;
+
/* For flag handling see RtsFlags.h */
//@node Prototypes
terminate, since STG_Exception will call myexit\tr{(0)} when
it received a PP_FINISH from the system manager task.
*/
-//@cindex par_exit
+//@cindex shutdownParallelSystem
void
shutdownParallelSystem(StgInt n)
{
- belch("==== entered shutdownParallelSystem ...");
- ASSERT(GlobalStopPending = rtsTrue);
- sendOp(PP_FINISH, SysManTask);
- if (n != 0)
- waitForTermination();
- else
- waitForPEOp(PP_FINISH, SysManTask);
- shutDownPE();
+ /* use the file specified via -S */
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+
IF_PAR_DEBUG(verbose,
- belch("--++ shutting down PE %lx, %ld sparks created, %ld sparks Ignored, %ld threads created, %ld threads Ignored",
- (W_) mytid, sparksCreated, sparksIgnored,
- threadsCreated, threadsIgnored));
- if (n!=0)
- exit(n);
+ if (n==0)
+ belch("==== entered shutdownParallelSystem ...");
+ else
+ belch("==== entered shutdownParallelSystem (ERROR %d)...", n);
+ );
+
+ stopPEComms(n);
+
+#if 0
+ if (sf!=(FILE*)NULL)
+ fprintf(sf, "PE %x: %u sparks created, %u sparks Ignored, %u threads created, %u threads Ignored",
+ (W_) mytid, sparksCreated, sparksIgnored,
+ threadsCreated, threadsIgnored);
+#endif
+
+ ShutdownEachPEHook();
}
//@cindex initParallelSystem
/* Don't buffer standard channels... */
setbuf(stdout,NULL);
setbuf(stderr,NULL);
-
- srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
- /* Used to select target of FISH message*/
-
+
+ srand48(time(NULL) * getpid()); /* Initialise Random-number generator seed*/
+ /* used to select target of FISH message*/
if (!InitPackBuffer())
barf("InitPackBuffer");
* manager, and initialises the Global address tables (LAGA & GALA)
*/
-//@cindex SynchroniseSystem
+//@cindex synchroniseSystem
void
-SynchroniseSystem(void)
+synchroniseSystem(void)
{
- int i;
+ /* Only in debug mode? */
+ fprintf(stderr, "==== Starting parallel execution on %d processors ...\n", nPEs);
- fprintf(stderr, "==== SynchroniseSystem: nPEs=%d\n", nPEs);
+ InitEachPEHook(); /* HWL: hook to be execed on each PE */
- initEachPEHook(); /* HWL: hook to be execed on each PE */
+ /* Initialize global address tables */
+ initGAtables();
- fprintf(stderr, "==== SynchroniseSystem: initParallelSystem\n");
initParallelSystem();
- allPEs = startUpPE(nPEs);
+
+ startPEComms();
+}
- /* Initialize global address tables */
- initGAtables();
+/*
+ Do the startup stuff (this is PVM specific!).
+ Determines global vars: mytid, IAmMainThread, SysManTask, nPEs
+ Called at the beginning of RtsStartup.startupHaskell
+*/
+void
+startupParallelSystem(char *argv[]) {
+ mytid = pvm_mytid(); /* Connect to PVM */
+
+ if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
+ IAmMainThread = rtsTrue;
+ sscanf(argv[0],"-%0X",&SysManTask); /* extract SysMan task ID*/
+ argv++; /* Strip off flag argument */
+ } else {
+ SysManTask = pvm_parent();
+ }
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== [%x] %s PE located SysMan at %x\n",
+ mytid, IAmMainThread?"Main":"Remote", SysManTask));
+
+ nPEs = atoi(argv[1]);
+}
- /* Record the shortened the PE identifiers for LAGA etc. tables */
- for (i = 0; i < nPEs; ++i) {
- fprintf(stderr, "==== [%x] registering %d-th PE as %x\n", mytid, i, allPEs[i]);
- registerTask(allPEs[i]);
+/*
+ Exception handler during startup.
+*/
+void *
+processUnexpectedMessageDuringStartup(rtsPacket p) {
+ OpCode opCode;
+ GlobalTaskId sender_id;
+
+ getOpcodeAndSender(p, &opCode, &sender_id);
+
+ switch(opCode) {
+ case PP_FISH:
+ bounceFish();
+ break;
+#if defined(DIST)
+ case PP_REVAL:
+ bounceReval();
+ break;
+#endif
+ case PP_FINISH:
+ stg_exit(EXIT_SUCCESS);
+ break;
+ default:
+ fprintf(stderr,"== Task %x: Unexpected OpCode %x (%s) from %x in startPEComms\n",
+ mytid, opCode, getOpName(opCode), sender_id);
+ }
+}
+
+void
+startPEComms(void){
+
+ startUpPE();
+ allPEs = (GlobalTaskId *) stgMallocBytes(sizeof(GlobalTaskId) * MAX_PES,
+ "(PEs)");
+
+ /* Send our tid and IAmMainThread flag back to SysMan */
+ sendOp1(PP_READY, SysManTask, (StgWord)IAmMainThread);
+ /* Wait until we get the PE-Id table from Sysman */
+ waitForPEOp(PP_PETIDS, SysManTask, processUnexpectedMessageDuringStartup);
+
+ IF_PAR_DEBUG(verbose,
+ belch("==-- startPEComms: methinks we just received a PP_PETIDS message"));
+
+ /* Digest the PE table we received */
+ processPEtids();
+}
+
+void
+processPEtids(void) {
+ long newPE;
+ nat i, sentPEs, currentPEs;
+
+ nPEs=0;
+
+ currentPEs = nPEs;
+
+ IF_PAR_DEBUG(verbose,
+ belch("==-- processPEtids: starting to iterate over a PVM buffer"));
+ /* ToDo: this has to go into LLComms !!! */
+ GetArgs(&sentPEs,1);
+
+ ASSERT(sentPEs > currentPEs);
+ ASSERT(sentPEs < MAX_PES); /* enforced by SysMan too*/
+
+ for (i = 0; i < sentPEs; i++) {
+ GetArgs(&newPE,1);
+ if (i<currentPEs) {
+ ASSERT(newPE == allPEs[i]);
+ } else {
+#if defined(DIST)
+ // breaks with PAR && !DEBUG
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "[%x] registering %d'th %x\n", mytid, i, newPE));
+ if(!looks_like_tid(newPE))
+ barf("unacceptable taskID %x\n",newPE);
+#endif
+ allPEs[i] = newPE;
+ nPEs++;
+ registerTask(newPE);
+ }
}
+
+ IF_PAR_DEBUG(verbose,
+ /* debugging */
+ belch("++++ [%x] PE table as I see it:", mytid);
+ for (i = 0; i < sentPEs; i++) {
+ belch("++++ allPEs[%d] = %x", i, allPEs[i]);
+ });
+}
+
+void
+stopPEComms(StgInt n) {
+ if (n != 0) {
+ /* In case sysman doesn't know about us yet...
+ pvm_initsend(PvmDataDefault);
+ PutArgs(&IAmMainThread,1);
+ pvm_send(SysManTask, PP_READY);
+ */
+ sendOp(PP_READY, SysManTask);
+ }
+
+ sendOp2(PP_FINISH, SysManTask, n, n);
+ waitForPEOp(PP_FINISH, SysManTask, NULL);
+ fflush(gr_file);
+ shutDownPE();
}
#endif /* PAR -- whole file */
//* spark queue:: @cindex\s-+spark queue
//* sparksIgnored:: @cindex\s-+sparksIgnored
//@end index
+
--- /dev/null
+/* -------------------------------------------------------------------------
+ * $Id: ParTicky.c,v 1.1 2001/03/22 03:51:11 hwloidl Exp $
+ *
+ * (c) Hans-Wolfgang Loidl, 2000-
+ *
+ * Parallel ticky profiling, monitoring basic RTS operations in GUM.
+ * Similar in structure to TICKY_TICKY profiling, but doesn't need a
+ * separate way of building GHC.
+ *-------------------------------------------------------------------------- */
+
+#if defined(PAR) && defined(PAR_TICKY)
+
+#include "Rts.h"
+#include "RtsFlags.h"
+#include "RtsUtils.h"
+//#include "StoragePriv.h"
+//#include "MBlock.h"
+//#include "Schedule.h"
+#include "GC.h"
+#include "Stats.h"
+#include "ParTicky.h" // ToDo: move into Rts.h
+#include "ParallelRts.h"
+
+#if defined(PAR) && defined(HAVE_GETRUSAGE)
+#include <sys/resource.h>
+#endif
+
+/* external data */
+extern double ElapsedTimeStart;
+
+extern ullong GC_tot_alloc;
+extern ullong GC_tot_copied;
+
+extern lnat MaxResidency; /* in words; for stats only */
+extern lnat ResidencySamples; /* for stats only */
+
+/* ngIplu' {Stats.c}vo' */
+#define BIG_STRING_LEN 512
+
+/* ngIplu' {Ticky.c}vo' */
+#define INTAVG(a,b) ((b == 0) ? 0.0 : ((double) (a) / (double) (b)))
+#define PC(a) (100.0 * a)
+
+#define AVG(thing) \
+ StgDouble avg##thing = INTAVG(tot##thing,ctr##thing)
+
+
+#if 0
+void
+set_foo_time(double *x) {
+ *x = usertime();
+}
+
+double
+get_foo_time(double x) {
+ fprintf(stderr, "get_foo_time: %7.2f (%7.5f,%7.5f) \n",
+ usertime()-x,usertime(),x);
+ return (usertime()-x);
+}
+#endif
+
+static double start_time_GA = 0.0;
+static double start_mark = 0.0;
+static double start_pack = 0.0;
+static double start_unpack = 0.0;
+
+void
+par_ticky_Par_start (void) {
+# if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS || defined(_WIN32)
+ fprintf(stderr, "|| sorry don't have RUSAGE\n");
+ return ;
+# else
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+ struct rusage t;
+ double utime, stime;
+
+ if (RtsFlags.GcFlags.giveStats>1 && sf != NULL) {
+ getrusage(RUSAGE_SELF, &t);
+
+ utime = t.ru_utime.tv_sec + 1e-6*t.ru_utime.tv_usec;
+ stime = t.ru_stime.tv_sec + 1e-6*t.ru_stime.tv_usec;
+
+ fprintf(stderr, "|| user time: %5.2f; system time: %5.2f\n",
+ utime, stime);
+ fprintf(stderr, "|| max RSS: %ld; int SM size: %ld; int USM data size: %ld; int USS size: %ld\n",
+ t.ru_maxrss, t.ru_ixrss, t.ru_idrss, t.ru_isrss);
+ }
+#endif
+}
+
+#if 0
+FYI:
+ struct rusage
+ {
+ struct timeval ru_utime; /* user time used */
+ struct timeval ru_stime; /* system time used */
+ long ru_maxrss; /* maximum resident set size */
+ long ru_ixrss; /* integral shared memory size */
+ long ru_idrss; /* integral unshared data size */
+ long ru_isrss; /* integral unshared stack size */
+ long ru_minflt; /* page reclaims */
+ long ru_majflt; /* page faults */
+ long ru_nswap; /* swaps */
+ long ru_inblock; /* block input operations */
+ long ru_oublock; /* block output operations */
+ long ru_msgsnd; /* messages sent */
+ long ru_msgrcv; /* messages received */
+ long ru_nsignals; /* signals received */
+ long ru_nvcsw; /* voluntary context switches */
+ long ru_nivcsw; /* involuntary context switches */
+ };
+#endif
+
+
+void
+par_ticky_rebuildGAtables_start(void) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ //set_foo_time(&start_time_GA);
+ start_time_GA = usertime();
+ }
+}
+
+void
+par_ticky_rebuildGAtables_end(nat n, nat size_GA) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ static double foo = 0.0;
+ foo = usertime() - start_time_GA; // get_foo_time(start_time_GA);
+ globalParStats.cnt_rebuild_GA++;
+ globalParStats.tot_rebuild_GA += n;
+ if ( n > globalParStats.res_rebuild_GA )
+ globalParStats.res_rebuild_GA = n;
+ // fprintf(stderr, "rebuildGAtables: footime=%7.2f (%11.5f, %11.5f)\n",
+ // foo, usertime(), start_time_GA);
+ globalParStats.time_rebuild_GA += foo;
+ globalParStats.tot_size_GA += size_GA;
+ if ( size_GA > globalParStats.res_size_GA )
+ globalParStats.res_size_GA = size_GA;
+ }
+ // fprintf(stderr, ">> n: %d; size: %d;; tot: %d; res: %d\n",
+ // n, size_GA, globalParStats.tot_size_GA, globalParStats.res_size_GA);
+}
+
+void
+par_ticky_markLocalGAs_start(void) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ start_time_GA = usertime();
+ }
+}
+
+void
+par_ticky_markLocalGAs_end(nat n) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.cnt_mark_GA++;
+ globalParStats.tot_mark_GA += n;
+ if ( n > globalParStats.res_mark_GA )
+ globalParStats.res_mark_GA = n;
+ globalParStats.time_mark_GA += usertime() - start_time_GA;
+ }
+}
+
+void
+par_ticky_markSparkQueue_start(void) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ start_mark=usertime();
+ }
+}
+
+void
+par_ticky_markSparkQueue_end(nat n) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.time_sparks += usertime() - start_mark;
+
+ globalParStats.tot_sparks_marked += n;
+ if ( n > globalParStats.res_sparks_marked )
+ globalParStats.res_sparks_marked = n;
+ }
+}
+
+void
+par_ticky_PackNearbyGraph_start (void) {
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ start_pack=usertime();
+ }
+}
+
+void
+par_ticky_PackNearbyGraph_end(nat n, nat thunks) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.time_pack += usertime() - start_pack;
+
+ globalParStats.tot_packets++;
+ globalParStats.tot_packet_size += n;
+ if ( n > globalParStats.res_packet_size )
+ globalParStats.res_packet_size = n;
+ globalParStats.tot_thunks += thunks;
+ if ( thunks > globalParStats.res_thunks )
+ globalParStats.res_thunks = thunks;
+ }
+}
+
+void
+par_ticky_UnpackGraph_start (void) {
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ start_unpack=usertime();
+ }
+}
+
+void
+par_ticky_UnpackGraph_end(nat n, nat thunks) {
+ // collect parallel global statistics (currently done together with GC stats)
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ globalParStats.time_unpack += usertime() - start_unpack;
+
+ globalParStats.rec_packets++;
+ globalParStats.rec_packet_size += n;
+ /*
+ if ( n > globalParStats.res_packet_size )
+ globalParStats.res_packet_size = n;
+ */
+ globalParStats.rec_thunks += thunks;
+ /*
+ if ( thunks > globalParStats.res_thunks )
+ globalParStats.res_thunks = thunks;
+ */
+ }
+}
+
+void
+par_ticky_TP (void) {
+ StgSparkPool *pool;
+ nat tp_size, sp_size; // stats only
+
+ // Global stats gathering
+ /* the spark pool for the current PE */
+ pool = &(MainRegTable.rSparks); // generalise to cap = &MainRegTable
+
+ // Global statistics: residency of thread and spark pool
+ if (RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS) {
+ tp_size = run_queue_len() + 1; // add the TSO just poped
+ // No: there may be many blocked threads being awoken at the same time
+ // ASSERT(tp_size <= RtsFlags.ParFlags.maxThreads);
+ globalParStats.tot_tp += tp_size;
+ globalParStats.emp_tp += (tp_size==0) ? 1 : 0;
+ globalParStats.cnt_tp++;
+ if ( tp_size > globalParStats.res_tp)
+ globalParStats.res_tp = tp_size;
+ // fprintf(stderr, "run_queue_len() = %d (max %d)\n", run_queue_len(), globalParStats.res_tp);
+ sp_size = spark_queue_len(pool);
+ //ASSERT(sp_size <= RtsFlags.ParFlags.maxLocalSparks);
+ globalParStats.tot_sp += sp_size;
+ globalParStats.emp_sp += (sp_size==0) ? 1 : 0;
+ globalParStats.cnt_sp++;
+ if ( sp_size > globalParStats.res_sp)
+ globalParStats.res_sp = sp_size;
+ // fprintf(stderr, "spark_queue_len(pool) = %d (max %d)\n", spark_queue_len(pool), globalParStats.res_sp);
+ }
+}
+
+void
+globalParStat_exit(void)
+{
+ FILE *sf = RtsFlags.GcFlags.statsFile;
+ double time, etime;
+
+ /* print only if GC stats is enabled, too; i.e. -sstderr */
+ if (!(RtsFlags.ParFlags.ParStats.Global &&
+ RtsFlags.GcFlags.giveStats > NO_GC_STATS))
+ return;
+
+ time = usertime();
+ etime = elapsedtime() - ElapsedTimeStart;
+ // fprintf(stderr, "foo=%7.2f\n", time);
+
+ if (sf != NULL){
+ char temp[BIG_STRING_LEN];
+
+ // GC_tot_alloc += alloc;
+ fprintf(sf,"\n");
+
+ fprintf(sf, "%11d threads created\n",
+ globalParStats.tot_threads_created);
+ /*
+ Would need to add a ++ to the par macro to use this
+
+ fprintf(sf, "%11d sparks created\n",
+ globalParStats.tot_sparks_created);
+ fprintf(sf, "%11d sparks ignored\n",
+ globalParStats.tot_sparks_ignored);
+ */
+ ullong_format_string(globalParStats.res_tp, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s thread pool residency", temp);
+ fprintf(sf, " (avg: %3.2f; %d times (%2.2f%%) of %d empty)\n",
+ (double)globalParStats.tot_tp/(double)globalParStats.cnt_tp,
+ globalParStats.emp_tp,
+ globalParStats.emp_tp*100.0/(double)globalParStats.cnt_tp,
+ globalParStats.cnt_tp);
+ ullong_format_string(globalParStats.res_sp, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s spark pool residency", temp);
+
+ fprintf(sf, " (avg: %3.2f; %d times (%2.2f%%) of %d empty)\n",
+ (double)globalParStats.tot_sp/(double)globalParStats.cnt_sp,
+ globalParStats.emp_sp,
+ globalParStats.emp_sp*100.0/(double)globalParStats.cnt_sp,
+ globalParStats.cnt_sp);
+ //ullong_format_string(globalParStats.tot_fishes, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11d messages sent (%d fish, %d fetch, %d resume, %d schedule",
+ globalParStats.tot_fish_mess+globalParStats.tot_fetch_mess+
+ globalParStats.tot_resume_mess+globalParStats.tot_schedule_mess,
+ globalParStats.tot_fish_mess, globalParStats.tot_fetch_mess,
+ globalParStats.tot_resume_mess, globalParStats.tot_schedule_mess);
+#if defined(DIST)
+ fprintf(sf, "%d revals", globalParStats.tot_reval_mess);
+#endif
+ fprintf(sf,")\n");
+ fprintf(sf, "%11d messages received (%d fish, %d fetch, %d resume, %d schedule",
+ globalParStats.rec_fish_mess+globalParStats.rec_fetch_mess+
+ globalParStats.rec_resume_mess+globalParStats.rec_schedule_mess,
+ globalParStats.rec_fish_mess, globalParStats.rec_fetch_mess,
+ globalParStats.rec_resume_mess, globalParStats.rec_schedule_mess);
+#if defined(DIST)
+ fprintf(sf, "%d revals", globalParStats.rec_reval_mess);
+#endif
+ fprintf(sf,")\n\n");
+
+ ullong_format_string(globalParStats.tot_size_GA*sizeof(W_), temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytes of global heap in total ", temp);
+ fprintf(sf, "(%5.2f%% of total allocated heap)\n",
+ globalParStats.tot_size_GA*sizeof(W_)*100.0/(double)GC_tot_alloc*sizeof(W_));
+ ullong_format_string(globalParStats.res_size_GA*sizeof(W_), temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytes global heap residency ", temp);
+ fprintf(sf, "(%5.2f%% of max heap residency)\n",
+ globalParStats.res_size_GA*sizeof(W_)*100.0/(double)MaxResidency*sizeof(W_));
+
+ //ullong_format_string(globalParStats.res_mark_GA, temp, rtsTrue/*commas*/);
+ //fprintf(sf, "%11s GAs residency in GALA table ", temp);
+ // ullong_format_string(globalParStats.tot_mark_GA, temp, rtsTrue/*commas*/);
+ //fprintf(sf, "(avg %5.2f; %d samples)\n",
+ // (double)globalParStats.tot_mark_GA/(double)globalParStats.cnt_mark_GA,
+ // globalParStats.cnt_mark_GA);
+
+ ullong_format_string(globalParStats.local_alloc_GA, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s GAs locally allocated (calls to makeGlobal)\n", temp);
+
+ ullong_format_string(globalParStats.tot_rebuild_GA, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s live GAs in total (after rebuilding tables)\n", temp);
+ ullong_format_string(globalParStats.res_rebuild_GA, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s GAs residency (after rebuilding tables) ", temp);
+ fprintf(sf, "(avg %5.2f; %d samples)\n",
+ (double)globalParStats.tot_rebuild_GA/(double)globalParStats.cnt_rebuild_GA,
+ globalParStats.cnt_rebuild_GA);
+ ullong_format_string(globalParStats.res_free_GA, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s residency of freeing GAs", temp);
+ fprintf(sf, " (avg %5.2f; %d samples)\n",
+ (double)globalParStats.tot_free_GA/(double)globalParStats.cnt_free_GA,
+ globalParStats.cnt_free_GA);
+
+ fprintf(sf, "%11.2fs spent marking GAs (%7.2f%% of %7.2fs)\n",
+ globalParStats.time_mark_GA,
+ globalParStats.time_mark_GA*100./time, time);
+ fprintf(sf, "%11.2fs spent rebuilding GALA tables (%7.2f%% of %7.2fs; %7.2f%% of %7.2fs)\n",
+ globalParStats.time_rebuild_GA,
+ globalParStats.time_rebuild_GA*100./time, time,
+ globalParStats.time_rebuild_GA*100./etime, etime);
+
+ ullong_format_string(globalParStats.tot_sparks_marked, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s sparks marked\t", temp);
+ ullong_format_string(globalParStats.res_sparks_marked, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%6s spark mark residency\n", temp);
+ fprintf(sf, "%11.2fs spent marking sparks (%7.2f%% of %7.2fs; %7.2f%% of %7.2fs elapsed)\n",
+ globalParStats.time_sparks,
+ globalParStats.time_sparks*100./time, time,
+ globalParStats.time_sparks*100./etime, etime);
+
+ fprintf(sf,"\n");
+
+ ullong_format_string(globalParStats.tot_packets, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s packets sent\n", temp);
+ ullong_format_string(globalParStats.tot_packet_size, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytes of graph sent in total (max %d; avg %.2f)\n",
+ temp, globalParStats.res_packet_size,
+ (double)globalParStats.tot_packet_size/(double)globalParStats.tot_packets);
+ ullong_format_string(globalParStats.tot_thunks, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s thunks sent in total (max %d; avg %.2f)\n",
+ temp, globalParStats.res_thunks,
+ (double)globalParStats.tot_thunks/(double)globalParStats.tot_packets);
+ fprintf(sf, "%11.2fs spent packing graph structures (%7.2f%% of %7.2fs; %7.2f%% of %7.2fs elapsed)\n",
+ globalParStats.time_pack,
+ globalParStats.time_pack*100./time, time,
+ globalParStats.time_pack*100./etime, etime);
+
+ ullong_format_string(globalParStats.rec_packets, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s packets received\n", temp);
+ ullong_format_string(globalParStats.rec_packet_size, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytes of graph received in total (max %d; avg %.2f)\n",
+ temp, globalParStats.rec_res_packet_size,
+ (double)globalParStats.rec_packet_size/(double)globalParStats.rec_packets);
+ ullong_format_string(globalParStats.rec_thunks, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s thunks received in total (max %d; avg %.2f)\n",
+ temp, globalParStats.rec_res_thunks,
+ (double)globalParStats.rec_thunks/(double)globalParStats.rec_packets);
+ fprintf(sf, "%11.2fs spent unpacking graph structures (%7.2f%% of %7.2fs; %7.2f%% of %7.2fs elapsed)\n",
+ globalParStats.time_unpack,
+ globalParStats.time_unpack*100./time, time,
+ globalParStats.time_unpack*100./etime, etime);
+
+ fprintf(sf,"\n");
+
+ ullong_format_string(globalParStats.tot_arrs, temp, rtsTrue/*commas*/);
+ fprintf(sf, "%11s bytearrays sent; ", temp);
+ ullong_format_string(globalParStats.tot_arr_size, temp, rtsTrue/*commas*/);
+ fprintf(sf, " %s bytes in total (avg %.2f)\n",
+ temp,
+ (double)globalParStats.tot_arr_size/(double)globalParStats.tot_arrs);
+
+ fprintf(sf,"\n");
+
+ fprintf(sf, "%11d yields, %d stack overflows, %d heap overflows\n",
+ globalParStats.tot_yields, globalParStats.tot_stackover,
+ globalParStats.tot_heapover);
+
+ fprintf(sf,"\n");
+
+ //fprintf(stderr, "Printing this pathetic statistics took %7.2fs (start @ %7.2f)\n",
+ // usertime()-time, time);
+
+ fflush(sf);
+ // Open filehandle needed by other stats printing fcts
+ // fclose(sf);
+ }
+}
+
+#endif
+
--- /dev/null
+/* --------------------------------------------------------------------------
+ * $Id: ParTicky.h,v 1.1 2001/03/22 03:51:11 hwloidl Exp $
+ *
+ * (c) Hans-Wolfgang Loidl, 2000-
+ *
+ * Header for ParTicky.c
+ *
+ * --------------------------------------------------------------------------*/
+
+#if defined(PAR_TICKY)
+
+/* macros */
+#define PAR_TICKY_PAR_START() par_ticky_Par_start ()
+#define PAR_TICKY_PAR_END() globalParStat_exit ()
+#define PAR_TICKY_REBUILD_GA_TABLES_START() par_ticky_rebuildGAtables_start()
+#define PAR_TICKY_REBUILD_GA_TABLES_END(n, size_GA) par_ticky_rebuildGAtables_end(n, size_GA)
+#define PAR_TICKY_MARK_LOCAL_GAS_START() par_ticky_markLocalGAs_start()
+#define PAR_TICKY_MARK_LOCAL_GAS_END(n) par_ticky_markLocalGAs_end(n)
+#define PAR_TICKY_MARK_SPARK_QUEUE_START() par_ticky_markSparkQueue_start()
+#define PAR_TICKY_MARK_SPARK_QUEUE_END(n) par_ticky_markSparkQueue_end(n)
+#define PAR_TICKY_PACK_NEARBY_GRAPH_START() (par_ticky_PackNearbyGraph_start())
+#define PAR_TICKY_PACK_NEARBY_GRAPH_END(n, thunks) par_ticky_PackNearbyGraph_end(n, thunks)
+#define PAR_TICKY_UNPACK_GRAPH_START() par_ticky_UnpackGraph_start()
+#define PAR_TICKY_UNPACK_GRAPH_END(n,thunks) par_ticky_UnpackGraph_end(n,thunks)
+#define PAR_TICKY_TP() par_ticky_TP()
+#define PAR_TICKY_CNT_FREE_GA() stats_CntFreeGA()
+
+/* prototypes */
+extern void par_ticky_Par_start (void) ;
+extern void par_ticky_rebuildGAtables_start(void) ;
+extern void par_ticky_rebuildGAtables_end(nat n, nat size_GA) ;
+extern void par_ticky_markLocalGAs_start(void) ;
+extern void par_ticky_markLocalGAs_end(nat n) ;
+extern void par_ticky_markSparkQueue_start(void) ;
+extern void par_ticky_markSparkQueue_end(nat n) ;
+extern void par_ticky_PackNearbyGraph_start (void) ;
+extern void par_ticky_PackNearbyGraph_end(nat n, nat thunks) ;
+extern void par_ticky_UnpackGraph_start (void) ;
+extern void par_ticky_UnpackGraph_end(nat n, nat thunks) ;
+extern void par_ticky_TP (void) ;
+extern void globalParStat_exit(void);
+
+#else
+
+#define PAR_TICKY_PAR_START()
+#define PAR_TICKY_PAR_END()
+#define PAR_TICKY_REBUILD_GA_TABLES_START()
+#define PAR_TICKY_REBUILD_GA_TABLES_END(n, size_GA)
+#define PAR_TICKY_MARK_LOCAL_GAS_START()
+#define PAR_TICKY_MARK_LOCAL_GAS_END(n)
+#define PAR_TICKY_MARK_SPARK_QUEUE_START()
+#define PAR_TICKY_MARK_SPARK_QUEUE_END(n)
+#define PAR_TICKY_PACK_NEARBY_GRAPH_START ()
+#define PAR_TICKY_PACK_NEARBY_GRAPH_END(n, thunks)
+#define PAR_TICKY_UNPACK_GRAPH_START ()
+#define PAR_TICKY_UNPACK_GRAPH_END(n, thunks)
+#define PAR_TICKY_TP ()
+#define PAR_TICKY_CNT_FREE_GA()
+
+#endif
+
/*
- Time-stamp: <Thu Mar 23 2000 18:20:17 Stardate: [-30]4548.82 hwloidl>
+ Time-stamp: <Wed Mar 21 2001 16:42:40 Stardate: [-30]6363.48 hwloidl>
Basic functions for use in either GranSim or GUM.
*/
//* Includes::
//* Variables and constants::
//* Writing to the log-file::
+//* Global statistics::
//* Dumping routines::
//@end menu
+//*/ fool highlight
//@node Includes, Variables and constants
//@subsection Includes
#include "Rts.h"
#include "RtsFlags.h"
#include "RtsUtils.h"
+#include "Storage.h"
#include "GranSimRts.h"
#include "ParallelRts.h"
FILE *gr_file = NULL;
char gr_filename[STATS_FILENAME_MAXLEN];
-//@node Writing to the log-file, Dumping routines, Variables and constants
+#if defined(PAR)
+/* Global statistics */
+GlobalParStats globalParStats;
+#endif
+
+#if defined(PAR) && !defined(DEBUG)
+// HAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACCCCCCCCCKKKKKKKKKKKK
+// Definitely the wrong place for info_type in !DEBUG (see Printer.c) -- HWL
+
+static char *closure_type_names[] = {
+ "INVALID_OBJECT", /* 0 */
+ "CONSTR", /* 1 */
+ "CONSTR_1_0", /* 2 */
+ "CONSTR_0_1", /* 3 */
+ "CONSTR_2_0", /* 4 */
+ "CONSTR_1_1", /* 5 */
+ "CONSTR_0_2", /* 6 */
+ "CONSTR_INTLIKE", /* 7 */
+ "CONSTR_CHARLIKE", /* 8 */
+ "CONSTR_STATIC", /* 9 */
+ "CONSTR_NOCAF_STATIC", /* 10 */
+ "FUN", /* 11 */
+ "FUN_1_0", /* 12 */
+ "FUN_0_1", /* 13 */
+ "FUN_2_0", /* 14 */
+ "FUN_1_1", /* 15 */
+ "FUN_0_2", /* 16 */
+ "FUN_STATIC", /* 17 */
+ "THUNK", /* 18 */
+ "THUNK_1_0", /* 19 */
+ "THUNK_0_1", /* 20 */
+ "THUNK_2_0", /* 21 */
+ "THUNK_1_1", /* 22 */
+ "THUNK_0_2", /* 23 */
+ "THUNK_STATIC", /* 24 */
+ "THUNK_SELECTOR", /* 25 */
+ "BCO", /* 26 */
+ "AP_UPD", /* 27 */
+ "PAP", /* 28 */
+ "IND", /* 29 */
+ "IND_OLDGEN", /* 30 */
+ "IND_PERM", /* 31 */
+ "IND_OLDGEN_PERM", /* 32 */
+ "IND_STATIC", /* 33 */
+ "CAF_UNENTERED", /* 34 */
+ "CAF_ENTERED", /* 35 */
+ "CAF_BLACKHOLE", /* 36 */
+ "RET_BCO", /* 37 */
+ "RET_SMALL", /* 38 */
+ "RET_VEC_SMALL", /* 39 */
+ "RET_BIG", /* 40 */
+ "RET_VEC_BIG", /* 41 */
+ "RET_DYN", /* 42 */
+ "UPDATE_FRAME", /* 43 */
+ "CATCH_FRAME", /* 44 */
+ "STOP_FRAME", /* 45 */
+ "SEQ_FRAME", /* 46 */
+ "BLACKHOLE", /* 47 */
+ "BLACKHOLE_BQ", /* 48 */
+ "SE_BLACKHOLE", /* 49 */
+ "SE_CAF_BLACKHOLE", /* 50 */
+ "MVAR", /* 51 */
+ "ARR_WORDS", /* 52 */
+ "MUT_ARR_PTRS", /* 53 */
+ "MUT_ARR_PTRS_FROZEN", /* 54 */
+ "MUT_VAR", /* 55 */
+ "WEAK", /* 56 */
+ "FOREIGN", /* 57 */
+ "STABLE_NAME", /* 58 */
+ "TSO", /* 59 */
+ "BLOCKED_FETCH", /* 60 */
+ "FETCH_ME", /* 61 */
+ "FETCH_ME_BQ", /* 62 */
+ "RBH", /* 63 */
+ "EVACUATED", /* 64 */
+ "REMOTE_REF", /* 65 */
+ "N_CLOSURE_TYPES" /* 66 */
+};
+
+char *
+info_type(StgClosure *closure){
+ return closure_type_names[get_itbl(closure)->type];
+}
+
+char *
+info_type_by_ip(StgInfoTable *ip){
+ return closure_type_names[ip->type];
+}
+
+void
+info_hdr_type(StgClosure *closure, char *res){
+ strcpy(res,closure_type_names[get_itbl(closure)->type]);
+}
+#endif
+
+//@node Writing to the log-file, Global statistics, Variables and constants
//@subsection Writing to the log-file
/*
Writing to the log-file
gr_filename);
}
- setbuf(gr_file, NULL); // for debugging turn buffering off
+ setbuf(gr_file, NULL); /* turn buffering off */
/* write header with program name, options and setup to gr_file */
fputs("Granularity Simulation for ", gr_file);
#elif defined(PAR)
+void init_gr_stats (void);
+
void
init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv)
char *prog_argv[], *rts_argv[];
if (!RtsFlags.ParFlags.ParStats.Full)
return;
+ if (RtsFlags.ParFlags.ParStats.Global)
+ init_gr_stats();
+
if ((gr_file = fopen(gr_filename, "w")) == NULL)
barf("Can't open activity report file %s\n", gr_filename);
- setbuf(gr_file, NULL); // for debugging turn buffering off
+ setbuf(gr_file, NULL); /* turn buffering off */
/* write header with program name, options and setup to gr_file */
for (i = 0; i < prog_argc; ++i) {
fputs("Start-Time: ", gr_file);
fputs(time_str(), gr_file);
fputc('\n', gr_file);
-
+
+ ASSERT(startTime==0);
+ // startTime = msTime();
startTime = CURRENT_TIME;
ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
fprintf(gr_file, "PE %2u [%s]: TIME\n", thisPE, time_string);
return;
}
+
+void
+init_gr_stats (void) {
+ // memset(&globalParStats, '\0', sizeof(GlobalParStats));
+
+ globalParStats.tot_mark_GA = globalParStats.tot_rebuild_GA = globalParStats.tot_free_GA = globalParStats.res_mark_GA = globalParStats.res_rebuild_GA = globalParStats.res_free_GA = globalParStats.tot_size_GA = globalParStats.res_size_GA = globalParStats.tot_global = globalParStats.tot_local = 0;
+ globalParStats.cnt_mark_GA = globalParStats.cnt_rebuild_GA = globalParStats.cnt_free_GA = globalParStats.res_free_GA = globalParStats.local_alloc_GA = 0;
+
+ globalParStats.time_mark_GA = 0.0;
+ globalParStats.time_rebuild_GA = 0.0;
+ globalParStats.time_sparks = 0.0;
+ globalParStats.time_pack = 0.0;
+
+ globalParStats.res_sp = globalParStats.res_tp = globalParStats.tot_sp = globalParStats.tot_tp = globalParStats.cnt_sp = globalParStats.cnt_tp = globalParStats.emp_sp = globalParStats.emp_tp = 0;
+ globalParStats.tot_packets = globalParStats.tot_packet_size = globalParStats.tot_thunks = globalParStats.res_packet_size = globalParStats.res_thunks = globalParStats.rec_res_packet_size = globalParStats.rec_res_thunks = 0;
+
+ globalParStats.tot_fish_mess = globalParStats.tot_fetch_mess = globalParStats.tot_resume_mess = globalParStats.tot_schedule_mess = 0;
+ globalParStats.rec_fish_mess = globalParStats.rec_resume_mess = globalParStats.rec_schedule_mess = 0;
+ globalParStats.rec_fetch_mess = 0;
+#if defined(DIST)
+ globalParStats.tot_reval_mess = 0;
+ globalParStats.rec_reval_mess = 0;
+#endif
+
+ globalParStats.tot_threads_created = globalParStats.tot_sparks_created = globalParStats.tot_sparks_ignored = globalParStats.tot_sparks_marked = globalParStats.res_sparks_created = globalParStats.res_sparks_ignored = globalParStats.res_sparks_marked = 0;
+ globalParStats.tot_yields = globalParStats.tot_stackover = globalParStats.tot_heapover = 0;
+
+ globalParStats.tot_arrs = globalParStats.tot_arr_size = 0;
+}
+
#endif /* PAR */
//@cindex end_gr_simulation
}
#endif /* PAR */
-//@node Dumping routines, , Writing to the log-file
+//@node Global statistics, Dumping routines, Writing to the log-file
+//@subsection Global statistics
+/*
+ Called at the end of execution
+*/
+
+//@node Dumping routines, , Global statistics
//@subsection Dumping routines
//@cindex DumpGranEvent
GranEventType name;
StgTSO *tso;
{
- DumpRawGranEvent(CURRENT_PROC, (PEs)0, name, tso, END_TSO_QUEUE, (StgInt)0, (StgInt)0);
+ DumpRawGranEvent(CURRENT_PROC, (PEs)0, name, tso, &stg_END_TSO_QUEUE_closure, (StgInt)0, (StgInt)0);
}
//@cindex DumpRawGranEvent
StgClosure *node;
StgInt sparkname, len;
{
+# if defined(GRAN)
+ DumpVeryRawGranEvent(TIME_ON_PROC(proc),
+ proc, p, name, tso, node, sparkname, len);
+# elif defined(PAR)
+ DumpVeryRawGranEvent(CURRENT_TIME,
+ proc, p, name, tso, node, sparkname, len);
+# endif
+}
+
+//@cindex DumpVeryRawGranEvent
+void
+DumpVeryRawGranEvent(time, proc, p, name, tso, node, sparkname, len)
+rtsTime time;
+PEs proc, p; /* proc ... where it happens; p ... where node lives */
+GranEventType name;
+StgTSO *tso;
+StgClosure *node;
+StgInt sparkname, len;
+{
FILE *output_file; // DEBUGGING ONLY !!!!!!!!!!!!!!!!!!!!!!!!!1
StgWord id;
char time_string[TIME_STR_LEN], node_str[NODE_STR_LEN];
# if defined(GRAN)
- ullong_format_string(TIME_ON_PROC(proc),
+ ullong_format_string(time,
time_string, rtsFalse/*no commas!*/);
# elif defined(PAR)
- ullong_format_string(CURRENT_TIME,
+ ullong_format_string(time,
time_string, rtsFalse/*no commas!*/);
# endif
output_file = gr_file;
+
# if defined(GRAN)
+
if (RtsFlags.GranFlags.GranSimStats.Full)
ASSERT(output_file!=NULL);
- IF_DEBUG(gran,
- fprintf(stderr, "GRAN: Dumping info to file with handle %#x\n", output_file))
-
if (RtsFlags.GranFlags.GranSimStats.Suppressed)
return;
# elif defined(PAR)
+
if (RtsFlags.ParFlags.ParStats.Full)
ASSERT(output_file!=NULL);
+
+ if (RtsFlags.ParFlags.ParStats.Suppressed)
+ return;
+
# endif
id = tso == NULL ? -1 : tso->id;
- if (node==stgCast(StgClosure*,&END_TSO_QUEUE_closure))
+ if (node==stgCast(StgClosure*,&stg_END_TSO_QUEUE_closure))
strcpy(node_str,"________"); /* "END_TSO_QUEUE"); */
else
sprintf(node_str,"0x%-6lx",node);
case GR_BLOCK:
case GR_STOLEN:
case GR_STOLENQ:
+ case GR_STEALING:
fprintf(output_file, "PE %2u [%s]: %-9s\t%lx \t%s\t(from %2u)\n",
proc, time_string, gran_event_names[name],
id,node_str,p);
fprintf(output_file,"PE %2u [%s]: %-9s\t%lx \n",
proc,time_string,gran_event_names[name],id);
break;
- case GR_STEALING:
- fprintf(output_file,"PE %2u [%s]: %-9s\t%lx\t \t(by %2u)\n",
- proc,time_string,gran_event_names[name],id,p);
- break;
case GR_ALLOC:
fprintf(output_file,"PE %2u [%s]: %-9s\t%lx\t \tallocating %u words\n",
proc,time_string,gran_event_names[name],id,len);
* NB: DumpGranEvent cannot be used because PE may be wrong
* (as well as the extra info)
*/
- fprintf(output_file, "PE %2u [%s]: END %lx, SN %u, ST %lu, EXP %c, BB %u, HA %u, RT %u, BT %u (%u), FT %u (%u), LS %u, GS %u, MY %c\n"
+ fprintf(output_file, "PE %2u [%s]: END %lx, SN %u, ST %lu, EXP %s, BB %u, HA %u, RT %u, BT %u (%u), FT %u (%u), LS %u, GS %u, MY %s\n"
,proc
,time_string
,tso->id
#if defined(GRAN)
,tso->gran.sparkname
,tso->gran.startedat
- ,tso->gran.exported ? 'T' : 'F'
+ ,((tso->gran.exported) ? 'T' : 'F')
,tso->gran.basicblocks
,tso->gran.allocs
,tso->gran.exectime
#elif defined(PAR)
,tso->par.sparkname
,tso->par.startedat
- ,tso->par.exported ? 'T' : 'F'
+ ,(tso->par.exported) ? "T" : "F"
,tso->par.basicblocks
,tso->par.allocs
,tso->par.exectime
,tso->par.localsparks
,tso->par.globalsparks
#endif
- ,mandatory_thread ? 'T' : 'F'
+ ,(mandatory_thread ? "T" : "F")
);
}
}
return;
# endif
- DumpGranEvent(GR_TERMINATE, stgCast(StgTSO*,&END_TSO_QUEUE_closure));
+ DumpGranEvent(GR_TERMINATE, stgCast(StgTSO*,&stg_END_TSO_QUEUE_closure));
if (sizeof(rtsTime) == 4) {
putc('\0', gr_file);
#endif
return info;
+#ifdef DIST
+ case REMOTE_REF: //same as for FETCH_ME...
+ *size = sizeofW(StgFetchMe);
+ *ptrs = (nat)0;
+ *nonptrs = (nat)0;
+ *vhs = *size - *ptrs - *nonptrs - sizeofW(StgHeader);
+#if 0 /* DEBUG */
+ info_hdr_type(node, info_hdr_ty);
+#else
+ strcpy(info_hdr_ty, "REMOTE_REF");
+#endif
+ return info;
+#endif DIST
+
case FETCH_ME_BQ:
*size = sizeofW(StgFetchMeBlockingQueue);
*ptrs = (nat)0;
/*
- Time-stamp: <Mon Mar 20 2000 19:27:38 Stardate: [-30]4534.05 hwloidl>
+ Time-stamp: <Sun Mar 18 2001 19:32:56 Stardate: [-30]6349.07 hwloidl>
-Various debugging routines for GranSim and GUM
+ Various debugging routines for GranSim and GUM
*/
-#if defined(GRAN) || defined(PAR) /* whole file */
+#if defined(DEBUG) && (defined(GRAN) || defined(PAR)) /* whole file */
//@node Debugging routines for GranSim and GUM, , ,
//@section Debugging routines for GranSim and GUM
#include "StgMiscClosures.h"
#include "Printer.h"
# if defined(DEBUG)
+# include "Hash.h"
+# include "Storage.h"
# include "ParallelDebug.h"
# endif
//@node Constants and Variables, Closures, Prototypes, Debugging routines for GranSim and GUM
//@subsection Constants and Variables
+static HashTable *tmpClosureTable; // used in GraphFingerPrint and PrintGraph
+
+#if defined(PAR)
+static char finger_print_char[] = {
+ '/', /* INVALID_OBJECT 0 */
+ 'C', /* CONSTR 1 */
+ 'C', /* CONSTR_1_0 2 */
+ 'C', /* CONSTR_0_1 3 */
+ 'C', /* CONSTR_2_0 4 */
+ 'C', /* CONSTR_1_1 5 */
+ 'C', /* CONSTR_0_2 6 */
+ 'I', /* CONSTR_INTLIKE 7 */
+ 'I', /* CONSTR_CHARLIKE 8 */
+ 'S', /* CONSTR_STATIC 9 */
+ 'S', /* CONSTR_NOCAF_STATIC 10 */
+ 'F', /* FUN 11 */
+ 'F', /* FUN_1_0 12 */
+ 'F', /* FUN_0_1 13 */
+ 'F', /* FUN_2_0 14 */
+ 'F', /* FUN_1_1 15 */
+ 'F', /* FUN_0_2 16 */
+ 'S', /* FUN_STATIC 17 */
+ 'T', /* THUNK 18 */
+ 'T', /* THUNK_1_0 19 */
+ 'T', /* THUNK_0_1 20 */
+ 'T', /* THUNK_2_0 21 */
+ 'T', /* THUNK_1_1 22 */
+ 'T', /* THUNK_0_2 23 */
+ 'S', /* THUNK_STATIC 24 */
+ 'E', /* THUNK_SELECTOR 25 */
+ 'b', /* BCO 26 */
+ 'p', /* AP_UPD 27 */
+ 'p', /* PAP 28 */
+ '_', /* IND 29 */
+ '_', /* IND_OLDGEN 30 */
+ '_', /* IND_PERM 31 */
+ '_', /* IND_OLDGEN_PERM 32 */
+ '_', /* IND_STATIC 33 */
+ '?', /* ***unused*** 34 */
+ '?', /* ***unused*** 35 */
+ '^', /* RET_BCO 36 */
+ '^', /* RET_SMALL 37 */
+ '^', /* RET_VEC_SMALL 38 */
+ '^', /* RET_BIG 39 */
+ '^', /* RET_VEC_BIG 40 */
+ '^', /* RET_DYN 41 */
+ '~', /* UPDATE_FRAME 42 */
+ '~', /* CATCH_FRAME 43 */
+ '~', /* STOP_FRAME 44 */
+ '~', /* SEQ_FRAME 45 */
+ 'o', /* CAF_BLACKHOLE 46 */
+ 'o', /* BLACKHOLE 47 */
+ 'o', /* BLACKHOLE_BQ 48 */
+ 'o', /* SE_BLACKHOLE 49 */
+ 'o', /* SE_CAF_BLACKHOLE 50 */
+ 'm', /* MVAR 51 */
+ 'a', /* ARR_WORDS 52 */
+ 'a', /* MUT_ARR_PTRS 53 */
+ 'a', /* MUT_ARR_PTRS_FROZEN 54 */
+ 'q', /* MUT_VAR 55 */
+ 'w', /* WEAK 56 */
+ 'f', /* FOREIGN 57 */
+ 's', /* STABLE_NAME 58 */
+ '@', /* TSO 59 */
+ '#', /* BLOCKED_FETCH 60 */
+ '>', /* FETCH_ME 61 */
+ '>', /* FETCH_ME_BQ 62 */
+ '$', /* RBH 63 */
+ 'v', /* EVACUATED 64 */
+ '>' /* REMOTE_REF 65 */
+ /* ASSERT(there are N_CLOSURE_TYPES (==66) in this arrary) */
+};
+#endif /* PAR */
+
#if defined(GRAN) && defined(GRAN_CHECK)
//@node Closures, Threads, Constants and Variables, Debugging routines for GranSim and GUM
//@subsection Closures
} else {
/* Fixed header */
fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]);
- for (i = 1; i < FIXED_HS; i++)
+ for (i = 1; i < _HS; i++)
fprintf(stderr, " %#lx", node[locn++]);
/* Variable header */
fprintf(stderr,"\n ");
if(i < ptrs)
- fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
+ fprintf(stderr," 0x%lx[P]",*(node+_HS+vhs+i));
else
- fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i));
+ fprintf(stderr," %lu[D]",*(node+_HS+vhs+i));
}
fprintf(stderr, "\n");
}
INFO_PTR(node) |= INFO_MASK;
for(i = 0; i < ptrs; ++i)
- DEBUG_TREE((StgPtr)node[i+vhs+_FHS]);
+ DEBUG_TREE((StgPtr)node[i+vhs+_HS]);
/* Unmark the node */
INFO_PTR(node) &= ~INFO_MASK;
void
PrintGraph(StgClosure *p, int indent_level)
{
+ void PrintGraph_(StgClosure *p, int indent_level);
+
+ ASSERT(tmpClosureTable==NULL);
+
+ /* init hash table */
+ tmpClosureTable = allocHashTable();
+
+ /* now do the real work */
+ PrintGraph_(p, indent_level);
+
+ /* nuke hash table */
+ freeHashTable(tmpClosureTable, NULL);
+ tmpClosureTable = NULL;
+}
+
+/*
+ This is the actual worker functions.
+ All recursive calls should be made to this function.
+*/
+void
+PrintGraph_(StgClosure *p, int indent_level)
+{
StgPtr x, q;
rtsBool printed = rtsFalse;
nat i, j;
const StgInfoTable *info;
+ /* check whether we have met this node already to break cycles */
+ if (lookupHashTable(tmpClosureTable, (StgWord)p)) { // ie. already touched
+ /* indentation */
+ for (j=0; j<indent_level; j++)
+ fputs(" ", stderr);
+
+ fprintf(stderr, "#### cylce to %p", p);
+ return;
+ }
+
+ /* record that we are processing this closure */
+ insertHashTable(tmpClosureTable, (StgWord) p, (void *)rtsTrue/*non-NULL*/);
+
q = p; /* save ptr to object */
/* indentation */
{
StgBCO* bco = stgCast(StgBCO*,p);
nat i;
- fprintf(stderr, "BCO (%p) with %d pointers\n", p, bco->n_ptrs);
+ fprintf(stderr, "BCO (%p)\n", p);
+ /*
for (i = 0; i < bco->n_ptrs; i++) {
// bcoConstCPtr(bco,i) =
- PrintGraph(bcoConstCPtr(bco,i), indent_level+1);
+ PrintGraph_(bcoConstCPtr(bco,i), indent_level+1);
}
+ */
// p += bco_sizeW(bco);
break;
}
// evac_gen = 0;
fprintf(stderr, "MVAR (%p) with 3 pointers (head, tail, value)\n", p);
// (StgClosure *)mvar->head =
- PrintGraph((StgClosure *)mvar->head, indent_level+1);
+ PrintGraph_((StgClosure *)mvar->head, indent_level+1);
// (StgClosure *)mvar->tail =
- PrintGraph((StgClosure *)mvar->tail, indent_level+1);
+ PrintGraph_((StgClosure *)mvar->tail, indent_level+1);
//(StgClosure *)mvar->value =
- PrintGraph((StgClosure *)mvar->value, indent_level+1);
+ PrintGraph_((StgClosure *)mvar->value, indent_level+1);
// p += sizeofW(StgMVar);
// evac_gen = saved_evac_gen;
break;
printed = rtsTrue;
}
// ((StgClosure *)p)->payload[0] =
- PrintGraph(((StgClosure *)p)->payload[0],
+ PrintGraph_(((StgClosure *)p)->payload[0],
indent_level+1);
// ((StgClosure *)p)->payload[1] =
- PrintGraph(((StgClosure *)p)->payload[1],
+ PrintGraph_(((StgClosure *)p)->payload[1],
indent_level+1);
// p += sizeofW(StgHeader) + 2;
break;
// scavenge_srt(info);
fprintf(stderr, "THUNK_1_0 (%p) with 1 pointer\n", p);
// ((StgClosure *)p)->payload[0] =
- PrintGraph(((StgClosure *)p)->payload[0],
+ PrintGraph_(((StgClosure *)p)->payload[0],
indent_level+1);
// p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
break;
printed = rtsTrue;
}
// ((StgClosure *)p)->payload[0] =
- PrintGraph(((StgClosure *)p)->payload[0],
+ PrintGraph_(((StgClosure *)p)->payload[0],
indent_level+1);
// p += sizeofW(StgHeader) + 1;
break;
printed = rtsTrue;
}
// ((StgClosure *)p)->payload[0] =
- PrintGraph(((StgClosure *)p)->payload[0],
+ PrintGraph_(((StgClosure *)p)->payload[0],
indent_level+1);
// p += sizeofW(StgHeader) + 2;
break;
}
/* basically same as loop in STABLE_NAME case */
for (i=0; i<info->layout.payload.ptrs; i++)
- PrintGraph(((StgClosure *)p)->payload[i],
+ PrintGraph_(((StgClosure *)p)->payload[i],
indent_level+1);
break;
/* NOT fall through */
end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
// (StgClosure *)*p =
- //PrintGraph((StgClosure *)*p, indent_level+1);
+ //PrintGraph_((StgClosure *)*p, indent_level+1);
fprintf(stderr, ", %p", *p);
}
//fputs("\n", stderr);
printed = rtsTrue;
}
// ((StgIndOldGen *)p)->indirectee =
- PrintGraph(((StgIndOldGen *)p)->indirectee,
+ PrintGraph_(((StgIndOldGen *)p)->indirectee,
indent_level+1);
//if (failed_to_evac) {
// failed_to_evac = rtsFalse;
// p += sizeofW(StgIndOldGen);
break;
- case CAF_UNENTERED:
- {
- StgCAF *caf = (StgCAF *)p;
-
- fprintf(stderr, "CAF_UNENTERED (%p) pointing to %p\n", p, caf->body);
- PrintGraph(caf->body, indent_level+1);
- //if (failed_to_evac) {
- // failed_to_evac = rtsFalse;
- // recordOldToNewPtrs((StgMutClosure *)p);
- //} else {
- // caf->mut_link = NULL;
- //}
- //p += sizeofW(StgCAF);
- break;
- }
-
- case CAF_ENTERED:
- {
- StgCAF *caf = (StgCAF *)p;
-
- fprintf(stderr, "CAF_ENTERED (%p) pointing to %p and %p\n",
- p, caf->body, caf->value);
- // caf->body =
- PrintGraph(caf->body, indent_level+1);
- //caf->value =
- PrintGraph(caf->value, indent_level+1);
- //if (failed_to_evac) {
- // failed_to_evac = rtsFalse;
- // recordOldToNewPtrs((StgMutClosure *)p);
- //} else {
- // caf->mut_link = NULL;
- //}
- //p += sizeofW(StgCAF);
- break;
- }
-
case MUT_VAR:
/* ignore MUT_CONSs */
fprintf(stderr, "MUT_VAR (%p) pointing to %p\n", p, ((StgMutVar *)p)->var);
- if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
+ if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
//evac_gen = 0;
- PrintGraph(((StgMutVar *)p)->var, indent_level+1);
+ PrintGraph_(((StgMutVar *)p)->var, indent_level+1);
//evac_gen = saved_evac_gen;
}
//p += sizeofW(StgMutVar);
// (StgClosure *)bh->blocking_queue =
fprintf(stderr, "BLACKHOLE_BQ (%p) pointing to %p\n",
p, (StgClosure *)bh->blocking_queue);
- PrintGraph((StgClosure *)bh->blocking_queue, indent_level+1);
+ PrintGraph_((StgClosure *)bh->blocking_queue, indent_level+1);
//if (failed_to_evac) {
// failed_to_evac = rtsFalse;
// recordMutable((StgMutClosure *)bh);
StgSelector *s = (StgSelector *)p;
fprintf(stderr, "THUNK_SELECTOR (%p) pointing to %p\n",
p, s->selectee);
- PrintGraph(s->selectee, indent_level+1);
+ PrintGraph_(s->selectee, indent_level+1);
// p += THUNK_SELECTOR_sizeW();
break;
}
case IND:
fprintf(stderr, "IND (%p) pointing to %p\n", p, ((StgInd*)p)->indirectee);
- PrintGraph(((StgInd*)p)->indirectee, indent_level+1);
+ PrintGraph_(((StgInd*)p)->indirectee, indent_level+1);
break;
case IND_OLDGEN:
fprintf(stderr, "IND_OLDGEN (%p) pointing to %p\n",
p, ((StgIndOldGen*)p)->indirectee);
- PrintGraph(((StgIndOldGen*)p)->indirectee, indent_level+1);
+ PrintGraph_(((StgIndOldGen*)p)->indirectee, indent_level+1);
break;
case CONSTR_INTLIKE:
fprintf(stderr, "AP_UPD (%p) with 0 pointers\n", p);
case PAP:
/* Treat a PAP just like a section of stack, not forgetting to
- * PrintGraph the function pointer too...
+ * PrintGraph_ the function pointer too...
*/
{
StgPAP* pap = stgCast(StgPAP*,p);
fprintf(stderr, "PAP (%p) pointing to %p\n", p, pap->fun);
// pap->fun =
- //PrintGraph(pap->fun, indent_level+1);
+ //PrintGraph_(pap->fun, indent_level+1);
//scavenge_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
//p += pap_sizeW(pap);
break;
next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
// (StgClosure *)*p =
- // PrintGraph((StgClosure *)*p, indent_level+1);
+ // PrintGraph_((StgClosure *)*p, indent_level+1);
fprintf(stderr, ", %p", *p);
}
fputs("\n", stderr);
next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
// (StgClosure *)*p =
- // PrintGraph((StgClosure *)*p, indent_level+1);
+ // PrintGraph_((StgClosure *)*p, indent_level+1);
fprintf(stderr, ", %p", *p);
}
fputs("\n", stderr);
// evac_gen = 0;
/* chase the link field for any TSOs on the same queue */
// (StgClosure *)tso->link =
- PrintGraph((StgClosure *)tso->link, indent_level+1);
+ PrintGraph_((StgClosure *)tso->link, indent_level+1);
//if (tso->blocked_on) {
- // tso->blocked_on = PrintGraph(tso->blocked_on);
+ // tso->blocked_on = PrintGraph_(tso->blocked_on);
//}
/* scavenge this thread's stack */
//scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
p, ((StgFetchMeBlockingQueue *)p)->blocking_queue);
break;
#endif
+
+#ifdef DIST
+ case REMOTE_REF:
+ fprintf(stderr, "REMOTE_REF (%p) with 0 pointers\n", p);
+ break;
+#endif
+
case EVACUATED:
fprintf(stderr, "EVACUATED (%p) with 0 pointers (evacuee=%p)\n",
p, ((StgEvacuated *)p)->evacuee);
break;
default:
- barf("PrintGraph: unknown closure %d (%s)",
+ barf("PrintGraph_: unknown closure %d (%s)",
info -> type, info_type(info));
}
//}
}
+# if defined(PAR)
+/*
+ Generate a finger-print for a graph.
+ A finger-print is a string, with each char representing one node;
+ depth-first traversal
+*/
+
+void
+GraphFingerPrint(StgClosure *p, char *finger_print)
+{
+ void GraphFingerPrint_(StgClosure *p, char *finger_print);
+
+ ASSERT(tmpClosureTable==NULL);
+ ASSERT(strlen(finger_print)==0);
+
+ /* init hash table */
+ tmpClosureTable = allocHashTable();
+
+ /* now do the real work */
+ GraphFingerPrint_(p, finger_print);
+
+ /* nuke hash table */
+ freeHashTable(tmpClosureTable, NULL);
+ tmpClosureTable = NULL;
+}
+
+/*
+ This is the actual worker functions.
+ All recursive calls should be made to this function.
+*/
+void
+GraphFingerPrint_(StgClosure *p, char *finger_print)
+{
+ StgPtr x, q;
+ rtsBool printed = rtsFalse;
+ nat i, j, len;
+ const StgInfoTable *info;
+
+ q = p; /* save ptr to object */
+ len = strlen(finger_print);
+ ASSERT(len<=MAX_FINGER_PRINT_LEN);
+ /* at most 7 chars for this node (I think) */
+ if (len+7>=MAX_FINGER_PRINT_LEN)
+ return;
+
+ /* check whether we have met this node already to break cycles */
+ if (lookupHashTable(tmpClosureTable, (StgWord)p)) { // ie. already touched
+ strcat(finger_print, "#");
+ return;
+ }
+
+ /* record that we are processing this closure */
+ insertHashTable(tmpClosureTable, (StgWord) p, (void *)rtsTrue/*non-NULL*/);
+
+ ASSERT(p!=(StgClosure*)NULL);
+ ASSERT(LOOKS_LIKE_STATIC(p) ||
+ LOOKS_LIKE_GHC_INFO(GET_INFO((StgClosure *)p)) ||
+ IS_HUGS_CONSTR_INFO(GET_INFO((StgClosure *)p)));
+
+ info = get_itbl((StgClosure *)p);
+ // append char for this node
+ finger_print[len] = finger_print_char[info->type]; finger_print[len+1] = '\0';
+ /* the rest of this fct recursively traverses the graph */
+ switch (info -> type) {
+
+ case BCO:
+ {
+ StgBCO* bco = stgCast(StgBCO*,p);
+ nat i;
+ //%% fprintf(stderr, "BCO (%p) with %d pointers\n", p, bco->n_ptrs);
+ /*
+ for (i = 0; i < bco->n_ptrs; i++) {
+ // bcoConstCPtr(bco,i) =
+ GraphFingerPrint_(bcoConstCPtr(bco,i), finger_print);
+ }
+ */
+ // p += bco_sizeW(bco);
+ break;
+ }
+
+ case MVAR:
+ break;
+
+ case THUNK_2_0:
+ case FUN_2_0:
+ case CONSTR_2_0:
+ // append char for this node
+ strcat(finger_print, "22(");
+ GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
+ GraphFingerPrint_(((StgClosure *)p)->payload[1], finger_print);
+ if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
+ strcat(finger_print, ")");
+ break;
+
+ case THUNK_1_0:
+ case FUN_1_0:
+ case CONSTR_1_0:
+ // append char for this node
+ strcat(finger_print, "12(");
+ GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
+ if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
+ strcat(finger_print, ")");
+ break;
+
+ case THUNK_0_1:
+ case FUN_0_1:
+ case CONSTR_0_1:
+ // append char for this node
+ strcat(finger_print, "01");
+ break;
+
+ case THUNK_0_2:
+ case FUN_0_2:
+ case CONSTR_0_2:
+ // append char for this node
+ strcat(finger_print, "02");
+ break;
+
+ case THUNK_1_1:
+ case FUN_1_1:
+ case CONSTR_1_1:
+ // append char for this node
+ strcat(finger_print, "11(");
+ GraphFingerPrint_(((StgClosure *)p)->payload[0], finger_print);
+ if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
+ strcat(finger_print, ")");
+ break;
+
+ case FUN:
+ case THUNK:
+ case CONSTR:
+ /* basically same as loop in STABLE_NAME case */
+ {
+ char str[6];
+ sprintf(str,"%d?(",info->layout.payload.ptrs);
+ strcat(finger_print,str);
+ for (i=0; i<info->layout.payload.ptrs; i++)
+ GraphFingerPrint_(((StgClosure *)p)->payload[i], finger_print);
+ if (strlen(finger_print)+2<MAX_FINGER_PRINT_LEN)
+ strcat(finger_print, ")");
+ }
+ break;
+
+ case WEAK:
+ case FOREIGN:
+ case STABLE_NAME:
+ {
+ StgPtr end;
+ char str[6];
+ sprintf(str,"%d?", info->layout.payload.ptrs);
+ strcat(finger_print,str);
+
+ //end = (StgPtr)((StgClosure *)p)->payload + info->layout.payload.ptrs;
+ //for (p = (StgPtr)((StgClosure *)p)->payload; p < end; p++) {
+ // GraphFingerPrint_((StgClosure *)*p, finger_print);
+ //}
+ break;
+ }
+
+ case IND_PERM:
+ case IND_OLDGEN_PERM:
+ GraphFingerPrint_(((StgIndOldGen *)p)->indirectee, finger_print);
+ break;
+
+ case MUT_VAR:
+ /* ignore MUT_CONSs */
+ if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
+ GraphFingerPrint_(((StgMutVar *)p)->var, finger_print);
+ }
+ break;
+
+ case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
+ case BLACKHOLE:
+ break;
+
+ case BLACKHOLE_BQ:
+ {
+ StgBlockingQueue *bh = (StgBlockingQueue *)p;
+ // GraphFingerPrint_((StgClosure *)bh->blocking_queue, finger_print);
+ break;
+ }
+
+ case THUNK_SELECTOR:
+ {
+ StgSelector *s = (StgSelector *)p;
+ GraphFingerPrint_(s->selectee, finger_print);
+ break;
+ }
+
+ case IND:
+ GraphFingerPrint_(((StgInd*)p)->indirectee, finger_print);
+ break;
+
+ case IND_OLDGEN:
+ GraphFingerPrint_(((StgIndOldGen*)p)->indirectee, finger_print);
+ break;
+
+ case IND_STATIC:
+ GraphFingerPrint_(((StgIndOldGen*)p)->indirectee, finger_print);
+ break;
+
+ case CONSTR_INTLIKE:
+ case CONSTR_CHARLIKE:
+ case CONSTR_STATIC:
+ case CONSTR_NOCAF_STATIC:
+ case THUNK_STATIC:
+ case FUN_STATIC:
+ break;
+
+ case RET_BCO:
+ case RET_SMALL:
+ case RET_VEC_SMALL:
+ case RET_BIG:
+ case RET_VEC_BIG:
+ case RET_DYN:
+ case UPDATE_FRAME:
+ case STOP_FRAME:
+ case CATCH_FRAME:
+ case SEQ_FRAME:
+ break;
+
+ case AP_UPD: /* same as PAPs */
+ case PAP:
+ /* Treat a PAP just like a section of stack, not forgetting to
+ * GraphFingerPrint_ the function pointer too...
+ */
+ {
+ StgPAP* pap = stgCast(StgPAP*,p);
+ char str[6];
+ sprintf(str,"%d",pap->n_args);
+ strcat(finger_print,str);
+ //GraphFingerPrint_(pap->fun, finger_print); // ??
+ break;
+ }
+
+ case ARR_WORDS:
+ {
+ char str[6];
+ sprintf(str,"%d",((StgArrWords*)p)->words);
+ strcat(finger_print,str);
+ }
+ break;
+
+ case MUT_ARR_PTRS:
+ /* follow everything */
+ {
+ char str[6];
+ sprintf(str,"%d",((StgMutArrPtrs*)p)->ptrs);
+ strcat(finger_print,str);
+ }
+ {
+ StgPtr next;
+ //next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ //for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ // GraphFingerPrint_((StgClosure *)*p, finger_print);
+ //}
+ break;
+ }
+
+ case MUT_ARR_PTRS_FROZEN:
+ /* follow everything */
+ {
+ char str[6];
+ sprintf(str,"%d",((StgMutArrPtrs*)p)->ptrs);
+ strcat(finger_print,str);
+ }
+ {
+ StgPtr start = p, next;
+ //next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+ //for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
+ // GraphFingerPrint_((StgClosure *)*p, finger_print);
+ //}
+ break;
+ }
+
+ case TSO:
+ {
+ StgTSO *tso = (StgTSO *)p;
+ char str[6];
+ sprintf(str,"%d",tso->id);
+ strcat(finger_print,str);
+ }
+ //GraphFingerPrint_((StgClosure *)tso->link, indent_level+1);
+ break;
+
+#if defined(GRAN) || defined(PAR)
+ case RBH:
+ {
+ // use this
+ // StgInfoTable *rip = REVERT_INFOPTR(get_itbl(p));
+ }
+ break;
+#endif
+#if defined(PAR)
+ case BLOCKED_FETCH:
+ break;
+ case FETCH_ME:
+ break;
+ case FETCH_ME_BQ:
+ break;
+#endif
+#ifdef DIST
+ case REMOTE_REF:
+ break;
+#endif
+ case EVACUATED:
+ break;
+
+ default:
+ barf("GraphFingerPrint_: unknown closure %d (%s)",
+ info -> type, info_type(info));
+ }
+
+}
+# endif /* PAR */
+
/*
Do a sanity check on the whole graph, down to a recursion level of level.
Same structure as PrintGraph (nona).
{
StgBCO* bco = stgCast(StgBCO*,p);
nat i;
+ /*
for (i = 0; i < bco->n_ptrs; i++) {
checkGraph(bcoConstCPtr(bco,i), rec_level-1);
}
+ */
break;
}
checkGraph(((StgIndOldGen *)p)->indirectee, rec_level-1);
break;
- case CAF_UNENTERED:
- {
- StgCAF *caf = (StgCAF *)p;
-
- fprintf(stderr, "CAF_UNENTERED (%p) pointing to %p\n", p, caf->body);
- checkGraph(caf->body, rec_level-1);
- break;
- }
-
- case CAF_ENTERED:
- {
- StgCAF *caf = (StgCAF *)p;
-
- fprintf(stderr, "CAF_ENTERED (%p) pointing to %p and %p\n",
- p, caf->body, caf->value);
- checkGraph(caf->body, rec_level-1);
- checkGraph(caf->value, rec_level-1);
- break;
- }
-
case MUT_VAR:
/* ignore MUT_CONSs */
- if (((StgMutVar *)p)->header.info != &MUT_CONS_info) {
+ if (((StgMutVar *)p)->header.info != &stg_MUT_CONS_info) {
checkGraph(((StgMutVar *)p)->var, rec_level-1);
}
break;
/*
- Time-stamp: <Tue Mar 14 2000 17:15:59 Stardate: [-30]4503.59 hwloidl>
+ Time-stamp: <Tue Mar 06 2001 00:25:14 Stardate: [-30]6285.08 hwloidl>
Prototypes of all parallel debugging functions.
*/
#ifndef PARALLEL_DEBUG_H
#define PARALLEL_DEBUG_H
-#if defined(GRAN) // || defined(PAR)
+#if defined(DEBUG) && (defined(GRAN) || defined(PAR))
+/* max length of the string holding a finger-print for a graph */
+#define MAX_FINGER_PRINT_LEN 10000
+// (10*RtsFlags.ParFlags.packBufferSize)
+#endif
+
+#if defined(DEBUG) && defined(GRAN)
void G_PRINT_NODE(StgClosure* node);
void G_PPN(StgClosure* node);
void G_INFO_TABLE(StgClosure* node);
void PrintPacket(rtsPackBuffer *buffer);
void PrintGraph(StgClosure *p, int indent_level);
+void GraphFingerPrint(StgClosure *p, char *finger_print);
void checkGraph(StgClosure *p, int rec_level);
void checkPacket(rtsPackBuffer *packBuffer);
#endif /* GRAN || PAR */
+#if defined(PAR)
+
+/* don't want to import Schedule.h and Sanity.h everywhere */
+extern void print_bq (StgClosure *node);
+extern void checkBQ (StgBlockingQueueElement *bqe, StgClosure *closure);
+
+void checkGAGAMap(globalAddr *gagamap, int nGAs);
+extern rtsBool isOnLiveIndTable(globalAddr *ga);
+extern void rebuildGAtables(rtsBool full);
+extern void rebuildLAGAtable(void);
+extern void checkLAGAtable(rtsBool check_closures);
+extern void checkHeapChunk(StgPtr start, StgPtr end);
+extern void printGA (globalAddr *ga);
+extern void printGALA (GALA *gala);
+extern void printLiveIndTable(void);
+extern void printRemoteGATable(void);
+extern void printLAGAtable(void);
+
+#endif
+
#endif /* PARALLEL_DEBUG_H */
/* --------------------------------------------------------------------------
- Time-stamp: <Wed Mar 29 2000 19:10:29 Stardate: [-30]4578.78 hwloidl>
- $Id: ParallelRts.h,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Tue Mar 06 2001 00:25:50 Stardate: [-30]6285.08 hwloidl>
+ $Id: ParallelRts.h,v 1.4 2001/03/22 03:51:12 hwloidl Exp $
Variables and functions specific to the parallel RTS (i.e. GUM or GranSim)
----------------------------------------------------------------------- */
#ifndef PARALLEL_RTS_H
#define PARALLEL_RTS_H
+#include "ParTicky.h"
+
+/* HWL HACK: compile time sanity checks; shouldn't be necessary at all */
+#if defined(PAR) && defined(GRAN)
+# error "Both PAR and GRAN defined"
+#endif
+
+#if defined(DEBUG)
+/* Paranoia debugging: we add an end-of-buffer marker to every pack buffer
+ (only when sanity checking RTS is enabled, of course) */
+#define DEBUG_HEADROOM 1
+#define END_OF_BUFFER_MARKER 0x1111bbbb
+#define GARBAGE_MARKER 0x1111eeee
+#else
+#define DEBUG_HEADROOM 0
+#endif /* DEBUG */
+
#if defined(GRAN) || defined(PAR)
#if defined(GRAN)
/* Pack.c */
rtsPackBuffer *PackNearbyGraph(StgClosure* closure, StgTSO* tso,
- nat *packBufferSize);
+ nat *packBufferSize, GlobalTaskId dest);
rtsPackBuffer *PackOneNode(StgClosure* closure, StgTSO* tso,
nat *packBufferSize);
rtsPackBuffer *PackTSO(StgTSO *tso, nat *packBufferSize);
/* HLComms.c */
rtsFetchReturnCode blockFetch(StgTSO* tso, PEs proc, StgClosure* bh);
-void blockThread(StgTSO *tso);
+void blockThread(StgTSO *tso);
-/* General closure predicates */
-/*
- {Parallel.h}Daq ngoqvam vIroQpu'
+#endif
+#if defined(PAR)
-StgInfoTable *get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs, nat *vhs, char *info_hdr_ty);
-rtsBool IS_BLACK_HOLE(StgClosure* node);
-StgClosure *IS_INDIRECTION(StgClosure* node);
-rtsBool IS_THUNK(StgClosure* closure);
-*/
+/* Statistics info */
+/* global structure for collecting statistics */
+typedef struct GlobalParStats_ {
+ /* GALA and LAGA table info */
+ nat tot_mark_GA, tot_rebuild_GA, tot_free_GA,
+ res_mark_GA, res_rebuild_GA, res_free_GA,
+ cnt_mark_GA, cnt_rebuild_GA, cnt_free_GA,
+ res_size_GA, tot_size_GA, local_alloc_GA, tot_global, tot_local;
+
+ /* time spent managing the GAs */
+ double time_mark_GA, time_rebuild_GA;
+
+ /* spark queue stats */
+ nat res_sp, tot_sp, cnt_sp, emp_sp;
+ // nat tot_sq_len, tot_sq_probes, tot_sparks;
+ /* thread queue stats */
+ nat res_tp, tot_tp, cnt_tp, emp_tp;
+ //nat tot_add_threads, tot_tq_len, non_end_add_threads;
+
+ /* packet statistics */
+ nat tot_packets, tot_packet_size, tot_thunks,
+ res_packet_size, res_thunks,
+ rec_packets, rec_packet_size, rec_thunks,
+ rec_res_packet_size, rec_res_thunks;
+ /* time spent packing stuff */
+ double time_pack, time_unpack;
+
+ /* thread stats */
+ nat tot_threads_created;
+
+ /* spark stats */
+ //nat pruned_sparks, withered_sparks;
+ nat tot_sparks_created, tot_sparks_ignored, tot_sparks_marked,
+ res_sparks_created, res_sparks_ignored, res_sparks_marked; // , sparks_created_on_PE[MAX_PROC];
+ double time_sparks;
+
+ /* scheduling stats */
+ nat tot_yields, tot_stackover, tot_heapover;
+
+ /* message statistics */
+ nat tot_fish_mess, tot_fetch_mess, tot_resume_mess, tot_schedule_mess;
+ nat rec_fish_mess, rec_fetch_mess, rec_resume_mess, rec_schedule_mess;
+#if defined(DIST)
+ nat tot_reval_mess;
+ nat rec_reval_mess;
#endif
-#if defined(PAR)
+
+ /* blocking queue statistics
+ rtsTime tot_bq_processing_time;
+ nat tot_bq_len, tot_bq_len_local, tot_awbq, tot_FMBQs;
+ */
+
+ /* specialised info on arrays (for GPH/Maple mainly) */
+ nat tot_arrs, tot_arr_size;
+} GlobalParStats;
+
+extern GlobalParStats globalParStats;
+
+void globalParStat_exit(void);
/* Pack.c */
+rtsBool InitPackBuffer(void);
rtsPackBuffer *PackNearbyGraph(StgClosure* closure, StgTSO* tso,
- nat *packBufferSize);
+ nat *packBufferSize, GlobalTaskId dest);
/* Unpack.c */
void CommonUp(StgClosure *src, StgClosure *dst);
/* Global.c */
void GALAdeprecate(globalAddr *ga);
-/* General closure predicates */
-/*
- {Parallel.h}Daq ngoqvam vIroQpu'
+/* HLComms.c */
+nat pending_fetches_len(void);
-StgInfoTable *get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs, nat *vhs, char *info_hdr_ty);
-rtsBool IS_BLACK_HOLE(StgClosure* node);
-StgClosure *IS_INDIRECTION(StgClosure* node);
-rtsBool IS_THUNK(StgClosure* closure);
-*/
+/* ParInit.c */
+void initParallelSystem(void);
+void shutdownParallelSystem(StgInt n);
+void synchroniseSystem(void);
+void par_exit(I_);
#endif
/* HLComms.c */
void freeRemoteGA(int pe, globalAddr *ga);
void sendFreeMessages(void);
+void markPendingFetches(rtsBool major_gc);
/* Global.c */
void markLocalGAs(rtsBool full);
//@cindex init_gr_stats
//@cindex init_gr_simulation
//@cindex end_gr_simulation
-void init_gr_stats (void);
-void init_gr_simulation(int rts_argc, char *rts_argv[],
- int prog_argc, char *prog_argv[]);
-void end_gr_simulation(void);
+void init_gr_stats (void);
+void init_gr_simulation(int rts_argc, char *rts_argv[],
+ int prog_argc, char *prog_argv[]);
+void end_gr_simulation(void);
// TODO: move fcts in here (as static inline)
-StgInfoTable* get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs, nat *vhs, char *info_hdr_ty);
-rtsBool IS_BLACK_HOLE(StgClosure* node);
-StgClosure *IS_INDIRECTION(StgClosure* node) ;
-StgClosure *UNWIND_IND (StgClosure *closure);
+StgInfoTable* get_closure_info(StgClosure* node, nat *size, nat *ptrs, nat *nonptrs, nat *vhs, char *info_hdr_ty);
+rtsBool IS_BLACK_HOLE(StgClosure* node);
+StgClosure *IS_INDIRECTION(StgClosure* node) ;
+StgClosure *UNWIND_IND (StgClosure *closure);
#endif /* defined(PAR) || defined(GRAN) */
/*
- Time-stamp: <Mon Mar 13 2000 18:50:36 Stardate: [-30]4498.92 hwloidl>
+ Time-stamp: <Tue Mar 13 2001 19:07:13 Stardate: [-30]6323.98 hwloidl>
Revertible Black Hole Manipulation.
Used in GUM and GranSim during the packing of closures. These black holes
//@node Externs and prototypes, Conversion Functions
//@section Externs and prototypes
-EXTFUN(RBH_Save_0_info);
-EXTFUN(RBH_Save_1_info);
-EXTFUN(RBH_Save_2_info);
+EXTFUN(stg_RBH_Save_0_info);
+EXTFUN(stg_RBH_Save_1_info);
+EXTFUN(stg_RBH_Save_2_info);
//@node Conversion Functions, Index, Externs and prototypes
//@section Conversion Functions
RBH_Save_N closures, with N being the number of pointers for this
closure. */
IF_GRAN_DEBUG(pack,
- belch("*>:: Converting closure %p (%s) into an RBH",
+ belch("*>:: %p (%s): Converting closure into an RBH",
closure, info_type(closure)));
IF_PAR_DEBUG(pack,
- belch("*>:: Converting closure %p (%s) into an RBH",
+ belch("*>:: %p (%s): Converting closure into an RBH",
closure, info_type(closure)));
ASSERT(closure_THUNK(closure));
old_info = get_itbl(closure));
/* Allocate a new closure for the holding data ripped out of closure */
- if ((rbh_save = (StgRBHSave *)allocate(FIXED_HS + 2)) == NULL)
+ if ((rbh_save = (StgRBHSave *)allocate(_HS + 2)) == NULL)
return NULL; /* have to Garbage Collect; check that in the caller! */
info_ptr = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
- ASSERT(size >= MIN_UPD_SIZE);
+ ASSERT(size >= _HS+MIN_UPD_SIZE);
/* Fill in the RBH_Save closure with the original data from closure */
rbh_save->payload[0] = (StgPtr) ((StgRBH *)closure)->blocking_queue;
/* Set the info_ptr for the rbh_Save closure according to the number of
pointers in the original */
- rbh_info_ptr = (StgInfoTable *) (ptrs == 0 ? &RBH_Save_0_info :
- ptrs == 1 ? &RBH_Save_1_info :
- &RBH_Save_2_info);
+ rbh_info_ptr = (StgInfoTable *) (ptrs == 0 ? &stg_RBH_Save_0_info :
+ ptrs == 1 ? &stg_RBH_Save_1_info :
+ &stg_RBH_Save_2_info);
SET_INFO(rbh_save, rbh_info_ptr);
/* same bitmask as the original closure */
SET_GRAN_HDR(rbh_save, PROCS(closure));
# if defined(PAR)
-EXTFUN(FETCH_ME_info);
+EXTFUN(stg_FETCH_ME_info);
//@cindex convertToFetchMe
void
recordMutable((StgMutClosure *)rbh);
/* actually turn it into a FETCH_ME */
- SET_INFO((StgClosure *)rbh, &FETCH_ME_info);
+ SET_INFO((StgClosure *)rbh, &stg_FETCH_ME_info);
/* set the global pointer in the FETCH_ME closure to the given value */
((StgFetchMe *)rbh)->ga = ga;
/* ----------------------------------------------------------------------------
- Time-stamp: <Tue Mar 21 2000 20:25:55 Stardate: [-30]4539.25 hwloidl>
- $Id: SysMan.c,v 1.3 2000/03/31 03:09:37 hwloidl Exp $
+ Time-stamp: <Wed Mar 21 2001 17:16:28 Stardate: [-30]6363.59 hwloidl>
+ $Id: SysMan.c,v 1.4 2001/03/22 03:51:12 hwloidl Exp $
GUM System Manager Program
Handles startup, shutdown and global synchronisation of the parallel system.
The Parade/AQUA Projects, Glasgow University, 1994-1995.
- GdH/APART Projects, Heriot-Watt University, Edinburgh, 1997-1999.
- P. Trinder, November 30th. 1994.
- Adapted for new RTS
- P. Trinder, July 1997.
- H-W. Loidl, November 1999.
+ GdH/APART Projects, Heriot-Watt University, Edinburgh, 1997-2000.
------------------------------------------------------------------------- */
-//@node GUM System Manager Program, , ,
+//@node GUM System Manager Program, , ,
//@section GUM System Manager Program
//@menu
//* Includes::
//* Macros etc::
//* Variables::
+//* Prototypes::
+//* Aux startup and shutdown fcts::
//* Main fct::
+//* Message handlers::
//* Auxiliary fcts::
//* Index::
//@end menu
//@subsection General docu
/*
-
The Sysman task currently controls initiation, termination, of a
parallel Haskell program running under GUM. In the future it may
control global GC synchronisation and statistics gathering. Based on
OK children, buckle down for some serious weirdness, it works like this ...
-
o The argument vector (argv) for SysMan has one the following 2 shapes:
-------------------------------------------------------------------------------
o use PVM to spawn (nPE-1) PVM tasks
o fork SysMan to create the main-thread PE. This permits the main-thread to
-read and write to stdin and stdout.
-o Barrier-synchronise waiting for all of the PE-tasks to start.
-o Broadcast the SysMan task-id, so that the main thread knows it.
-o Wait for the Main-thread PE to send it's task-id.
-o Broadcast an array of the PE task-ids to all of the PE-tasks.
+ read and write to stdin and stdout.
+o Wait for all the PE-tasks to reply back saying they are ready and if they were the
+ main thread or not.
+o Broadcast an array of the PE task-ids out to all of the PE-tasks.
o Enter a loop awaiting incoming messages, e.g. failure, Garbage-collection,
-termination.
+ termination.
The forked Main-thread algorithm, in SysMan, is as follows.
The pvm-executable run by each PE-task, is initialised as follows.
o Registers with PVM, obtaining a task-id.
-o Joins the barrier synchronisation awaiting the other PEs.
-o Receives and records the task-id of SysMan, for future use.
-o If the PE is the main thread it sends its task-id to SysMan.
-o Receives and records the array of task-ids of the other PEs.
+o If it was main it gets SysMan's task-id from argv otherwise it can use pvm_parent.
+oSends a ready message to SysMan together with a flag indicating if it was main or not.
+o Receives from SysMan the array of task-ids of the other PEs.
+o If the number of task-ids sent was larger than expected then it must have been a task
+ generated after the rest of the program had started, so it sends its own task-id message
+ to all the tasks it was told about.
o Begins execution.
*/
#include "ParTypes.h"
#include "LLC.h"
#include "Parallel.h"
+#include "ParallelRts.h" // stats only
//@node Macros etc, Variables, Includes, GUM System Manager Program
//@subsection Macros etc
#define NON_POSIX_SOURCE /* so says Solaris */
-#define checkerr(c) do { \
- if ((c)<0) { \
- pvm_perror("Sysman"); \
- fprintf(stderr,"Sysman"); \
- stg_exit(EXIT_FAILURE); \
- } \
- } while(0)
-
/* SysMan is put on top of the GHC routine that does the RtsFlags handling.
So, we cannot use the standard macros. For the time being we use a macro
that is fixed at compile time.
*/
+
+#ifdef IF_PAR_DEBUG
+#undef IF_PAR_DEBUG
+#endif
+
/* debugging enabled */
-#define IF_PAR_DEBUG(c,s) { s; }
+//#define IF_PAR_DEBUG(c,s) { s; }
/* debugging disabled */
-// #define IF_PAR_DEBUG(c,s) /* nothing */
+#define IF_PAR_DEBUG(c,s) /* nothing */
+
+void *stgMallocBytes (int n, char *msg);
-//@node Variables, Main fct, Macros etc, GUM System Manager Program
+//@node Variables, Prototypes, Macros etc, GUM System Manager Program
//@subsection Variables
/*
The following definitions included so that SysMan can be linked with Low
- Level Communications module (LLComms). They are not used in SysMan. */
+ Level Communications module (LLComms). They are not used in SysMan.
+*/
+GlobalTaskId mytid;
+
+static unsigned PEsArrived = 0;
+static GlobalTaskId gtids[MAX_PES];
+static GlobalTaskId sysman_id, sender_id;
+static unsigned PEsTerminated = 0;
+static rtsBool Finishing = rtsFalse;
+static long PEbuffer[MAX_PES];
+nat nSpawn = 0; // current no. of spawned tasks (see gtids)
+nat nPEs = 0; // number of PEs specified on startup
+nat nextPE;
+/* PVM-ish variables */
+char *petask, *pvmExecutable;
+char **pargv;
+int cc, spawn_flag = PvmTaskDefault;
+
+#if 0 && defined(PAR_TICKY)
+/* ToDo: use allGlobalParStats to collect stats of all PEs */
+GlobalParStats *allGlobalParStats[MAX_PES];
+#endif
+
+//@node Prototypes, Aux startup and shutdown fcts, Variables, GUM System Manager Program
+//@subsection Prototypes
+
+/* prototypes for message handlers called from the main loop of SysMan */
+void newPE(int nbytes, int opcode, int sender_id);
+void readyPE(int nbytes, int opcode, int sender_id);
+void finishPE(int nbytes, int opcode, int sender_id, int exit_code);
+
+//@node Aux startup and shutdown fcts, Main fct, Prototypes, GUM System Manager Program
+//@subsection Aux startup and shutdown fcts
+
+/*
+ Create the PE Tasks. We spawn (nPEs-1) pvm threads: the Main Thread
+ (which starts execution and performs IO) is created by forking SysMan
+*/
+static int
+createPEs(int total_nPEs) {
+ int i, spawn_nPEs, iSpawn = 0, nArch, nHost;
+ struct pvmhostinfo *hostp;
+ int sysman_host;
+
+ spawn_nPEs = total_nPEs-1;
+ if (spawn_nPEs > 0) {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== [%x] Spawning %d PEs(%s) ...\n",
+ sysman_id, spawn_nPEs, petask);
+ fprintf(stderr, " args: ");
+ for (i = 0; pargv[i]; ++i)
+ fprintf(stderr, "%s, ", pargv[i]);
+ fprintf(stderr, "\n"));
+
+ pvm_config(&nHost,&nArch,&hostp);
+ sysman_host=pvm_tidtohost(sysman_id);
+
+ /* create PEs on the specific machines in the specified order! */
+ for (i=0; (iSpawn<spawn_nPEs) && (i<nHost); i++)
+ if (hostp[i].hi_tid != sysman_host) {
+ checkComms(pvm_spawn(petask, pargv, spawn_flag+PvmTaskHost,
+ hostp[i].hi_name, 1, gtids+iSpawn),
+ "SysMan startup");
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== [%x] Spawned PE %d onto %s\n",
+ sysman_id, i, hostp[i].hi_name));
+ iSpawn++;
+ }
+
+ /* create additional PEs anywhere you like */
+ if (iSpawn<spawn_nPEs) {
+ checkComms(pvm_spawn(petask, pargv, spawn_flag, "",
+ spawn_nPEs-iSpawn, gtids+iSpawn),
+ "SysMan startup");
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Spawned %d additional PEs anywhere\n",
+ sysman_id, spawn_nPEs-iSpawn));
+ }
+ }
+
+#if 0
+ /* old code with random placement of PEs; make that a variant? */
+# error "Broken startup in SysMan"
+ { /* let pvm place the PEs anywhere; not used anymore */
+ checkComms(pvm_spawn(petask, pargv, spawn_flag, "", spawn_nPEs, gtids),"SysMan startup");
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Spawned\n", sysman_id));
+
+ }
+#endif
+
+ // iSpawn=spawn_nPEs;
+
+ return iSpawn;
+}
+
+/*
+ Check if this pvm task is in the list of tasks we spawned and are waiting
+ on, if so then remove it.
+*/
+
+static rtsBool
+alreadySpawned (GlobalTaskId g) {
+ unsigned int i;
+
+ for (i=0; i<nSpawn; i++)
+ if (g==gtids[i]) {
+ nSpawn--;
+ gtids[i] = gtids[nSpawn]; //the last takes its place
+ return rtsTrue;
+ }
+ return rtsFalse;
+}
-GlobalTaskId mytid, SysManTask;
-rtsBool IAmMainThread;
-rtsBool GlobalStopPending = rtsFalse;
- /* Handle unexpected messages correctly */
+static void
+broadcastFinish(void) {
+ int i,j;
+ int tids[MAX_PES]; /* local buffer of all surviving PEs */
-static GlobalTaskId gtids[MAX_PES];
-static GlobalTaskId sysman_id, sender_id, mainThread_id;
-static unsigned PEsTerminated = 0;
-static rtsBool Finishing = rtsFalse;
-static long PEbuffer[MAX_PES];
-nat nPEs = 0;
+ for (i=0, j=0; i<nPEs; i++)
+ if (PEbuffer[i])
+ tids[j++]=PEbuffer[i]; //extract valid tids
-//@node Main fct, Auxiliary fcts, Variables, GUM System Manager Program
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Broadcasting Finish to %d PEs; initiating shutdown\n",
+ sysman_id, j));
+
+ /* ToDo: move into LLComms.c */
+ pvm_initsend(PvmDataDefault);
+ pvm_mcast(tids,j,PP_FINISH);
+}
+
+static void
+broadcastPEtids (void) {
+ nat i;
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan sending PE table to all PEs\n", sysman_id);
+ /* debugging */
+ fprintf(stderr,"++++ [%x] PE table as seen by SysMan:\n", mytid);
+ for (i = 0; i < nPEs; i++) {
+ fprintf(stderr,"++++ PEbuffer[%d] = %x\n", i, PEbuffer[i]);
+ }
+ )
+
+ broadcastOpN(PP_PETIDS, PEGROUP, nPEs, &PEbuffer);
+}
+
+//@node Main fct, Message handlers, Aux startup and shutdown fcts, GUM System Manager Program
//@subsection Main fct
//@cindex main
+int
main (int argc, char **argv) {
int rbufid;
- int opcode, nbytes;
- char **pargv;
- int i, cc, spawn_flag = PvmTaskDefault;
- char *petask, *pvmExecutable;
- rtsPacket addr;
+ int opcode, nbytes, nSpawn;
+ unsigned int i;
setbuf(stdout, NULL); // disable buffering of stdout
setbuf(stderr, NULL); // disable buffering of stderr
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,
+ "==== RFP: GdH enabled SysMan reporting for duty ($Revision: 1.4 $)\n"));
if (argc > 1) {
if (*argv[1] == '-') {
}
sysman_id = pvm_mytid(); /* This must be the first PVM call */
- checkerr(sysman_id);
+ if (sysman_id<0) {
+ fprintf(stderr, "==== PVM initialisation failure\n");
+ exit(EXIT_FAILURE);
+ }
/*
Get the full path and filename of the pvm executable (stashed in some
pvmExecutable = argv[1];
nPEs = atoi(argv[2]);
+ if (nPEs==0) {
+ /* as usual 0 means infinity: use all PEs specified in PVM config */
+ int nArch, nHost;
+ struct pvmhostinfo *hostp;
+
+ /* get info on PVM config */
+ pvm_config(&nHost,&nArch,&hostp);
+ nPEs=nHost;
+ sprintf(argv[2],"%d",nPEs); /* ToCheck: does this work on all archs */
+ }
+
+ /* get the name of the binary to execute */
if ((petask = getenv(PETASK)) == NULL) // PETASK set by driver
petask = PETASK;
IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] nPEs (%s) = %d\n",
- sysman_id, petask, nPEs));
+ fprintf(stderr,"==== [%x] nPEs: %d; executable: |%s|\n",
+ sysman_id, nPEs, petask));
- /* Check that we can create the number of PE and IMU tasks requested */
- if (nPEs > MAX_PES) {
- fprintf(stderr,"SysMan: No more than %d PEs allowed (%d requested)\n",
+ /* Check that we can create the number of PE and IMU tasks requested.
+ ^^^
+ This comment is most entertaining since we haven't been using IMUs
+ for the last 10 years or so -- HWL */
+ if ((nPEs > MAX_PES) || (nPEs<1)) {
+ fprintf(stderr,"==** SysMan: No more than %d PEs allowed (%d requested)\n Reconfigure GUM setting MAX_PE in ghc/includes/Parallel.h to a higher value\n",
MAX_PES, nPEs);
- stg_exit(EXIT_FAILURE);
+ exit(EXIT_FAILURE);
}
- /*
- Now create the PE Tasks. We spawn (nPEs-1) pvm threads: the Main Thread
- (which starts execution and performs IO) is created by forking SysMan
- */
- nPEs--;
- if (nPEs > 0) {
- /* Initialise the PE task arguments from Sysman's arguments */
- pargv = argv + 2;
- IF_PAR_DEBUG(verbose,
- fprintf(stderr, "== [%x] Spawning %d PEs(%s) ...\n",
- sysman_id, nPEs, petask);
- fprintf(stderr, " args: ");
- for (i = 0; pargv[i]; ++i)
- fprintf(stderr, "%s, ", pargv[i]);
- fprintf(stderr, "\n"));
-
- checkerr(pvm_spawn(petask, pargv, spawn_flag, "", nPEs, gtids));
- /*
- * Stash the task-ids of the PEs away in a buffer, once we know
- * the Main Thread's task-id, we'll broadcast them all.
- */
- for (i = 0; i < nPEs; i++)
- PEbuffer[i+1] = (long) gtids[i];
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] is SysMan Task\n", sysman_id));
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Spawned\n", sysman_id));
- }
+ /* Initialise the PE task arguments from Sysman's arguments */
+ pargv = argv + 2;
+
+ /* Initialise list of all PE identifiers */
+ PEsArrived=0;
+ nextPE=1;
+ for (i=0; i<nPEs; i++)
+ PEbuffer[i]=0;
+
+ /* start up the required number of PEs */
+ nSpawn = createPEs(nPEs);
/*
Create the MainThread PE by forking SysMan. This arcane coding
is required to allow MainThread to read stdin and write to stdout.
PWT 18/1/96
*/
- nPEs++; /* Record that the number of PEs is increasing */
+ //nPEs++; /* Record that the number of PEs is increasing */
if ((cc = fork())) {
- checkerr(cc); /* Parent continues as SysMan */
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] SysMan Task is [t%x]\n", sysman_id));
-
- /*
- SysMan joins PECTLGROUP, so that it can wait (at the
- barrier sysnchronisation a few instructions later) for the
- other PE-tasks to start.
-
- The manager group (MGRGROUP) is vestigial at the moment. It
- may eventually include a statistics manager, and a (global)
- garbage collector manager.
- */
- checkerr(pvm_joingroup(PECTLGROUP));
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Joined PECTLGROUP \n", sysman_id));
-
- /* Wait for all the PEs to arrive */
- checkerr(pvm_barrier(PECTLGROUP, nPEs + 1));
-
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] PECTLGROUP barrier passed \n",
- sysman_id));
-
- /* Broadcast SysMan's ID, so Main Thread PE knows it */
- pvm_initsend(PvmDataDefault);
- pvm_bcast(PEGROUP, PP_SYSMAN_TID);
-
- /* Wait for Main Thread to identify itself*/
- addr = waitForPEOp(PP_MAIN_TASK, ANY_GLOBAL_TASK);
- pvm_bufinfo(addr, &nbytes, &opcode, &mainThread_id);
- PEbuffer[0] = mainThread_id;
-
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] SysMan received Main Task = %x\n",
- sysman_id, mainThread_id));
-
- /* Now that we have them all, broadcast Global Task Ids of all PEs */
- pvm_initsend(PvmDataDefault);
- PutArgs(PEbuffer, nPEs);
- pvm_bcast(PEGROUP, PP_PETIDS);
+ checkComms(cc,"SysMan fork"); /* Parent continues as SysMan */
+
+ PEbuffer[0]=0; /* we accept the first main and assume its valid. */
+ PEsArrived=1; /* assume you've got main */
IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Sysman successfully initialized!\n",
+ fprintf(stderr,"==== [%x] Sysman successfully initialized!\n",
sysman_id));
//@cindex message handling loop
/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* Process incoming messages */
while (1) {
- if ((rbufid = pvm_recv(ANY_TASK, ANY_OPCODE)) < 0)
- pvm_perror("Sysman: Receiving Message");
- else {
- pvm_bufinfo(rbufid, &nbytes, &opcode, &sender_id);
-
- /*
- IF_PAR_DEBUG(trace,
- fprintf(stderr,"== [%x] SysMan: Message received by SysMan: rbufid=%x, nbytes = %d, opcode = %x, sender_id = %x\n",
- sysman_id, rbufid, nbytes, opcode, sender_id));
- */
- switch (opcode) {
- case PP_GC_INIT:
+ if ((rbufid = pvm_recv(ANY_TASK, ANY_OPCODE)) < 0) {
+ pvm_perror("==** Sysman: Receiving Message (pvm_recv)");
+ /* never reached */
+ }
+
+ pvm_bufinfo(rbufid, &nbytes, &opcode, &sender_id);
+
+ /* very low level debugging
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"== [%x] SysMan: Message received by SysMan: rbufid=%x, nbytes = %d, opcode = %x, sender_id = %x\n",
+ sysman_id, rbufid, nbytes, opcode, sender_id));
+ */
+
+ switch (opcode) {
+
+ case PP_NEWPE: /* a new PE is registering for work */
+ newPE(nbytes, opcode, sender_id);
+ break;
+
+ case PP_READY: /* startup complete; let PEs start working */
+ readyPE(nbytes, opcode, sender_id);
+ break;
+
+
+ case PP_GC_INIT: /* start global GC */
/* This Function not yet implemented for GUM */
- fprintf(stderr,"Global GC from %x Not yet implemented for GUM!\n",
- sender_id);
- sync(PECTLGROUP, PP_FULL_SYSTEM);
- broadcast(PEGROUP, PP_GC_INIT);
- /* DoGlobalGC(); */
- /* broadcast(PEGROUP, PP_INIT); */
+ fprintf(stderr,"==** Global GC requested by PE %x. Not yet implemented for GUM!\n",
+ sender_id);
break;
- case PP_STATS_ON:
- fprintf(stderr,"PP_STATS_ON (from %x) not yet implemented for GUM!\n",
+ case PP_STATS_ON: /* enable statistics gathering */
+ fprintf(stderr,"==** PP_STATS_ON requested by %x. Not yet implemented for GUM!\n",
sender_id);
break;
- case PP_STATS_OFF:
- fprintf(stderr,"PP_STATS_OFF (from %x) not yet implemented for GUM!\n",
+ case PP_STATS_OFF: /* disable statistics gathering */
+ fprintf(stderr,"==** PP_STATS_OFF requested by %x. Not yet implemented for GUM!\n",
sender_id);
break;
case PP_FINISH:
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Finish from %x\n",
- sysman_id, sender_id));
- if (!Finishing) {
- Finishing = rtsTrue;
- PEsTerminated = 1;
- pvm_initsend(PvmDataDefault);
- pvm_bcast(PEGROUP, PP_FINISH);
- } else {
- ++PEsTerminated;
- }
- if (PEsTerminated >= nPEs) {
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Global Shutdown, Goodbye!! (SysMan has received FINISHes from all PEs)\n",
- sysman_id));
- broadcast(PEGROUP, PP_FINISH);
- broadcast(MGRGROUP, PP_FINISH);
- pvm_lvgroup(PECTLGROUP);
- pvm_lvgroup(MGRGROUP);
- pvm_exit();
- exit(EXIT_SUCCESS);
- /* Qapla'! */
- }
- break;
-
- case PP_FAIL:
- IF_PAR_DEBUG(verbose,
- fprintf(stderr,"== [%x] Fail from %x\n",
- sysman_id, sender_id));
- if (!Finishing) {
- Finishing = rtsTrue;
- broadcast(PEGROUP, PP_FAIL);
- }
- break;
-
+ {
+ int exit_code = getExitCode(nbytes, &sender_id);
+ finishPE(nbytes, opcode, sender_id, exit_code);
+ break;
+
default:
{
/*
char *opname = GetOpName(opcode);
fprintf(stderr,"Sysman: Unrecognised opcode %s (%x)\n",
opname,opcode); */
- fprintf(stderr,"Qagh: Sysman: Unrecognised opcode (%x)\n",
- opcode);
+ fprintf(stderr,"==** Qagh: Sysman: Unrecognised opcode (%x)\n",
+ opcode);
}
break;
} /* switch */
- } /* else */
+ } /* else */
} /* while 1 */
- } /* forked Sysman Process */
- else {
- fprintf(stderr, "Main Thread PE has been forked; doing an execv(%s,...)\n",
- pvmExecutable);
- pvmendtask(); /* Disconnect from PVM to avoid confusion: */
- /* executable reconnects */
- *argv[0] = '-'; /* Flag that this is the Main Thread PE */
+ /* end of SysMan!! */
+ } else {
+ /* forked main thread begins here */
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== Main Thread PE has been forked; doing an execv(%s,...)\n",
+ pvmExecutable));
+ pvmendtask(); // Disconnect from PVM to avoid confusion:
+ // executable reconnects
+
+ // RFP: assumes that length(arvv[0])>=9 !!!
+ sprintf(argv[0],"-%08X",sysman_id); /*flag that its the Main Thread PE and include sysman's id*/
execv(pvmExecutable,argv); /* Parent task becomes Main Thread PE */
- }
- } /* argc > 1 */
-} /* main */
+ } /* else */
+ } /* argc > 1 */
+} /* main */
-//@node Auxiliary fcts, Index, Main fct, GUM System Manager Program
-//@subsection Auxiliary fcts
+//@node Message handlers, Auxiliary fcts, Main fct, GUM System Manager Program
+//@subsection Message handlers
/*
- * This reproduced from RtsUtlis to save linking with a whole ball of wax
- */
-/* result-checking malloc wrappers. */
-
-//@cindex stgMallocBytes
-
-void *
-stgMallocBytes (int n, char *msg)
-{
- char *space;
-
- if ((space = (char *) malloc((size_t) n)) == NULL) {
- fflush(stdout);
- fprintf(stderr, msg);
- // MallocFailHook((W_) n, msg); /*msg*/
- stg_exit(EXIT_FAILURE);
+ Received PP_NEWPE:
+ A new PE has been added to the configuration.
+*/
+void
+newPE(int nbytes, int opcode, int sender_id) {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan detected a new host\n",
+ sysman_id));
+
+ /* Determine the new machine... assume its the last on the config list? */
+ if (nSpawn < MAX_PES) {
+ int nArch,nHost;
+ struct pvmhostinfo *hostp;
+
+ /* get conmfiguration of PVM machine */
+ pvm_config(&nHost,&nArch,&hostp);
+ nHost--;
+ checkComms(pvm_spawn(petask, pargv, spawn_flag+PvmTaskHost,
+ hostp[nHost].hi_name, 1, gtids+nSpawn),
+ "SysMan loop");
+ nSpawn++;
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr, "==== [%x] Spawned onto %s\n",
+ sysman_id, hostp[nHost].hi_name));
+ }
+}
+
+/*
+ Received PP_READY:
+ Let it be known that PE @sender_id@ participates in the computation.
+*/
+void
+readyPE(int nbytes, int opcode, int sender_id) {
+ int i = 0, flag = 1;
+ long isMain;
+ int nArch, nHost;
+ struct pvmhostinfo *hostp;
+
+ //ASSERT(opcode==PP_READY);
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan received PP_READY message from %x\n",
+ sysman_id, sender_id));
+
+ pvm_config(&nHost,&nArch,&hostp);
+
+ GetArg1(isMain);
+
+ //if ((isMain && (PEbuffer[0]==0)) || alreadySpawned(sender_id)) {
+ if (nPEs >= MAX_PES) {
+ fprintf(stderr,"==== [%x] SysMan doesn't need PE %d (max %d PEs allowed)\n",
+ sysman_id, sender_id, MAX_PES);
+ pvm_kill(sender_id);
+ } else {
+ if (isMain) {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan found Main PE %x\n",
+ sysman_id, sender_id));
+ PEbuffer[0]=sender_id;
+ } else {
+ /* search for PE in list of PEs */
+ for(i=1; i<nPEs; i++)
+ if (PEbuffer[i]==sender_id) {
+ flag=0;
+ break;
+ }
+ /* it's a new PE: add it to the list of PEs */
+ if (flag)
+ PEbuffer[nextPE++] = sender_id;
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan: found PE %d as [%x] on host %s\n",
+ sysman_id, PEsArrived, sender_id, hostp[PEsArrived].hi_name));
+
+ PEbuffer[PEsArrived++] = sender_id;
+ }
+
+
+ /* enable better handling of unexpected terminations */
+ checkComms( pvm_notify(PvmTaskExit, PP_FINISH, 1, &sender_id),
+ "SysMan loop");
+
+ /* finished registration of all PEs => enable notification */
+ if ((PEsArrived==nPEs) && PEbuffer[0]) {
+ checkComms( pvm_notify(PvmHostAdd, PP_NEWPE, -1, 0),
+ "SysMan startup");
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan initialising notificaton for new hosts\n", sysman_id));
+ }
+
+ /* finished notification => send off the PE ids */
+ if ((PEsArrived>=nPEs) && PEbuffer[0]) {
+ if (PEsArrived>nPEs) {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Weird: %d PEs registered, but we only asked for %d\n", sysman_id, PEsArrived, nPEs));
+ // nPEs=PEsArrived;
+ }
+ broadcastPEtids();
+ }
}
- return space;
}
+/*
+ Received PP_FINISH:
+ Shut down the corresponding PE. Check whether it is a regular shutdown
+ or an uncontrolled termination.
+*/
+void
+finishPE(int nbytes, int opcode, int sender_id, int exitCode) {
+ int i;
+
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] SysMan received PP_FINISH message from %x (exit code: %d)\n",
+ sysman_id, sender_id, exitCode));
+
+ /* Is it relevant to us? Count the first message */
+ for (i=0; i<nPEs; i++)
+ if (PEbuffer[i] == sender_id) {
+ PEsTerminated++;
+ PEbuffer[i]=0;
+
+ /* handle exit code */
+ if (exitCode<0) { /* a task exit before a controlled finish? */
+ fprintf(stderr,"==== [%x] Termination at %x with exit(%d)\n",
+ sysman_id, sender_id, exitCode);
+ } else if (exitCode>0) { /* an abnormal exit code? */
+ fprintf(stderr,"==== [%x] Uncontrolled termination at %x with exit(%d)\n",
+ sysman_id, sender_id, exitCode);
+ } else if (!Finishing) { /* exitCode==0 which is good news */
+ if (i!=0) { /* someone other than main PE terminated first? */
+ fprintf(stderr,"==== [%x] Unexpected early termination at %x\n",
+ sysman_id, sender_id);
+ } else {
+ /* start shutdown by broadcasting FINISH to other PEs */
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Initiating shutdown (requested by [%x] RIP) (exit code: %d)\n", sysman_id, sender_id, exitCode));
+ Finishing = rtsTrue;
+ broadcastFinish();
+ }
+ } else {
+ /* we are in a shutdown already */
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Finish from %x during shutdown (%d PEs terminated so far; %d total)\n",
+ sysman_id, sender_id, PEsTerminated, nPEs));
+ }
+
+ if (PEsTerminated >= nPEs) {
+ IF_PAR_DEBUG(verbose,
+ fprintf(stderr,"==== [%x] Global Shutdown, Goodbye!! (SysMan has received FINISHes from all PEs)\n", sysman_id));
+ //broadcastFinish();
+ /* received finish from everybody; now, we can exit, too */
+ exit(EXIT_SUCCESS); /* Qapla'! */
+ }
+ }
+}
+
+//@node Auxiliary fcts, Index, Message handlers, GUM System Manager Program
+//@subsection Auxiliary fcts
+
/* Needed here because its used in loads of places like LLComms etc */
//@cindex stg_exit
-void stg_exit(n)
-I_ n;
+/*
+ * called from STG-land to exit the program
+ */
+
+void
+stg_exit(I_ n)
{
- exit(n);
+ fprintf(stderr, "==// [%x] %s in SysMan code; sending PP_FINISH to all PEs ...\n",
+ mytid,(n!=0)?"FAILURE":"FINISH");
+ broadcastFinish();
+ //broadcastFinish();
+ pvm_exit();
+ exit(n);
}
//@node Index, , Auxiliary fcts, GUM System Manager Program
include $(TOP)/mk/target.mk
-
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.8 2000/11/03 16:23:38 simonmar Exp $
+# $Id: Makefile,v 1.9 2001/03/22 03:51:12 hwloidl Exp $
#
# (c) The GHC Team, 1999-2000
#
NOT_THESE += dmgob_native1 dmgob_native2
# Native library doens't exist
+ifneq "$(HWL_NOFIB_HACK)" ""
+NOT_THESE += callback zhang_ccall
+# HWL: tmp disabled for testing GUM-merged version (20/3/01)
+# don't compile: failed to load interface for `IOExts'
+endif
+
SUBDIRS = $(filter-out $(patsubst %, %/, $(NOT_THESE)), $(wildcard */))
include $(TOP)/mk/target.mk
projects / ghc-hetmet.git / commitdiff