each build is compiled consistently
*/
-GHC_OPTS_norm=-O /*-fsemi-tagging*/ -darity-checks-C-only rts_or_lib(-optc-DGCap,)
-GHC_OPTS_p =-hisuf _p.hi -O /*-fsemi-tagging*/ -prof -GPrelude rts_or_lib(-optc-DGCap,)
-GHC_OPTS_t =-hisuf _t.hi -O /*-fsemi-tagging*/ -ticky -optc-DDEBUG rts_or_lib(-optc-DGCap,)
-GHC_OPTS_u =-hisuf _u.hi -O -unregisterised ???? /*-fsemi-tagging*/ -ticky rts_or_lib(-optc-DGCap,)
-GHC_OPTS_mc=-hisuf _mc.hi -O -concurrent rts_or_lib(-optc-DGCap,)
-GHC_OPTS_mr=-hisuf _mr.hi -O -concurrent -prof -GPrelude rts_or_lib(-optc-DGCap,)
-GHC_OPTS_mt=-hisuf _mt.hi -O -concurrent -ticky -optc-DDEBUG rts_or_lib(-optc-DGCap,)
-GHC_OPTS_mp=-hisuf _mp.hi -O -parallel rts_or_lib(-optc-DGCap,)
-GHC_OPTS_mg=-hisuf _mg.hi -O -gransim rts_or_lib(-optc-DGCap,)
-GHC_OPTS_2s=-hisuf _2s.hi -O -gc-2s rts_or_lib(-optc-DGC2s,)
-GHC_OPTS_1s=-hisuf _1s.hi -O -gc-1s rts_or_lib(-optc-DGC1s,)
-GHC_OPTS_du=-hisuf _du.hi -O -gc-du rts_or_lib(-optc-DGCdu,)
+GHC_OPTS_norm=-O rts_or_lib(-optc-DGCap,)
+GHC_OPTS_p =-hisuf p_hi -O -prof -GPrelude rts_or_lib(-optc-DGCap,)
+GHC_OPTS_t =-hisuf t_hi -O -ticky -optc-DDEBUG rts_or_lib(-optc-DGCap,)
+GHC_OPTS_u =-hisuf u_hi -O -unregisterised ???? -ticky rts_or_lib(-optc-DGCap,)
+GHC_OPTS_mc=-hisuf mc_hi -O -concurrent rts_or_lib(-optc-DGCap,)
+GHC_OPTS_mr=-hisuf mr_hi -O -concurrent -prof -GPrelude rts_or_lib(-optc-DGCap,)
+GHC_OPTS_mt=-hisuf mt_hi -O -concurrent -ticky -optc-DDEBUG rts_or_lib(-optc-DGCap,)
+GHC_OPTS_mp=-hisuf mp_hi -O -parallel rts_or_lib(-optc-DGCap,)
+GHC_OPTS_mg=-hisuf mg_hi -O -gransim rts_or_lib(-optc-DGCap,)
+GHC_OPTS_2s=-hisuf 2s_hi -O -gc-2s rts_or_lib(-optc-DGC2s,)
+GHC_OPTS_1s=-hisuf 1s_hi -O -gc-1s rts_or_lib(-optc-DGC1s,)
+GHC_OPTS_du=-hisuf du_hi -O -gc-du rts_or_lib(-optc-DGCdu,)
/* ToDo: mkworld-ify these user-way opts */
-GHC_OPTS_a =-hisuf _a.hi -user-setup-a rts_or_lib(-optc-DGCap,)
-GHC_OPTS_b =-hisuf _b.hi -user-setup-b rts_or_lib(-optc-DGCap,)
-GHC_OPTS_c =-hisuf _c.hi -user-setup-c rts_or_lib(-optc-DGCap,)
-GHC_OPTS_d =-hisuf _d.hi -user-setup-d rts_or_lib(-optc-DGCap,)
-GHC_OPTS_e =-hisuf _e.hi -user-setup-e rts_or_lib(-optc-DGCap,)
-GHC_OPTS_f =-hisuf _f.hi -user-setup-f rts_or_lib(-optc-DGCap,)
-GHC_OPTS_g =-hisuf _g.hi -user-setup-g rts_or_lib(-optc-DGCap,)
-GHC_OPTS_h =-hisuf _h.hi -user-setup-h rts_or_lib(-optc-DGCap,)
-GHC_OPTS_i =-hisuf _i.hi -user-setup-i rts_or_lib(-optc-DGCap,)
-GHC_OPTS_j =-hisuf _j.hi -user-setup-j rts_or_lib(-optc-DGCap,)
-GHC_OPTS_k =-hisuf _k.hi -user-setup-k rts_or_lib(-optc-DGCap,)
-GHC_OPTS_l =-hisuf _l.hi -user-setup-l rts_or_lib(-optc-DGCap,)
-GHC_OPTS_m =-hisuf _m.hi -user-setup-m rts_or_lib(-optc-DGCap,)
-GHC_OPTS_n =-hisuf _n.hi -user-setup-n rts_or_lib(-optc-DGCap,)
-GHC_OPTS_o =-hisuf _o.hi -user-setup-o rts_or_lib(-optc-DGCap,)
-GHC_OPTS_A =-hisuf _A.hi -user-setup-A rts_or_lib(-optc-DGCap,)
-GHC_OPTS_B =-hisuf _B.hi -user-setup-B rts_or_lib(-optc-DGCap,)
+GHC_OPTS_a =-hisuf a_hi -user-setup-a rts_or_lib(-optc-DGCap,)
+GHC_OPTS_b =-hisuf b_hi -user-setup-b rts_or_lib(-optc-DGCap,)
+GHC_OPTS_c =-hisuf c_hi -user-setup-c rts_or_lib(-optc-DGCap,)
+GHC_OPTS_d =-hisuf d_hi -user-setup-d rts_or_lib(-optc-DGCap,)
+GHC_OPTS_e =-hisuf e_hi -user-setup-e rts_or_lib(-optc-DGCap,)
+GHC_OPTS_f =-hisuf f_hi -user-setup-f rts_or_lib(-optc-DGCap,)
+GHC_OPTS_g =-hisuf g_hi -user-setup-g rts_or_lib(-optc-DGCap,)
+GHC_OPTS_h =-hisuf h_hi -user-setup-h rts_or_lib(-optc-DGCap,)
+GHC_OPTS_i =-hisuf i_hi -user-setup-i rts_or_lib(-optc-DGCap,)
+GHC_OPTS_j =-hisuf j_hi -user-setup-j rts_or_lib(-optc-DGCap,)
+GHC_OPTS_k =-hisuf k_hi -user-setup-k rts_or_lib(-optc-DGCap,)
+GHC_OPTS_l =-hisuf l_hi -user-setup-l rts_or_lib(-optc-DGCap,)
+GHC_OPTS_m =-hisuf m_hi -user-setup-m rts_or_lib(-optc-DGCap,)
+GHC_OPTS_n =-hisuf n_hi -user-setup-n rts_or_lib(-optc-DGCap,)
+GHC_OPTS_o =-hisuf o_hi -user-setup-o rts_or_lib(-optc-DGCap,)
+GHC_OPTS_A =-hisuf A_hi -user-setup-A rts_or_lib(-optc-DGCap,)
+GHC_OPTS_B =-hisuf B_hi -user-setup-B rts_or_lib(-optc-DGCap,)
+#if 0
+%************************************************************************
+%* *
+\section[mkworld-install-ghc]{Installation stuff for @ghc@ project}
+%* *
+%************************************************************************
+
+NONE.
+#endif
+++ /dev/null
-%************************************************************************
-%* *
-\section[mkworld-install-ghc]{Installation stuff for @ghc@ project}
-%* *
-%************************************************************************
-
-NONE.
-# line 9 "macros-ghc.ljm"
/* ToDo: cmp -> $(CMP) */
#ifndef UgenTarget
-#define UgenTarget(fileroot) @@\
-ExtraStuffToBeVeryClean(fileroot.c fileroot.h fileroot.hs) @@\
-fileroot.c : fileroot.ugn @@\
- d=`dirname fileroot.ugn` ; f=`basename fileroot.ugn .ugn` ; \ @@\
- $(RM) fileroot.c fileroot.hs "$$d/U_$$f.hs" fileroot.h-SAVE @@\
- if [ -f fileroot.h ] ; then $(MV) -f fileroot.h fileroot.h-SAVE ; else exit 0 ; fi @@\
- $(UGEN) fileroot.ugn || ( $(RM) fileroot.h fileroot.c fileroot.hs; $(MV) -f fileroot.h-SAVE fileroot.h ) @@\
- if cmp -s fileroot.h-SAVE fileroot.h ; then \ @@\
- $(MV) -f fileroot.h-SAVE fileroot.h ; \ @@\
- else \ @@\
- chmod 444 fileroot.h fileroot.c fileroot.hs ; \ @@\
- fi @@\
- @$(RM) fileroot.h-SAVE @@\
- @d=`dirname fileroot.ugn` ; f=`basename fileroot.ugn .ugn` ; \ @@\
- $(MV) -f fileroot.hs "$$d/U_$$f.hs" @@\
- @@\
-fileroot.h : fileroot.c @@\
+#define UgenTarget(dir,fileroot) @@\
+ExtraStuffToBeVeryClean(dir/fileroot.c dir/fileroot.h dir/fileroot.hs) @@\
+dir/fileroot.c dir/CAT3(U_,fileroot,.hs): dir/fileroot.ugn @@\
+ $(RM) dir/fileroot.c dir/fileroot.hs dir/CAT3(U_,fileroot,.hs) dir/fileroot.h-SAVE @@\
+ if [ -f dir/fileroot.h ] ; then $(MV) -f dir/fileroot.h dir/fileroot.h-SAVE ; else exit 0 ; fi @@\
+ $(UGEN) dir/fileroot.ugn || ( $(RM) dir/fileroot.h dir/fileroot.c dir/fileroot.hs; $(MV) -f dir/fileroot.h-SAVE dir/fileroot.h ) @@\
+ if cmp -s dir/fileroot.h-SAVE dir/fileroot.h ; then \ @@\
+ $(MV) -f dir/fileroot.h-SAVE dir/fileroot.h ; \ @@\
+ else \ @@\
+ chmod 444 dir/fileroot.h dir/fileroot.c dir/fileroot.hs ; \ @@\
+ fi @@\
+ @$(RM) dir/fileroot.h-SAVE @@\
+ $(MV) -f dir/fileroot.hs dir/CAT3(U_,fileroot,.hs) @@\
+ @@\
+dir/fileroot.h : dir/fileroot.c @@\
@: /* no-op */
#endif /* UgenTarget */
+++ /dev/null
-%************************************************************************
-%* *
-\section[mkworld-macros-ghc]{CPP macros for @ghc@ project}
-%* *
-%************************************************************************
-
-Rule to run the LML-ish \tr{ugen} utility.
-\begin{code}
-/* ToDo: cmp -> $(CMP) */
-
-#ifndef UgenTarget
-#define UgenTarget(fileroot) @@\
-ExtraStuffToBeVeryClean(fileroot.c fileroot.h fileroot.hs) @@\
-fileroot.c : fileroot.ugn @@\
- d=`dirname fileroot.ugn` ; f=`basename fileroot.ugn .ugn` ; \ @@\
- $(RM) fileroot.c fileroot.hs "$$d/U_$$f.hs" fileroot.h-SAVE @@\
- if [ -f fileroot.h ] ; then $(MV) -f fileroot.h fileroot.h-SAVE ; else exit 0 ; fi @@\
- $(UGEN) fileroot.ugn || ( $(RM) fileroot.h fileroot.c fileroot.hs; $(MV) -f fileroot.h-SAVE fileroot.h ) @@\
- if cmp -s fileroot.h-SAVE fileroot.h ; then \ @@\
- $(MV) -f fileroot.h-SAVE fileroot.h ; \ @@\
- else \ @@\
- chmod 444 fileroot.h fileroot.c fileroot.hs ; \ @@\
- fi @@\
- @$(RM) fileroot.h-SAVE @@\
- @d=`dirname fileroot.ugn` ; f=`basename fileroot.ugn .ugn` ; \ @@\
- $(MV) -f fileroot.hs "$$d/U_$$f.hs" @@\
- @@\
-fileroot.h : fileroot.c @@\
- @: /* no-op */
-#endif /* UgenTarget */
-\end{code}
-# line 8 "mkworld/only4-ghc.ljm"
+#if 0
+%************************************************************************
+%* *
+\section[mkworld-only4-ghc]{Extra things ``only for'' for the @ghc@ project}
+%* *
+%************************************************************************
+
+\begin{code}
+#endif /* 0 */
/* Project identification - name and version */
#ifndef ProjectName
#endif
/* ProjectVersion is something printable */
#ifndef ProjectVersion
-#define ProjectVersion 0.27
+#define ProjectVersion 2.01
#endif
/* A patchlevel change is something *very minor* */
#ifndef ProjectPatchLevel
#endif
/* GhcBuildeeVersion is something CPP-testable (ProjectVersion * 100) */
#ifndef GhcBuildeeVersion
-#define GhcBuildeeVersion 27
+#define GhcBuildeeVersion 201
#endif
-# line 29 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+Make variables that say where the source to main pieces of the system live:
+\begin{code}
+#endif /* 0 */
/* state of the source world */
GHC_DRIVERSRC = $(TOP)/ghc/driver
GHC_COMPILERSRC = $(TOP)/ghc/compiler
GHC_INCLUDESRC = $(TOP)/ghc/includes
GHC_UTILSRC = $(TOP)/ghc/utils
GHC_BOOKSRC = $(TOP)/ghc/book
-# line 41 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+Include definitions (usually to go with generated C):
+\begin{code}
+#endif /* 0 */
#ifndef GhcIncludesDir
#define GhcIncludesDir $(GHC_INCLUDESRC)
#endif
GHC_INCLUDES = GhcIncludesDir
-# line 51 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+A make variable that's occasionally very important: we use \tr{GHC_*}
+when we really mean GHC, rather than \tr{HC*}, which just means ``the
+standard Haskell compiler'' (whatever that is).
+\begin{code}
+#endif /* 0 */
#ifndef AllProjectsGhcOpts
#define AllProjectsGhcOpts /*none*/
#endif
GenerateOptionsMakeVars(GHC,OPTS,AllProjectsGhcOpts,PlatformGhcOpts,ProjectGhcOpts,SetupGhcOpts)
GHCFLAGS=$(GLUED_CPP_DEFINES) $(GLUED_GHC_OPTS)
-# line 95 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{What to build}
+%* *
+%************************************************************************
+
+%************************************************************************
+%* *
+\subsubsection{Include or leave out these individual ``features''}
+%* *
+%************************************************************************
+
+\begin{code}
+#endif /* 0 */
/* build York interpreter as well as Glasgow compiler
*/
#ifndef BuildYorkInterpreter
#ifndef UseSemantiqueStrictnessAnalyser
#define UseSemantiqueStrictnessAnalyser NO
#endif
-# line 116 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Installation: whether to, where to, what to}
+%* *
+%************************************************************************
+
+\begin{code}
+#endif /* 0 */
/* defaults for which pieces should be installed */
/* ToDo: possibly obsolete */
#ifndef DoInstallGHCSystem
#define DoInstallGHCSystem YES
#endif /* DoInstallGHCSystem */
-# line 124 "mkworld/only4-ghc.ljm"
+
/* ------------------------------------------------------------------ */
/* compiler-proper subsystem:
the lib/data bits are installed w/ a version number as well
INSTSCRIPTDIR_GHC = InstScriptDir_GHC
INSTLIBDIR_GHC = InstLibDir_GHC
INSTDATADIR_GHC = InstDataDir_GHC
-# line 183 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Configuring the driver}
+%* *
+%************************************************************************
+
+The driver script is the thing that glues the compilation system
+together. It needs to know what is/isn't included in the system,
+e.g., what garbage-collectors are catered for.
+
+Mkworld records the needed information in make variables (e.g.,
+\tr{$(GHC_HSCPP)}), and we then `msub' that into the driver (perl)
+script. Note: ALL configuration info should be HERE (not hacked into
+the script)!
+
+The first chunk of stuff here is mkworld boilerplate and probably
+doesn't need fiddling. Once we get into what C compiler(s) to use for
+compiling .hc files, what libraries are available, etc., there may be
+something to tweak (but not here -- in a `setup' file, please!) There
+are further comments where the tweakables begin...
+
+First, the driver can be installed under any old name; here's the default:
+\begin{code}
+#endif /* 0 */
#ifndef GhcDriverInstallName
#define GhcDriverInstallName ghc
#endif /* ! GhcDriverInstallName */
GHC_DRIVER_INST_NAME = GhcDriverInstallName
-# line 197 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Where to find the programs for the various phases}
+%* *
+%************************************************************************
+
+First, the driver itself:
+\begin{code}
+#endif /* 0 */
/* ghc: std driver for compilation system */
#ifndef GhcDriverCmd
#define GhcDriverCmd $(GHC_DRIVERSRC)/ghc
/* could be GHC_DRIVER, but GHC is its common name */
GHC = GhcDriverCmd
-# line 218 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+\tr{unlit}, to de-literatise a source file, is from the HBC
+distribution. See utils-ghc.
+
+\tr{hscpp}: runs C pre-processor but converts \tr{#line}s to Haskell pragmas;
+is platform-independent.
+\begin{code}
+#endif /* 0 */
#ifndef HsCppCmd
#define HsCppCmd $(GHC_HSCPPSRC)/hscpp
#endif
GHC_HSCPP = HsCppCmd $(ALLPROJ_CPP_DEFINES)
GHC_HSCPPSRC = $(GHC_UTILSRC)/hscpp
-# line 233 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+\tr{hsp}: std Haskell parser.
+\begin{code}
+#endif /* 0 */
#ifndef HsParserCmd
#define HsParserCmd $(GHC_HSPSRC)/hsp
#endif
GHC_HSP = HsParserCmd
GHC_HSPSRC = $(GHC_HSCSRC)
-# line 248 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+\tr{hsc}: std Haskell compiler.
+\begin{code}
+#endif /* 0 */
#ifndef HsCompilerCmd
#define HsCompilerCmd $(GHC_HSCSRC)/hsc
#endif
GHC_HSC = HsCompilerCmd
GHC_HSCSRC = $(GHC_COMPILERSRC)
-# line 263 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+\tr{SysMan}: PVM-controlling program for parallel Haskell.
+\begin{code}
+#endif /* 0 */
#ifndef SysManCmd
#define SysManCmd $(GHC_RUNTIMESRC)/gum/SysMan
#endif
GHC_SYSMAN = SysManCmd
GHC_SYSMANSRC = $(GHC_RUNTIMESRC)
-# line 318 "mkworld/only4-ghc.ljm"
+#if 0
+\end{code}
+
+For an ``assembler'' and a ``linker,'' the driver uses the same
+program as it used for C compilation; this means libraries and things
+are likely to be picked up correctly.
+
+%************************************************************************
+%* *
+\subsubsection{Stuff for the C-compiling phase in particular...}
+%* *
+%************************************************************************
+
+{\em High-level assembler}: C compiler with which to compile \tr{.hc} files.
+
+There are {\em three} things to set:
+\begin{enumerate}
+\item
+C compilers to use:
+\begin{itemize}
+\item
+compiler to use for ``debugging'' compilation (@GHC_DEBUG_HILEV_ASM@)
+\item
+compiler to use for ``optimising'' compiling (w/ regs magic, etc)
+(@GHC_OPT_HILEV_ASM@)
+This must be GCC; otherwise opt compiling must be turned off.
+\end{itemize}
+
+\item
+Whether or not you can do the ``optimising''-style compilation (set
+@GHC_GCC_IS_AVAILABLE@).
+\end{enumerate}
+
+For options that should always be applied {\em for this project},
+set the @ProjectGhcOpts@ variable...
+
+Similarly, for a particular {\em setup}, use @SetupGhcOpts@...
+
+%************************************************************************
+%* *
+\subsubsubsection{Which C compiler to use (GCC is best)}
+%* *
+%************************************************************************
+
+\begin{code}
+#endif /* 0 */
/* NON-OPTIMISING C COMPILATION: ==================================
We can use GCC 2.n for the non-optimising (normal) .hc C
#endif /* ! gcc */
#endif /* GhcDebuggingHighLevelAsmCmd */
GHC_DEBUG_HILEV_ASM = GhcDebuggingHighLevelAsmCmd
-# line 342 "mkworld/only4-ghc.ljm"
+
/* OPTIMISING C COMPILATION (regs, etc): ==========================
Must use GCC 2.n for this
#endif /* ! gcc */
#endif /* GhcOptHighLevelAsmCmd */
GHC_OPT_HILEV_ASM = GhcOptHighLevelAsmCmd
+#if 0
+\end{code}
+#endif /* 0 */
+++ /dev/null
-%************************************************************************
-%* *
-\section[mkworld-only4-ghc]{Extra things ``only for'' for the @ghc@ project}
-%* *
-%************************************************************************
-
-\begin{code}
-/* Project identification - name and version */
-
-#ifndef ProjectName
-#define ProjectName The Glorious Glasgow Haskell Compilation System
-#endif
-/* ProjectVersion is something printable */
-#ifndef ProjectVersion
-#define ProjectVersion 0.27
-#endif
-/* A patchlevel change is something *very minor* */
-#ifndef ProjectPatchLevel
-#define ProjectPatchLevel patchlevel 0
-#endif
-/* GhcBuildeeVersion is something CPP-testable (ProjectVersion * 100) */
-#ifndef GhcBuildeeVersion
-#define GhcBuildeeVersion 27
-#endif
-\end{code}
-
-Make variables that say where the source to main pieces of the system live:
-\begin{code}
-/* state of the source world */
-GHC_DRIVERSRC = $(TOP)/ghc/driver
-GHC_COMPILERSRC = $(TOP)/ghc/compiler
-GHC_RUNTIMESRC = $(TOP)/ghc/runtime
-GHC_LIBSRC = $(TOP)/ghc/lib
-GHC_INCLUDESRC = $(TOP)/ghc/includes
-GHC_UTILSRC = $(TOP)/ghc/utils
-GHC_BOOKSRC = $(TOP)/ghc/book
-\end{code}
-
-Include definitions (usually to go with generated C):
-\begin{code}
-#ifndef GhcIncludesDir
-#define GhcIncludesDir $(GHC_INCLUDESRC)
-#endif
-GHC_INCLUDES = GhcIncludesDir
-\end{code}
-
-A make variable that's occasionally very important: we use \tr{GHC_*}
-when we really mean GHC, rather than \tr{HC*}, which just means ``the
-standard Haskell compiler'' (whatever that is).
-\begin{code}
-#ifndef AllProjectsGhcOpts
-#define AllProjectsGhcOpts /*none*/
-#endif
-
-#ifndef PlatformGhcOpts
-#define PlatformGhcOpts /*none*/
-#endif
-
-#if HaskellCompilerType == HC_CHALMERS_HBC
-GHC_RTS_STYLE = 'hbc'
-#else
-# if HaskellCompilerType == HC_ROJEMO_NHC
-GHC_RTS_STYLE = 'ghc' /* wrong, but more likely to trigger something */
-# else
-GHC_RTS_STYLE = 'ghc'
-# endif
-#endif
-
-#ifndef ProjectGhcOpts
-#define ProjectGhcOpts -hi-diffs -dcore-lint -link-chk
-#endif /* ! ProjectGhcOpts */
-
-#ifndef SetupGhcOpts
-#define SetupGhcOpts /*none*/
-#endif
-
-GenerateOptionsMakeVars(GHC,OPTS,AllProjectsGhcOpts,PlatformGhcOpts,ProjectGhcOpts,SetupGhcOpts)
-
-GHCFLAGS=$(GLUED_CPP_DEFINES) $(GLUED_GHC_OPTS)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{What to build}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Include or leave out these individual ``features''}
-%* *
-%************************************************************************
-
-\begin{code}
-/* build York interpreter as well as Glasgow compiler
-*/
-#ifndef BuildYorkInterpreter
-#define BuildYorkInterpreter NO
-#endif
-
-/* incorporate Semantique strictness analyser into the compiler;
- it analyses, but the info generated is *UNUSED* :-(
- */
-#ifndef UseSemantiqueStrictnessAnalyser
-#define UseSemantiqueStrictnessAnalyser NO
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Installation: whether to, where to, what to}
-%* *
-%************************************************************************
-
-\begin{code}
-/* defaults for which pieces should be installed */
-/* ToDo: possibly obsolete */
-#ifndef DoInstallGHCSystem
-#define DoInstallGHCSystem YES
-#endif /* DoInstallGHCSystem */
-\end{code}
-
-\begin{code}
-/* ------------------------------------------------------------------ */
-/* compiler-proper subsystem:
- the lib/data bits are installed w/ a version number as well
-*/
-
-#ifndef InstBinDir_GHC
-# if AT_GLASGOW
-# define InstBinDir_GHC $(exec_prefix_GHC)/bin/`/usr/local/gnu/bin/hw_os`
-# else
-# define InstBinDir_GHC $(exec_prefix_GHC)/bin
-# endif
-#endif
-
-/* scripts are platform-independent */
-#ifndef InstScriptDir_GHC
-#define InstScriptDir_GHC $(exec_prefix_GHC)/bin
-#endif
-
-/* main "internally-used-by-GHC" stuff */
-#ifndef InstLibDir_GHC
-#define InstLibDir_GHC $(prefix_GHC)/lib/ghc/$(PROJECTVERSION)/$(HOSTPLATFORM)
-#endif
-
-/* "data" is defined (by WDP) to be platform-independent library stuff */
-#ifndef InstDataDir_GHC
-#define InstDataDir_GHC $(prefix_GHC)/lib/ghc/$(PROJECTVERSION)
-#endif
-
-prefix_GHC = InstRootDir_GHC /* set by configure */
-exec_prefix_GHC = InstBinRootDir_GHC /* ditto */
-INSTBINDIR_GHC = InstBinDir_GHC
-INSTSCRIPTDIR_GHC = InstScriptDir_GHC
-INSTLIBDIR_GHC = InstLibDir_GHC
-INSTDATADIR_GHC = InstDataDir_GHC
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Configuring the driver}
-%* *
-%************************************************************************
-
-The driver script is the thing that glues the compilation system
-together. It needs to know what is/isn't included in the system,
-e.g., what garbage-collectors are catered for.
-
-Mkworld records the needed information in make variables (e.g.,
-\tr{$(GHC_HSCPP)}), and we then `msub' that into the driver (perl)
-script. Note: ALL configuration info should be HERE (not hacked into
-the script)!
-
-The first chunk of stuff here is mkworld boilerplate and probably
-doesn't need fiddling. Once we get into what C compiler(s) to use for
-compiling .hc files, what libraries are available, etc., there may be
-something to tweak (but not here -- in a `setup' file, please!) There
-are further comments where the tweakables begin...
-
-First, the driver can be installed under any old name; here's the default:
-\begin{code}
-#ifndef GhcDriverInstallName
-#define GhcDriverInstallName ghc
-#endif /* ! GhcDriverInstallName */
-GHC_DRIVER_INST_NAME = GhcDriverInstallName
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Where to find the programs for the various phases}
-%* *
-%************************************************************************
-
-First, the driver itself:
-\begin{code}
-/* ghc: std driver for compilation system */
-#ifndef GhcDriverCmd
-#define GhcDriverCmd $(GHC_DRIVERSRC)/ghc
-#endif
-
-/* macro to make sure it has been built */
-#ifndef GhcDriverNeededHere
-#define GhcDriverNeededHere(target) \
-__SomeUtilNeededHere(target,$(GHC),$(GHC_DRIVERSRC),all)
-#endif
-
-/* could be GHC_DRIVER, but GHC is its common name */
-GHC = GhcDriverCmd
-\end{code}
-
-\tr{unlit}, to de-literatise a source file, is from the HBC
-distribution. See utils-ghc.
-
-\tr{hscpp}: runs C pre-processor but converts \tr{#line}s to Haskell pragmas;
-is platform-independent.
-\begin{code}
-#ifndef HsCppCmd
-#define HsCppCmd $(GHC_HSCPPSRC)/hscpp
-#endif
-
-#ifndef HsCppNeededHere
-#define HsCppNeededHere(target) \
-__SomeUtilNeededHere(target,$(GHC_HSCPP),$(GHC_HSCPPSRC),hscpp)
-#endif
-
-GHC_HSCPP = HsCppCmd $(ALLPROJ_CPP_DEFINES)
-GHC_HSCPPSRC = $(GHC_UTILSRC)/hscpp
-\end{code}
-
-\tr{hsp}: std Haskell parser.
-\begin{code}
-#ifndef HsParserCmd
-#define HsParserCmd $(GHC_HSPSRC)/hsp
-#endif
-
-#ifndef HsParserNeededHere
-#define HsParserNeededHere(target) \
-__SomeUtilNeededHere(target,$(GHC_HSP),$(GHC_HSPSRC),hsp)
-#endif /* HsParserNeededHere */
-
-GHC_HSP = HsParserCmd
-GHC_HSPSRC = $(GHC_HSCSRC)
-\end{code}
-
-\tr{hsc}: std Haskell compiler.
-\begin{code}
-#ifndef HsCompilerCmd
-#define HsCompilerCmd $(GHC_HSCSRC)/hsc
-#endif
-
-#ifndef HsCompilerNeededHere
-#define HsCompilerNeededHere(target) \
-__SomeUtilNeededHere(target,$(GHC_HSC),$(GHC_HSCSRC),hsc)
-#endif /* HsCompilerNeededHere */
-
-GHC_HSC = HsCompilerCmd
-GHC_HSCSRC = $(GHC_COMPILERSRC)
-\end{code}
-
-\tr{SysMan}: PVM-controlling program for parallel Haskell.
-\begin{code}
-#ifndef SysManCmd
-#define SysManCmd $(GHC_RUNTIMESRC)/gum/SysMan
-#endif
-
-#ifndef SysManNeededHere
-#define SysManNeededHere(target) \
-__SomeUtilNeededHere(target,$(GHC_SYSMAN),$(GHC_SYSMANSRC),gum/SysMan)
-#endif /* SysManNeededHere */
-
-GHC_SYSMAN = SysManCmd
-GHC_SYSMANSRC = $(GHC_RUNTIMESRC)
-\end{code}
-
-For an ``assembler'' and a ``linker,'' the driver uses the same
-program as it used for C compilation; this means libraries and things
-are likely to be picked up correctly.
-
-%************************************************************************
-%* *
-\subsubsection{Stuff for the C-compiling phase in particular...}
-%* *
-%************************************************************************
-
-{\em High-level assembler}: C compiler with which to compile \tr{.hc} files.
-
-There are {\em three} things to set:
-\begin{enumerate}
-\item
-C compilers to use:
-\begin{itemize}
-\item
-compiler to use for ``debugging'' compilation (@GHC_DEBUG_HILEV_ASM@)
-\item
-compiler to use for ``optimising'' compiling (w/ regs magic, etc)
-(@GHC_OPT_HILEV_ASM@)
-This must be GCC; otherwise opt compiling must be turned off.
-\end{itemize}
-
-\item
-Whether or not you can do the ``optimising''-style compilation (set
-@GHC_GCC_IS_AVAILABLE@).
-\end{enumerate}
-
-For options that should always be applied {\em for this project},
-set the @ProjectGhcOpts@ variable...
-
-Similarly, for a particular {\em setup}, use @SetupGhcOpts@...
-
-%************************************************************************
-%* *
-\subsubsubsection{Which C compiler to use (GCC is best)}
-%* *
-%************************************************************************
-
-\begin{code}
-/* NON-OPTIMISING C COMPILATION: ==================================
-
- We can use GCC 2.n for the non-optimising (normal) .hc C
- compilation [use it if we have it]
-*/
-#ifndef GhcUseGccForDebuggingAsm
-#if HaveGcc == YES
-#define GhcUseGccForDebuggingAsm YES
-#else
-#define GhcUseGccForDebuggingAsm NO
-#endif
-#endif
-
-#ifndef GhcDebuggingHighLevelAsmCmd
-#if GhcUseGccForDebuggingAsm == YES
-#define GhcDebuggingHighLevelAsmCmd WhatGccIsCalled
-#else
-#define GhcDebuggingHighLevelAsmCmd $(CC)
-#endif /* ! gcc */
-#endif /* GhcDebuggingHighLevelAsmCmd */
-GHC_DEBUG_HILEV_ASM = GhcDebuggingHighLevelAsmCmd
-\end{code}
-
-\begin{code}
-/* OPTIMISING C COMPILATION (regs, etc): ==========================
-
- Must use GCC 2.n for this
- compilation [OFF by default]
-*/
-/* We have GCC, which is necessary for optimising the Haskell
- compiler's C output.
-*/
-#ifndef GhcUseGccForOptAsm
-#if HaveGcc == YES
-#define GhcUseGccForOptAsm YES
-#else
-#define GhcUseGccForOptAsm NO
-#endif
-#endif
-
-#ifndef GhcOptHighLevelAsmCmd
-#if GhcUseGccForOptAsm == YES
-#define GhcOptHighLevelAsmCmd WhatGccIsCalled
-GHC_GCC_IS_AVAILABLE = 1
-#else
-GHC_GCC_IS_AVAILABLE = 0
-#endif /* ! gcc */
-#endif /* GhcOptHighLevelAsmCmd */
-GHC_OPT_HILEV_ASM = GhcOptHighLevelAsmCmd
-\end{code}
/* ================================================================
BUILDS stuff: main sequential ones
+
+ The configure script dumps all the what-builds-to-do info
+ into a file called "buildinfo.jm", in this directory. We
+ do it this way, rather than AC_SUBSTing the info into this file
+ because some sed's (notably OSF and maybe HP-UX) only allow
+ 99 commands (!!!), which is way too few if we want to do the
+ GhcBuild_ stuff as well as everything else. WDP 96/04
*/
-#define GhcBuild_normal @GhcBuild_normal@ /* profiled sequential */
+#include "buildinfo.jm"
+
+/* normal sequential */
#if GhcBuild_normal == YES
# define IfGhcBuild_normal(x) x
GHC_BUILD_FLAG_normal = -build-normal-defined
GHC_BUILD_FLAG_normal = -build-normal-not-defined
#endif
-#define GhcBuild_p @GhcBuild_p@ /* profiled sequential */
+/* profiled sequential */
#if GhcBuild_p == YES
# define IfGhcBuild_p(x) x
GHC_BUILD_FLAG_p = -build-p-defined
GHC_BUILD_FLAG_p = -build-p-not-defined
#endif
-#define GhcBuild_t @GhcBuild_t@ /* ticky-ticky "profiling" */
+/* ticky-ticky "profiling" (sequential) */
#if GhcBuild_t == YES
# define IfGhcBuild_t(x) x
GHC_BUILD_FLAG_t = -build-t-defined
GHC_BUILD_FLAG_t = -build-t-not-defined
#endif
-#define GhcBuild_u @GhcBuild_u@ /* unregisterized (most basic boot) */
+/* unregisterized (most basic boot) */
#if GhcBuild_u == YES
# define IfGhcBuild_u(x) x
GHC_BUILD_FLAG_u = -build-u-defined
/* === builds: concurrent and parallel ============================ */
-#define GhcBuild_mc @GhcBuild_mc@ /* concurrent */
+/* concurrent */
#if GhcBuild_mc == YES
# define IfGhcBuild_mc(x) x
GHC_BUILD_FLAG_mc = -build-mc-defined
GHC_BUILD_FLAG_mc = -build-mc-not-defined
#endif
-#define GhcBuild_mr @GhcBuild_mr@ /* profiled concurrent */
+/* profiled concurrent */
#if GhcBuild_mr == YES
# define IfGhcBuild_mr(x) x
GHC_BUILD_FLAG_mr = -build-mr-defined
GHC_BUILD_FLAG_mr = -build-mr-not-defined
#endif
-#define GhcBuild_mt @GhcBuild_mt@ /* ticky concurrent */
+/* ticky concurrent */
#if GhcBuild_mt == YES
# define IfGhcBuild_mt(x) x
GHC_BUILD_FLAG_mt = -build-mt-defined
GHC_BUILD_FLAG_mt = -build-mt-not-defined
#endif
-#define GhcBuild_mp @GhcBuild_mp@ /* parallel (GUM, PVM-based) */
+/* parallel (GUM, PVM-based) */
#if GhcBuild_mp == YES
# define IfGhcBuild_mp(x) x
GHC_BUILD_FLAG_mp = -build-mp-defined
GHC_BUILD_FLAG_mp = -build-mp-not-defined
#endif
-#define GhcBuild_mg @GhcBuild_mg@ /* GranSim */
+/* GranSim */
#if GhcBuild_mg == YES
# define IfGhcBuild_mg(x) x
GHC_BUILD_FLAG_mg = -build-mg-defined
but do not have any "fed back" options.
*/
-#define GhcBuild_2s @GhcBuild_2s@ /* sequential -- 2-space collector */
+/* sequential -- 2-space collector */
#if GhcBuild_2s == YES
# define IfGhcBuild_2s(x) x
GHC_BUILD_FLAG_2s = -gc-2s
GHC_BUILD_FLAG_2s = -build-2s-not-defined
#endif
-#define GhcBuild_1s @GhcBuild_1s@ /* sequential -- 1-space collector */
+/* sequential -- 1-space collector */
#if GhcBuild_1s == YES
# define IfGhcBuild_1s(x) x
GHC_BUILD_FLAG_1s = -gc-1s
GHC_BUILD_FLAG_1s = -build-1s-not-defined
#endif
-#define GhcBuild_du @GhcBuild_du@ /* sequential -- dual-mode collector */
+/* sequential -- dual-mode collector */
#if GhcBuild_du == YES
# define IfGhcBuild_du(x) x
GHC_BUILD_FLAG_du = -gc-du
/* === builds: "user ways" ======================================= */
-/* these had to be de-configure-ified because of 99-cmd-limit brain-dead seds */
-
-/* stuff for "update" paper; also use --enable-ticky */
-
-#define GhcBuild_a YES /*@GhcBuild_a@*/ /* "user way" a */
#if GhcBuild_a == YES
# define IfGhcBuild_a(x) x
-GHC_BUILD_FLAG_a = -SA-noUpdA
-GHC_BUILD_OPTS_a = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -Ofile /local/grasp/partain-other/performance/update/Ofile.SA-noUpdA
+GHC_BUILD_FLAG_a = -build-a-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_a = -build-a-not-defined-error
#else
# define IfGhcBuild_a(x) /**/
GHC_BUILD_FLAG_a = -build-a-not-defined
GHC_BUILD_OPTS_a = -build-a-not-defined-error
#endif
-#define GhcBuild_b YES /*@GhcBuild_b@*/ /* "user way" b */
#if GhcBuild_b == YES
# define IfGhcBuild_b(x) x
-GHC_BUILD_FLAG_b = -noSA-UpdA
-GHC_BUILD_OPTS_b = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -Ofile /local/grasp/partain-other/performance/update/Ofile.noSA-UpdA
+GHC_BUILD_FLAG_b = -build-b-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_b = -build-b-not-defined-error
#else
# define IfGhcBuild_b(x) /**/
GHC_BUILD_FLAG_b = -build-b-not-defined
GHC_BUILD_OPTS_b = -build-b-not-defined-error
#endif
-#define GhcBuild_c YES /*@GhcBuild_c@*/ /* "user way" c */
#if GhcBuild_c == YES
# define IfGhcBuild_c(x) x
-GHC_BUILD_FLAG_c = -noSA-noUpdA
-GHC_BUILD_OPTS_c = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -Ofile /local/grasp/partain-other/performance/update/Ofile.noSA-noUpdA
+GHC_BUILD_FLAG_c = -build-c-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_c = -build-c-not-defined-error
#else
# define IfGhcBuild_c(x) /**/
GHC_BUILD_FLAG_c = -build-c-not-defined
GHC_BUILD_OPTS_c = -build-c-not-defined-error
#endif
-#define GhcBuild_d NO/*YES*/ /*@GhcBuild_d@*/ /* "user way" d */
#if GhcBuild_d == YES
# define IfGhcBuild_d(x) x
-GHC_BUILD_FLAG_d = -regs-avail-2
-GHC_BUILD_OPTS_d = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -O -freturn-in-regs-threshold2
+GHC_BUILD_FLAG_d = -build-d-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_d = -build-d-not-defined-error
#else
# define IfGhcBuild_d(x) /**/
GHC_BUILD_FLAG_d = -build-d-not-defined
GHC_BUILD_OPTS_d = -build-d-not-defined-error
#endif
-#define GhcBuild_e NO/*YES*/ /*@GhcBuild_e@*/ /* "user way" e */
#if GhcBuild_e == YES
# define IfGhcBuild_e(x) x
-GHC_BUILD_FLAG_e = -regs-avail-3
-GHC_BUILD_OPTS_e = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -O -freturn-in-regs-threshold3
+GHC_BUILD_FLAG_e = -build-e-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_e = -build-e-not-defined-error
#else
# define IfGhcBuild_e(x) /**/
GHC_BUILD_FLAG_e = -build-e-not-defined
GHC_BUILD_OPTS_e = -build-e-not-defined-error
#endif
-#define GhcBuild_f NO/*YES*/ /*@GhcBuild_f@*/ /* "user way" f */
#if GhcBuild_f == YES
# define IfGhcBuild_f(x) x
-GHC_BUILD_FLAG_f = -regs-avail-4
-GHC_BUILD_OPTS_f = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -O -freturn-in-regs-threshold4
+GHC_BUILD_FLAG_f = -build-f-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_f = -build-f-not-defined-error
#else
# define IfGhcBuild_f(x) /**/
GHC_BUILD_FLAG_f = -build-f-not-defined
GHC_BUILD_OPTS_f = -build-f-not-defined-error
#endif
-#define GhcBuild_g NO/*YES*/ /*@GhcBuild_g@*/ /* "user way" g */
#if GhcBuild_g == YES
# define IfGhcBuild_g(x) x
-GHC_BUILD_FLAG_g = -regs-avail-5
-GHC_BUILD_OPTS_g = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -O -freturn-in-regs-threshold5
+GHC_BUILD_FLAG_g = -build-g-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_g = -build-g-not-defined-error
#else
# define IfGhcBuild_g(x) /**/
GHC_BUILD_FLAG_g = -build-g-not-defined
GHC_BUILD_OPTS_g = -build-g-not-defined-error
#endif
-#define GhcBuild_h YES /*@GhcBuild_h@*/ /* "user way" a */
#if GhcBuild_h == YES
# define IfGhcBuild_h(x) x
-GHC_BUILD_FLAG_h = -semi-tagged
-GHC_BUILD_OPTS_h = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -O -fsemi-tagging
+GHC_BUILD_FLAG_h = -build-h-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_h = -build-h-not-defined-error
#else
# define IfGhcBuild_h(x) /**/
GHC_BUILD_FLAG_h = -build-h-not-defined
GHC_BUILD_OPTS_h = -build-h-not-defined-error
#endif
-/* _b minus ticky */
-#define GhcBuild_i NO/*YES*/ /*@GhcBuild_i@*/ /* "user way" b */
#if GhcBuild_i == YES
# define IfGhcBuild_i(x) x
-GHC_BUILD_FLAG_i = -noSA-noFI2
-GHC_BUILD_OPTS_i = -Ofile /local/grasp/partain-other/performance/update/Ofile.noSA-noFI
+GHC_BUILD_FLAG_i = -build-i-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_i = -build-i-not-defined-error
#else
# define IfGhcBuild_i(x) /**/
GHC_BUILD_FLAG_i = -build-i-not-defined
GHC_BUILD_OPTS_i = -build-i-not-defined-error
#endif
-#define GhcBuild_j NO/*YES*/ /*@GhcBuild_j@*/ /* "user way" c */
#if GhcBuild_j == YES
# define IfGhcBuild_j(x) x
-GHC_BUILD_FLAG_j = -SA-noFI2
-GHC_BUILD_OPTS_j = -Ofile /local/grasp/partain-other/performance/update/Ofile.SA-noFI
+GHC_BUILD_FLAG_j = -build-j-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_j = -build-j-not-defined-error
#else
# define IfGhcBuild_j(x) /**/
GHC_BUILD_FLAG_j = -build-j-not-defined
GHC_BUILD_OPTS_j = -build-j-not-defined-error
#endif
-#define GhcBuild_k NO/*YES*/ /*@GhcBuild_k@*/ /* "user way" d */
#if GhcBuild_k == YES
# define IfGhcBuild_k(x) x
-GHC_BUILD_FLAG_k = -SA-noFL2
-GHC_BUILD_OPTS_k = -Ofile /local/grasp/partain-other/performance/update/Ofile.SA-noFL
+GHC_BUILD_FLAG_k = -build-k-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_k = -build-k-not-defined-error
#else
# define IfGhcBuild_k(x) /**/
GHC_BUILD_FLAG_k = -build-k-not-defined
GHC_BUILD_OPTS_k = -build-k-not-defined-error
#endif
-#define GhcBuild_l NO/*YES*/ /*@GhcBuild_l@*/ /* "user way" e */
#if GhcBuild_l == YES
# define IfGhcBuild_l(x) x
-GHC_BUILD_FLAG_l = -float-strict2
-GHC_BUILD_OPTS_l = -Ofile /local/grasp/partain-other/performance/update/Ofile.float-strict
+GHC_BUILD_FLAG_l = -build-l-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_l = -build-l-not-defined-error
#else
# define IfGhcBuild_l(x) /**/
GHC_BUILD_FLAG_l = -build-l-not-defined
GHC_BUILD_OPTS_l = -build-l-not-defined-error
#endif
-#define GhcBuild_m NO/*YES*/ /*@GhcBuild_m@*/ /* "user way" f */
#if GhcBuild_m == YES
# define IfGhcBuild_m(x) x
-GHC_BUILD_FLAG_m = -float-always2
-GHC_BUILD_OPTS_m = -Ofile /local/grasp/partain-other/performance/update/Ofile.float-always
+GHC_BUILD_FLAG_m = -build-m-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_m = -build-m-not-defined-error
#else
# define IfGhcBuild_m(x) /**/
GHC_BUILD_FLAG_m = -build-m-not-defined
GHC_BUILD_OPTS_m = -build-m-not-defined-error
#endif
-#define GhcBuild_n NO/*YES*/ /*@GhcBuild_n@*/ /* "user way" g */
#if GhcBuild_n == YES
# define IfGhcBuild_n(x) x
-GHC_BUILD_FLAG_n = -no-float2
-GHC_BUILD_OPTS_n = -Ofile /local/grasp/partain-other/performance/update/Ofile.no-float
+GHC_BUILD_FLAG_n = -build-n-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_n = -build-n-not-defined-error
#else
# define IfGhcBuild_n(x) /**/
GHC_BUILD_FLAG_n = -build-n-not-defined
GHC_BUILD_OPTS_n = -build-n-not-defined-error
#endif
-#define GhcBuild_A NO/*YES*/ /*@GhcBuild_A@*/ /* "user way" A */
+#if GhcBuild_o == YES
+# define IfGhcBuild_o(x) x
+GHC_BUILD_FLAG_o = -build-o-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_o = -build-o-not-defined-error
+#else
+# define IfGhcBuild_o(x) /**/
+GHC_BUILD_FLAG_o = -build-o-not-defined
+GHC_BUILD_OPTS_o = -build-o-not-defined-error
+#endif
+
#if GhcBuild_A == YES
# define IfGhcBuild_A(x) x
-GHC_BUILD_FLAG_A = -no-local-float
-GHC_BUILD_OPTS_A = -fticky-ticky -optcO-DTICKY_TICKY -debug \
- -Ofile /local/grasp/partain-other/performance/update/Ofile.no-local-float
+GHC_BUILD_FLAG_A = -build-A-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_A = -build-A-not-defined-error
#else
# define IfGhcBuild_A(x) /**/
GHC_BUILD_FLAG_A = -build-A-not-defined
GHC_BUILD_OPTS_A = -build-A-not-defined-error
#endif
-#define GhcBuild_B NO/*YES*/ /*@GhcBuild_B@*/ /* "user way" B */
#if GhcBuild_B == YES
# define IfGhcBuild_B(x) x
-GHC_BUILD_FLAG_B = -no-local-float2
-GHC_BUILD_OPTS_B = -Ofile /local/grasp/partain-other/performance/update/Ofile.no-local-float
+GHC_BUILD_FLAG_B = -build-B-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_B = -build-B-not-defined-error
#else
# define IfGhcBuild_B(x) /**/
GHC_BUILD_FLAG_B = -build-B-not-defined
GHC_BUILD_OPTS_B = -build-B-not-defined-error
#endif
-
-/* end of "floating" stuff */
-
-#define GhcBuild_o NO /*@GhcBuild_o@*/ /* "user way" o */
-#if GhcBuild_o == YES
-# define IfGhcBuild_o(x) x
-GHC_BUILD_FLAG_o = -build-o-not-defined /* >>>change here<<< if required */
-GHC_BUILD_OPTS_o = -build-o-not-defined-error
-#else
-# define IfGhcBuild_o(x) /**/
-GHC_BUILD_FLAG_o = -build-o-not-defined
-GHC_BUILD_OPTS_o = -build-o-not-defined-error
-#endif
-
/* ======= END OF BUILD INFO ==================================== */
-# line 11 "suffixes-ghc.ljm"
+#if 0
+%************************************************************************
+%* *
+\section[mkworld-suffix-ghc]{Suffix rules for @ghc@ project}
+%* *
+%************************************************************************
+
+The \tr{ghc} project tends to ask for specific suffix rules on
+a per-directory basis.
+
+\begin{code}
+#endif /* 0 */
#ifndef SuffixRules_WantStdOnes
#define SuffixRules_WantStdOnes NO
#endif
+
+#ifndef UnlitSuffixRule
+#define UnlitSuffixRule(beforesuff,aftersuff) @@\
+CAT2(beforesuff,aftersuff): @@\
+ $(RM) $@ @@\
+ $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 ) @@\
+ @chmod 444 $@
+#endif /* UnlitSuffixRule */
+
+#if 0
+\end{code}
+#endif /* 0 */
+++ /dev/null
-%************************************************************************
-%* *
-\section[mkworld-suffix-ghc]{Suffix rules for @ghc@ project}
-%* *
-%************************************************************************
-
-The \tr{ghc} project tends to ask for specific suffix rules on
-a per-directory basis.
-
-\begin{code}
-#ifndef SuffixRules_WantStdOnes
-#define SuffixRules_WantStdOnes NO
-#endif
-\end{code}
-# line 11 "utils-ghc.ljm"
+#if 0
+%************************************************************************
+%* *
+\section[mkworld-utils-ghc]{``Utilities'' stuff for @ghc@ project}
+%* *
+%************************************************************************
+
+It's become sorta traditional to change the project-wide
+Haskell-compiler options with @SetupHcOpts@ (rather than
+@ProjectHcOpts@).
+\begin{code}
+#endif /* 0 */
#if GhcWithHscOptimised == YES
#define __hsc_opt -O
#else
#ifndef ProjectJmakeDefines
#define ProjectJmakeDefines /*none*/
#endif
-# line 48 "utils-ghc.ljm"
+
#ifndef MkDependHSSrc
#define MkDependHSSrc $(GHC_UTILSRC)/mkdependHS
#endif
GHC_UNLIT = UnlitCmd
GHC_UNLITSRC = $(GHC_UTILSRC)/unlit
-# line 87 "utils-ghc.ljm"
+
#ifndef HsTagsSrc
#define HsTagsSrc $(GHC_UTILSRC)/hstags
#endif
+++ /dev/null
-%************************************************************************
-%* *
-\section[mkworld-utils-ghc]{``Utilities'' stuff for @ghc@ project}
-%* *
-%************************************************************************
-
-It's become sorta traditional to change the project-wide
-Haskell-compiler options with @SetupHcOpts@ (rather than
-@ProjectHcOpts@).
-\begin{code}
-#if GhcWithHscOptimised == YES
-#define __hsc_opt -O
-#else
-#define __hsc_opt /**/
-#endif
-
-#ifndef SetupHcOpts
-#if HaskellCompilerType == HC_CHALMERS_HBC
-#define SetupHcOpts __hsc_opt -fpbu
-#else
-#if HaskellCompilerType == HC_GLASGOW_GHC
-#define SetupHcOpts __hsc_opt -hi-diffs -link-chk
-#else
-#if HaskellCompilerType == HC_ROJEMO_NHC
-#define SetupHcOpts /*nothing*/
-#else
-#define SetupHcOpts /*nothing*/
-#endif
-#endif
-#endif
-#endif /* SetupHcOpts */
-
-#ifndef ProjectCcOpts
-#if HaveGcc == YES && UseGcc == YES
-/* can cope w/ "-g -O" ...; but leave out -g to avoid bloated libs */
-#define ProjectCcOpts -O /*-g*/
-#else
-#define ProjectCcOpts /*-g*/
-#endif /* Gcc whatnot */
-#endif /* ProjectCcOpts */
-
-#ifndef ProjectJmakeDefines
-#define ProjectJmakeDefines /*none*/
-#endif
-\end{code}
-
-\begin{code}
-#ifndef MkDependHSSrc
-#define MkDependHSSrc $(GHC_UTILSRC)/mkdependHS
-#endif
-
-#ifndef MkDependHSCmd
-#if defined(UseInstalledUtils)
-#define MkDependHSCmd mkdependHS
-#else
-#define MkDependHSCmd $(MKDEPENDHSSRC)/mkdependHS
-#endif
-#endif /* ! MkDependHSCmd */
-
-#ifndef MkDependHSNeededHere
-#if defined(UseInstalledUtils)
-#define MkDependHSNeededHere(target) /**/
-#else
-#define MkDependHSNeededHere(target) \
-__SomeUtilNeededHere(target,$(MKDEPENDHS),$(MKDEPENDHSSRC),mkdependHS)
-#endif /* UseInstalledUtils */
-#endif /* MkDependHSNeededHere */
-
-#ifndef UseInstalledUtils
-MKDEPENDHSSRC = MkDependHSSrc
-#endif
-
-#ifndef UnlitCmd
-#define UnlitCmd $(GHC_UNLITSRC)/unlit
-#endif
-
-#ifndef UnlitNeededHere
-#define UnlitNeededHere(target) \
-__SomeUtilNeededHere(target,$(GHC_UNLIT),$(GHC_UNLITSRC),unlit)
-#endif /* UnlitNeededHere */
-
-GHC_UNLIT = UnlitCmd
-GHC_UNLITSRC = $(GHC_UTILSRC)/unlit
-\end{code}
-
-\begin{code}
-#ifndef HsTagsSrc
-#define HsTagsSrc $(GHC_UTILSRC)/hstags
-#endif
-#if defined(UseInstalledUtils)
-#define HsTagsCmd hstags
-#else
-#define HsTagsCmd $(HSTAGSSRC)/hstags
-#endif
-
-#ifndef HsTagsNeededHere
-#if defined(UseInstalledUtils)
-#define HsTagsNeededHere(target) /**/
-#else
-#define HsTagsNeededHere(target) \
-__SomeUtilNeededHere(target,$(HSTAGS),$(HSTAGSSRC),hstags)
-#endif /* UseInstalledUtils */
-#endif /* HsTagsNeededHere */
-HSTAGS = HsTagsCmd
-#ifndef UseInstalledUtils
-HSTAGSSRC = HsTagsSrc
-#endif
-
-#ifndef AllProjectsHsTagsOpts
-#define AllProjectsHsTagsOpts /*none*/
-#endif
-#ifndef PlatformHsTagsOpts
-#define PlatformHsTagsOpts /*none*/
-#endif
-#ifndef ProjectHsTagsOpts
-#define ProjectHsTagsOpts /*none*/
-#endif
-#ifndef SetupHsTagsOpts
-#define SetupHsTagsOpts /*none*/
-#endif
-GenerateOptionsMakeVars(HSTAGS,OPTS,AllProjectsHsTagsOpts,PlatformHsTagsOpts,ProjectHsTagsOpts,SetupHsTagsOpts)
-HSTAGSFLAGS = $(GLUED_HSTAGS_OPTS)
-
-/* ugen: allegedly generally-useful util from LML distribution */
-#ifndef UgenCmd
-#if defined(UseInstalledUtils)
-#define UgenCmd ugen
-#else
-#define UgenCmd $(UGENSRC)/ugen
-#endif
-#endif
-#ifndef UgenNeededHere
-#if defined(UseInstalledUtils)
-#define UgenNeededHere(target) /**/
-#else
-#define UgenNeededHere(target) \
-__SomeUtilNeededHere(target,$(UGEN),$(UGENSRC),ugen)
-#endif /* ! UseInstalledUtils */
-#endif /* UgenNeededHere */
-UGEN = UgenCmd
-#ifndef UseInstalledUtils
-UGENSRC = $(GHC_UTILSRC)/ugen
-#endif
-\end{code}
GhcDriverNeededHere(depend all) /* we use its C-compiling know-how */
EtagsNeededHere(tags)
+UnlitNeededHere(depend)
/****************************************************************
* *
GHC_OPTS, just for fun.
*/
-GHC_OPTS = -O2-for-C $(EXTRA_HC_OPTS)
+GHC_OPTS = $(EXTRA_HC_OPTS)
/* per-build options: shared with libraries */
#define rts_or_lib(r,l) r
hooks/OutOfHeap.lc \
hooks/OutOfStk.lc \
hooks/OutOfVM.lc \
+ hooks/NoRunnableThrds.lc \
hooks/PatErrorHdr.lc \
hooks/TraceHooks.lc \
hooks/SizeHooks.lc \
+ hooks/InitEachPE.lc \
+ io/acceptSocket.lc \
+ io/bindSocket.lc \
io/closeFile.lc \
+ io/connectSocket.lc \
io/createDirectory.lc \
+ io/createSocket.lc \
io/env.lc \
io/errno.lc \
io/execvpe.lc \
io/getCurrentDirectory.lc \
io/getDirectoryContents.lc \
io/getLock.lc \
+ io/getPeerName.lc \
+ io/getSockName.lc \
io/inputReady.lc \
+ io/listenSocket.lc \
io/openFile.lc \
io/readFile.lc \
+ io/readDescriptor.lc \
io/removeDirectory.lc \
io/removeFile.lc \
io/renameDirectory.lc \
io/setBuffering.lc \
io/setCurrentDirectory.lc \
io/showTime.lc \
+ io/shutdownSocket.lc \
io/system.lc \
io/toClockSec.lc \
io/toLocalTime.lc \
io/toUTCTime.lc \
io/writeFile.lc \
+ io/writeDescriptor.lc \
main/Mallocs.lc \
prims/ByteOps.lc __readline_cfile
ExtraStuffToClean ( $(C_FILES) )
/* Literate-pgmming suffix rules used herein */
-LitSuffixRule(.lhc,.hc)
-LitSuffixRule(.lc,.c)
-LitSuffixRule(.lh,.h)
+UnlitSuffixRule(.lhc,.hc)
+UnlitSuffixRule(.lc,.c)
+UnlitSuffixRule(.lh,.h)
/****************************************************************
* *
****************************************************************/
RTS_OBJS_norm = $(RTS_LC:.lc=.o) $(RTS_LHC:.lhc=.o)
-RTS_OBJS_p = $(RTS_LC:.lc=_p.o) $(RTS_LHC:.lhc=_p.o)
-RTS_OBJS_t = $(RTS_LC:.lc=_t.o) $(RTS_LHC:.lhc=_t.o)
-RTS_OBJS_u = $(RTS_LC:.lc=_u.o) $(RTS_LHC:.lhc=_u.o)
-RTS_OBJS_mc = $(RTS_LC:.lc=_mc.o) $(RTS_LHC:.lhc=_mc.o)
-RTS_OBJS_mr = $(RTS_LC:.lc=_mr.o) $(RTS_LHC:.lhc=_mr.o)
-RTS_OBJS_mt = $(RTS_LC:.lc=_mt.o) $(RTS_LHC:.lhc=_mt.o)
-RTS_OBJS_mp = $(RTS_LC:.lc=_mp.o) $(RTS_LHC:.lhc=_mp.o)
-RTS_OBJS_mg = $(RTS_LC:.lc=_mg.o) $(RTS_LHC:.lhc=_mg.o)
-RTS_OBJS_2s = $(RTS_LC:.lc=_2s.o) $(RTS_LHC:.lhc=_2s.o)
-RTS_OBJS_1s = $(RTS_LC:.lc=_1s.o) $(RTS_LHC:.lhc=_1s.o)
-RTS_OBJS_du = $(RTS_LC:.lc=_du.o) $(RTS_LHC:.lhc=_du.o)
-RTS_OBJS_a = $(RTS_LC:.lc=_a.o) $(RTS_LHC:.lhc=_a.o)
-RTS_OBJS_b = $(RTS_LC:.lc=_b.o) $(RTS_LHC:.lhc=_b.o)
-RTS_OBJS_c = $(RTS_LC:.lc=_c.o) $(RTS_LHC:.lhc=_c.o)
-RTS_OBJS_d = $(RTS_LC:.lc=_d.o) $(RTS_LHC:.lhc=_d.o)
-RTS_OBJS_e = $(RTS_LC:.lc=_e.o) $(RTS_LHC:.lhc=_e.o)
-RTS_OBJS_f = $(RTS_LC:.lc=_f.o) $(RTS_LHC:.lhc=_f.o)
-RTS_OBJS_g = $(RTS_LC:.lc=_g.o) $(RTS_LHC:.lhc=_g.o)
-RTS_OBJS_h = $(RTS_LC:.lc=_h.o) $(RTS_LHC:.lhc=_h.o)
-RTS_OBJS_i = $(RTS_LC:.lc=_i.o) $(RTS_LHC:.lhc=_i.o)
-RTS_OBJS_j = $(RTS_LC:.lc=_j.o) $(RTS_LHC:.lhc=_j.o)
-RTS_OBJS_k = $(RTS_LC:.lc=_k.o) $(RTS_LHC:.lhc=_k.o)
-RTS_OBJS_l = $(RTS_LC:.lc=_l.o) $(RTS_LHC:.lhc=_l.o)
-RTS_OBJS_m = $(RTS_LC:.lc=_m.o) $(RTS_LHC:.lhc=_m.o)
-RTS_OBJS_n = $(RTS_LC:.lc=_n.o) $(RTS_LHC:.lhc=_n.o)
-RTS_OBJS_o = $(RTS_LC:.lc=_o.o) $(RTS_LHC:.lhc=_o.o)
-RTS_OBJS_A = $(RTS_LC:.lc=_A.o) $(RTS_LHC:.lhc=_A.o)
-RTS_OBJS_B = $(RTS_LC:.lc=_B.o) $(RTS_LHC:.lhc=_B.o)
+RTS_OBJS_p = $(RTS_LC:.lc=.p_o) $(RTS_LHC:.lhc=.p_o)
+RTS_OBJS_t = $(RTS_LC:.lc=.t_o) $(RTS_LHC:.lhc=.t_o)
+RTS_OBJS_u = $(RTS_LC:.lc=.u_o) $(RTS_LHC:.lhc=.u_o)
+RTS_OBJS_mc = $(RTS_LC:.lc=.mc_o) $(RTS_LHC:.lhc=.mc_o)
+RTS_OBJS_mr = $(RTS_LC:.lc=.mr_o) $(RTS_LHC:.lhc=.mr_o)
+RTS_OBJS_mt = $(RTS_LC:.lc=.mt_o) $(RTS_LHC:.lhc=.mt_o)
+RTS_OBJS_mp = $(RTS_LC:.lc=.mp_o) $(RTS_LHC:.lhc=.mp_o)
+RTS_OBJS_mg = $(RTS_LC:.lc=.mg_o) $(RTS_LHC:.lhc=.mg_o)
+RTS_OBJS_2s = $(RTS_LC:.lc=.2s_o) $(RTS_LHC:.lhc=.2s_o)
+RTS_OBJS_1s = $(RTS_LC:.lc=.1s_o) $(RTS_LHC:.lhc=.1s_o)
+RTS_OBJS_du = $(RTS_LC:.lc=.du_o) $(RTS_LHC:.lhc=.du_o)
+RTS_OBJS_a = $(RTS_LC:.lc=.a_o) $(RTS_LHC:.lhc=.a_o)
+RTS_OBJS_b = $(RTS_LC:.lc=.b_o) $(RTS_LHC:.lhc=.b_o)
+RTS_OBJS_c = $(RTS_LC:.lc=.c_o) $(RTS_LHC:.lhc=.c_o)
+RTS_OBJS_d = $(RTS_LC:.lc=.d_o) $(RTS_LHC:.lhc=.d_o)
+RTS_OBJS_e = $(RTS_LC:.lc=.e_o) $(RTS_LHC:.lhc=.e_o)
+RTS_OBJS_f = $(RTS_LC:.lc=.f_o) $(RTS_LHC:.lhc=.f_o)
+RTS_OBJS_g = $(RTS_LC:.lc=.g_o) $(RTS_LHC:.lhc=.g_o)
+RTS_OBJS_h = $(RTS_LC:.lc=.h_o) $(RTS_LHC:.lhc=.h_o)
+RTS_OBJS_i = $(RTS_LC:.lc=.i_o) $(RTS_LHC:.lhc=.i_o)
+RTS_OBJS_j = $(RTS_LC:.lc=.j_o) $(RTS_LHC:.lhc=.j_o)
+RTS_OBJS_k = $(RTS_LC:.lc=.k_o) $(RTS_LHC:.lhc=.k_o)
+RTS_OBJS_l = $(RTS_LC:.lc=.l_o) $(RTS_LHC:.lhc=.l_o)
+RTS_OBJS_m = $(RTS_LC:.lc=.m_o) $(RTS_LHC:.lhc=.m_o)
+RTS_OBJS_n = $(RTS_LC:.lc=.n_o) $(RTS_LHC:.lhc=.n_o)
+RTS_OBJS_o = $(RTS_LC:.lc=.o_o) $(RTS_LHC:.lhc=.o_o)
+RTS_OBJS_A = $(RTS_LC:.lc=.A_o) $(RTS_LHC:.lhc=.A_o)
+RTS_OBJS_B = $(RTS_LC:.lc=.B_o) $(RTS_LHC:.lhc=.B_o)
CLIB_OBJS = $(CLIB_LC:.lc=.o)
CompileClibishly(hooks/OutOfHeap,)
CompileClibishly(hooks/OutOfStk,)
CompileClibishly(hooks/OutOfVM,)
+CompileClibishly(hooks/NoRunnableThrds,)
CompileClibishly(hooks/PatErrorHdr,)
CompileClibishly(hooks/TraceHooks,)
CompileClibishly(hooks/SizeHooks,)
+CompileClibishly(hooks/InitEachPE,)
+CompileClibishly(io/acceptSocket,)
+CompileClibishly(io/bindSocket,)
CompileClibishly(io/closeFile,)
+CompileClibishly(io/connectSocket,)
+CompileClibishly(io/createSocket,)
CompileClibishly(io/createDirectory,)
CompileClibishly(io/env,)
CompileClibishly(io/errno,)
CompileClibishly(io/getCurrentDirectory,)
CompileClibishly(io/getDirectoryContents,)
CompileClibishly(io/getLock,)
+CompileClibishly(io/getPeerName,)
+CompileClibishly(io/getSockName,)
CompileClibishly(io/inputReady,)
+CompileClibishly(io/listenSocket,)
CompileClibishly(io/openFile,)
CompileClibishly(io/readFile,)
+CompileClibishly(io/readDescriptor,)
CompileClibishly(io/removeDirectory,)
CompileClibishly(io/removeFile,)
CompileClibishly(io/renameDirectory,)
CompileClibishly(io/setBuffering,)
CompileClibishly(io/setCurrentDirectory,)
CompileClibishly(io/showTime,)
+CompileClibishly(io/shutdownSocket,)
CompileClibishly(io/system,)
CompileClibishly(io/toClockSec,)
CompileClibishly(io/toLocalTime,)
CompileClibishly(io/toUTCTime,)
+CompileClibishly(io/writeDescriptor,)
CompileClibishly(io/writeFile,)
CompileClibishly(main/Mallocs,)
-CompileClibishly(main/TopClosure,) /* NB */
-CompileClibishly(main/TopClosure13,) /* ditto */
+CompileClibishly(main/TopClosure,)
CompileClibishly(prims/ByteOps,)
#if GhcWithReadline == YES
CompileClibishly(io/ghcReadline,)
#endif
-ExtraStuffToClean(main/TopClosure.o main/TopClosure13.o)
+ExtraStuffToClean(main/TopClosure.o)
-all :: main/TopClosure.o main/TopClosure13.o
+all :: main/TopClosure.o
-install :: main/TopClosure.o main/TopClosure13.o
+install :: main/TopClosure.o
$(INSTALL) -c $(INSTLIBFLAGS) main/TopClosure.o $(INSTLIBDIR_GHC)/TopClosure.o
- $(INSTALL) -c $(INSTLIBFLAGS) main/TopClosure13.o $(INSTLIBDIR_GHC)/TopClosure13.o
#if GhcBuild_mp == YES
# if solaris2_TARGET_OS
CompileRTSishly(c-as-asm/CallWrap_C,.c,)
CompileRTSishly(c-as-asm/FreeMallocPtr,.c,)
CompileRTSishly(c-as-asm/HpOverflow,.c,)
-CompileRTSishly(c-as-asm/PerformIO,.hc,-optcO-DIN_GHC_RTS=1)
+CompileRTSishly(c-as-asm/PerformIO,.hc,-optc-DIN_GHC_RTS=1)
CompileRTSishly(c-as-asm/StablePtr,.c,)
CompileRTSishly(c-as-asm/StablePtrOps,.c,)
CompileRTSishly(c-as-asm/StgDebug,.c,)
CompileRTSishly(c-as-asm/StgMiniInt,.c,)
-CompileRTSishly(gum/FetchMe,.hc,-optcO-DIN_GHC_RTS=1)
+CompileRTSishly(gum/FetchMe,.hc,-optc-DIN_GHC_RTS=1)
CompileRTSishly(gum/GlobAddr,.c,)
CompileRTSishly(gum/HLComms,.c,)
CompileRTSishly(gum/Hash,.c,)
CompileRTSishly(main/Select,.c,)
CompileRTSishly(main/Signals,.c,)
CompileRTSishly(main/StgOverflow,.c,)
-CompileRTSishly(main/StgStartup,.hc,-optcO-DIN_GHC_RTS=1)
-CompileRTSishly(main/StgThreads,.hc,-optcO-DIN_GHC_RTS=1)
-CompileRTSishly(main/StgUpdate,.hc,-optcO-DIN_GHC_RTS=1)
+CompileRTSishly(main/StgStartup,.hc,-optc-DIN_GHC_RTS=1)
+CompileRTSishly(main/StgThreads,.hc,-optc-DIN_GHC_RTS=1)
+CompileRTSishly(main/StgUpdate,.hc,-optc-DIN_GHC_RTS=1)
CompileRTSishly(main/Threads,.c,)
CompileRTSishly(main/RtsFlags,.c,)
CompileRTSishly(main/main,.c,)
CompileRTSishly(storage/SMextn,.c,)
CompileRTSishly(storage/SMgen,.c,)
CompileRTSishly(storage/SMinit,.c,)
-CompileRTSishly(storage/SMmark,.hc,-optcO-DIN_GHC_RTS=1 -optc-DMARK_REG_MAP)
+CompileRTSishly(storage/SMmark,.hc,-optc-DIN_GHC_RTS=1 -optc-DMARK_REG_MAP)
CompileRTSishly(storage/SMmarking,.c,)
CompileRTSishly(storage/SMscan,.c,)
CompileRTSishly(storage/SMscav,.c,)
CTagsTarget( regex/[a-z]*.c )
CDependTarget( $(RTS_LC) $($RTS_LHC) $(CLIB_LC) )
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-
-/*LitDocRootTargetWithNamedOutput(threadroot,lit,threadroot-standalone)*/
WRAPPER_RETURN(0)
}
-# endif
-
-# ifdef GRAN
-
+#if defined(GRAN)
void PerformReschedule_wrapper PROTO((W_, W_)) WRAPPER_NAME(PerformReschedule);
void PerformReschedule_wrapper(liveness, always_reenter_node)
W_ liveness;
WRAPPER_RETURN(0)
}
+/* Similar wrappers for all GrAnSim functions. */
+/* NB: These are normal functions, which don't call ReSchedule. So we just */
+/* have to safe/restore the registers. */
+
+void GranSimAllocate_wrapper PROTO((I_, P_, W_)) WRAPPER_NAME(GranSimAllocate);
+void GranSimAllocate_wrapper(n, node, liveness)
+I_ n;
+P_ node;
+W_ liveness;
+{
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(GranSimAllocate, ret_addr, ignore_me)
+#else
+ WRAPPER_SETUP(GranSimAllocate, ignore_me, ignore_me)
+#endif
+ GranSimAllocate(n, node, liveness);
+ WRAPPER_RETURN(0);
+}
+
+void GranSimUnallocate_wrapper PROTO((I_, P_, W_)) WRAPPER_NAME(GranSimUnallocate);
+void GranSimUnallocate_wrapper(n, node, liveness)
+I_ n;
+P_ node;
+W_ liveness;
+{
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(GranSimUnallocate, ret_addr, ignore_me)
+#else
+ WRAPPER_SETUP(GranSimUnallocate, ignore_me, ignore_me)
+#endif
+ GranSimUnallocate(n, node, liveness);
+ WRAPPER_RETURN(0);
+}
+
+void GranSimFetch_wrapper PROTO((P_)) WRAPPER_NAME(GranSimFetch);
+void GranSimFetch_wrapper(node)
+P_ node;
+{
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(GranSimFetch, ret_addr, ignore_me)
+#else
+ WRAPPER_SETUP(GranSimFetch, ignore_me, ignore_me)
+#endif
+ GranSimFetch(node);
+ WRAPPER_RETURN(0);
+}
+
+void GranSimExec_wrapper PROTO((W_, W_, W_, W_, W_)) WRAPPER_NAME(GranSimExec);
+void GranSimExec_wrapper(arith,branch,load,store,floats)
+W_ arith,branch,load,store,floats;
+{
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(GranSimExec, ret_addr, ignore_me)
+#else
+ WRAPPER_SETUP(GranSimExec, ignore_me, ignore_me)
+#endif
+ GranSimExec(arith,branch,load,store,floats);
+ WRAPPER_RETURN(0);
+}
+
# endif /* GRAN */
+# endif /* CONCURRENT */
+
/*
* In the threaded world, context switches may occur during one of these
* wrapped calls, and when we come back, our stack will have been trashed.
}
\end{code}
-Hack for -UGRAN setup. % HWL
-
-\begin{code}
-#ifndef GRAN
-void PerformReschedule_wrapper PROTO((W_, W_));
-void PerformReschedule_wrapper(liveness, always_reenter_node)
- W_ liveness;
- W_ always_reenter_node;
-{ }
-#endif
-\end{code}
\section[freemallocptr]{FreeMallocPtr}
+ToDo: obliterate -- SOF
+
This is the default definition of FreeMallocPtr. It is a file by
itself so that the linker can choose to ignore it if it has already
seen a definition of FreeMallocPtr.
#include "rtsdefs.h"
void
-FreeMallocPtr (mp)
- StgMallocPtr mp;
+FreeMallocPtr (StgForeignObj mp)
{
fprintf(stderr, "Error: No deallocation routine for MallocPtr %lx\n", (W_) mp);
EXIT(EXIT_FAILURE);
extern smInfo StorageMgrInfo;
extern void PrintTickyInfo(STG_NO_ARGS);
-#if defined(GRAN_CHECK) && defined(GRAN)
-extern W_ debug;
-#endif
-
/* the real work is done by this function --- see wrappers at end */
void
}
# endif
# if defined(GRAN)
- ReSchedule(9 /*i.e. error; was SAME_THREAD*/);
+ ReSchedule(SAME_THREAD); /* ToDo: Check HWL */
# else
ReSchedule(1);
# endif
}
- /* Don't use SET_CCC, because we don't want to bump the sub_scc_count */
# if defined(PROFILING)
Save_CCC = CCC;
# endif
# if defined(PAR)
- CCC = (CostCentre)STATIC_CC_REF(CC_GC);
- CCC->scc_count++;
+ SET_CCC_RTS(CC_GC,0,1); /* without the sub_scc_count++ */
# endif
ReallyPerformThreadGC(reqsize, do_full_collection);
#else /* !CONCURRENT */
# if defined(PROFILING)
- /* Don't use SET_CCC, because we don't want to bump the sub_scc_count */
Save_CCC = CCC;
- CCC = (CostCentre)STATIC_CC_REF(CC_GC);
- CCC->scc_count++;
+ SET_CCC_RTS(CC_GC,0,1); /* without the sub_scc_count++ */
# endif
/* root saving ---------------------------------- */
void
PerformReschedule(liveness, always_reenter_node)
W_ liveness;
- W_ always_reenter_node;
+ rtsBool always_reenter_node;
{
- I_ need_to_reschedule;
+ rtsBool need_to_reschedule;
/* Reset the global NeedToReSchedule --
this is used only to communicate the fact that we should schedule
a new thread rather than the existing one following a fetch.
+ if (RTSflags.GranFlags.Light) {
+ Yield(liveness);
+ }
+
+ ASSERT(!RTSflags.GranFlags.Light);
*/
+
need_to_reschedule = NeedToReSchedule;
NeedToReSchedule = rtsFalse;
if (always_reenter_node) {
/* Avoid infinite loops at the same context switch */
- if ((TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) &&
- !need_to_reschedule) {
- TSO_SWITCH(CurrentTSO) = NULL;
+ if (/* (TSO_SWITCH(CurrentTSO) == TSO_PC2(CurrentTSO)) || */
+ (!need_to_reschedule &&
+ CurrentTime[CurrentProc]<EndOfTimeSlice &&
+ (TimeOfNextEvent==0 || TimeOfNextEvent>=CurrentTime[CurrentProc])
+ || IgnoreEvents
+ )) {
+ /* TSO_SWITCH(CurrentTSO) = NULL; */
return;
}
/* Set up to re-enter Node, so as to be sure it's really there. */
ASSERT(liveness & LIVENESS_R1);
- TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
+ /* TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO); */
TSO_PC2(CurrentTSO) = (void *) EnterNodeCode;
}
/* We're in a GC callWrapper, so the thread state is safe */
TSO_ARG1(CurrentTSO) = 0;
TSO_PC1(CurrentTSO) = EnterNodeCode;
- ReSchedule( (need_to_reschedule && !DoReScheduleOnFetch) ?
+ ReSchedule( (need_to_reschedule &&
+ !RTSflags.GranFlags.DoReScheduleOnFetch &&
+ !RTSflags.GranFlags.Light) ?
CHANGE_THREAD : SAME_THREAD );
+ /* In a block-on-fetch setup we must not use SAME_THREAD since that */
+ /* would continue the fetching TSO, which is still at the head of the */
+ /* of the threadq */
+ /* GrAnSim-Light always uses SAME_THREAD */
}
#endif
}
#endif /* !PAR */
-#ifdef CONCURRENT
+#if defined(CONCURRENT)
# if defined(GRAN)
+# if defined(DEPTH_FIRST_PRUNING)
+
/* Jim's spark pools are very similar to our processors, except that
he uses a hard-wired constant. This would be a mistake for us,
since we won't always need this many pools.
{
sparkq spark, prev, next;
I_ proc, pool, prunedSparks;
+ I_ tot_sparks[MAX_PROC], total_sparks = 0, tot = 0;;
- for(proc=0; proc<max_proc; ++proc) {
- prev = NULL;
-
- for (pool = 0; pool < SPARK_POOLS; pool++) {
- prunedSparks=0;
-
- for(spark = PendingSparksHd[proc][pool];
- spark != NULL;
- spark = next) {
- next = SPARK_NEXT(spark);
-
- /* HACK! The first clause should actually never happen HWL */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x40 )
+ fprintf(stderr,"Pruning (depth-first) spark roots for GC ...\n");
+# endif
- if ( (SPARK_NODE(spark) == NULL) ||
- (SPARK_NODE(spark) == Nil_closure) ) {
+ for(proc=0; proc<RTSflags.GranFlags.proc; ++proc) {
+ tot_sparks[proc] = 0;
+ prev = NULL;
+
+ for (pool = 0; pool < SPARK_POOLS; pool++) {
+ prunedSparks=0;
+
+ for(spark = PendingSparksHd[proc][pool];
+ spark != NULL;
+ spark = next) {
+ next = SPARK_NEXT(spark);
+
+ if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0)
+ {
+ if ( RTSflags.GcFlags.giveStats )
+ if (i==ADVISORY_POOL) {
+ tot_sparks[proc]++;
+ tot++;
+ }
+
+ /* HACK! This clause should actually never happen HWL */
+ if ( (SPARK_NODE(spark) == NULL) ||
+ (SPARK_NODE(spark) == Prelude_Z91Z93_closure) ) {
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Nil_closure\n", spark);
+ if ( RTSflags.GcFlags.giveStats &&
+ (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Prelude_Z91Z93_closure\n", spark);
# endif
- if (do_qp_prof)
- QP_Event0(threadId++, SPARK_NODE(spark));
-
- if(do_sp_profile)
- DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark);
-
- DisposeSpark(spark);
- prunedSparks++;
- }
- else if (SHOULD_SPARK(SPARK_NODE(spark))) {
- /* Keep it */
- if (prev == NULL)
- PendingSparksHd[proc][pool] = spark;
- else
- SPARK_NEXT(prev) = spark;
- SPARK_PREV(spark) = prev;
- prev = spark;
- } else {
- if (do_qp_prof)
- QP_Event0(threadId++, SPARK_NODE(spark));
-
- if(do_sp_profile)
- DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark);
-
- DisposeSpark(spark);
- prunedSparks++;
- }
+ /* prune it below */
+ }
+ else if (SHOULD_SPARK(SPARK_NODE(spark))) {
+ /* Keep it */
+ if (prev == NULL)
+ PendingSparksHd[proc][pool] = spark;
+ else
+ SPARK_NEXT(prev) = spark;
+ SPARK_PREV(spark) = prev;
+ prev = spark;
+ continue;
+ }
+ }
+
+ /* By now we know that the spark has to be pruned */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ /* DumpRawGranEvent(CURRENT_PROC,SP_PRUNED,(W_) spark); */
+ DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
+ Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
+
+ DisposeSpark(spark);
+ prunedSparks++;
} /* forall spark ... */
if (prev == NULL)
PendingSparksHd[proc][pool] = NULL;
else
SPARK_NEXT(prev) = NULL;
PendingSparksTl[proc][pool] = prev;
- if (prunedSparks>0)
- fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %ld in PruneSparks\n",
- prunedSparks,(W_) MAX_SPARKS,proc);
+ if ( (RTSflags.GcFlags.giveStats) &&
+ (RTSflags.GranFlags.debug & 0x1000) &&
+ (prunedSparks>0) )
+ fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu sparks (_NS flag!) on proc %d (pool %d) in PruneSparks\n",
+ prunedSparks,proc,pool);
} /* forall pool ... */
} /* forall proc ... */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GcFlags.giveStats ) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Spark statistics (after pruning) (total sparks: %d; before pruning: %d):",
+ tot,total_sparks);
+ for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
+ if (proc % 4 == 0) fprintf(RTSflags.GcFlags.statsFile,"\n> ");
+ fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
+ }
+ fprintf(RTSflags.GcFlags.statsFile,".\n");
+ }
+# endif
+}
+
+# else /* !DEPTH_FIRST_PRUNING */
+
+/* Auxiliary functions that are used in the GranSim version of PruneSparks */
+
+static W_
+arr_and(W_ arr[], I_ max)
+{
+ I_ i;
+ W_ res;
+
+ /* Doesn't work with max==0; but then, many things don't work in this */
+ /* special case. */
+ for (i=1, res = arr[0]; i<max; i++)
+ res &= arr[i];
+
+ return (res);
+}
+
+static W_
+arr_max(W_ arr[], I_ max)
+{
+ I_ i;
+ W_ res;
+
+ /* Doesn't work with max==0; but then, many things don't work in this */
+ /* special case. */
+ for (i=1, res = arr[0]; i<max; i++)
+ res = (arr[i]>res) ? arr[i] : res;
+
+ return (res);
+}
+
+/* In case of an excessive number of sparks, depth first pruning is a Bad */
+/* Idea as we might end up with all remaining sparks on processor 0 and */
+/* none on the other processors. So, this version uses breadth first */
+/* pruning. -- HWL */
+
+void
+PruneSparks(STG_NO_ARGS)
+{
+ sparkq spark, prev,
+ prev_spark[MAX_PROC][SPARK_POOLS],
+ curr_spark[MAX_PROC][SPARK_POOLS];
+ PROC proc;
+ W_ allProcs = 0,
+ endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
+ I_ pool, total_sparks=0,
+ prunedSparks[MAX_PROC][SPARK_POOLS];
+ I_ tot_sparks[MAX_PROC], tot = 0;;
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x40 )
+ fprintf(stderr,"Pruning (breadth-first) sparks for GC ...\n");
+# endif
+
+ /* Init */
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ allProcs |= PE_NUMBER(proc);
+ tot_sparks[proc] = 0;
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ prev_spark[proc][pool] = NULL;
+ curr_spark[proc][pool] = PendingSparksHd[proc][pool];
+ prunedSparks[proc][pool] = 0;
+ endQueues[pool] = 0;
+ finishedQueues[pool] = 0;
+ }
+ }
+
+ /* Breadth first pruning */
+ do {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ spark = curr_spark[proc][pool];
+ prev = prev_spark[proc][pool];
+
+ if (spark == NULL) { /* at the end of the queue already? */
+ if (! (endQueues[pool] & PE_NUMBER(proc)) ) {
+ endQueues[pool] |= PE_NUMBER(proc);
+ if (prev==NULL)
+ PendingSparksHd[proc][pool] = NULL;
+ else
+ SPARK_NEXT(prev) = NULL;
+ PendingSparksTl[proc][pool] = prev;
+ }
+ continue;
+ }
+
+ /* HACK! This clause should actually never happen HWL */
+ if ( (SPARK_NODE(spark) == NULL) ||
+ (SPARK_NODE(spark) == Prelude_Z91Z93_closure) ) {
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GcFlags.giveStats &&
+ (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Prelude_Z91Z93_closure\n", spark);
+# endif
+ /* prune it below */
+ } else if (SHOULD_SPARK(SPARK_NODE(spark))) {
+ if(++total_sparks <= MAX_SPARKS || MAX_SPARKS == 0) {
+ if ( RTSflags.GcFlags.giveStats )
+ if (pool==ADVISORY_POOL) {
+ tot_sparks[proc]++;
+ tot++;
+ }
+
+ /* Keep it */
+ if (prev_spark[proc][pool] == NULL)
+ PendingSparksHd[proc][pool] = spark;
+ else
+ SPARK_NEXT(prev_spark[proc][pool]) = spark;
+ SPARK_PREV(spark) = prev_spark[proc][pool];
+ prev_spark[proc][pool] = spark;
+ curr_spark[proc][pool] = SPARK_NEXT(spark);
+ continue;
+ } else { /* total_sparks > MAX_SPARKS */
+ /* Sparkq will end before the current spark */
+ if (prev == NULL)
+ PendingSparksHd[proc][pool] = NULL;
+ else
+ SPARK_NEXT(prev) = NULL;
+ PendingSparksTl[proc][pool] = prev;
+ endQueues[pool] |= PE_NUMBER(proc);
+ continue;
+ }
+ }
+
+ /* By now we know that the spark has to be pruned */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
+ Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
+
+ SPARK_NODE(spark) = Prelude_Z91Z93_closure;
+ curr_spark[proc][pool] = SPARK_NEXT(spark);
+ prunedSparks[proc][pool]++;
+ DisposeSpark(spark);
+ } /* forall pool ... */
+ } /* forall proc ... */
+ } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
+
+ /* Prune all sparks on all processor starting with */
+ /* curr_spark[proc][pool]. */
+
+ do {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ spark = curr_spark[proc][pool];
+
+ if ( spark != NULL ) {
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,0,SP_PRUNED,
+ Prelude_Z91Z93_closure,SPARK_NODE(spark),0);
+
+ SPARK_NODE(spark) = Prelude_Z91Z93_closure;
+ curr_spark[proc][pool] = SPARK_NEXT(spark);
+
+ prunedSparks[proc][pool]++;
+ DisposeSpark(spark);
+ } else {
+ finishedQueues[pool] |= PE_NUMBER(proc);
+ }
+ } /* forall pool ... */
+ } /* forall proc ... */
+ } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
+
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x1000) {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][pool]>0)) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
+ prunedSparks[proc][pool],proc,pool);
+ }
+ }
+ }
+
+ if ( RTSflags.GcFlags.giveStats ) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Spark statistics (after discarding) (total sparks = %d):",tot);
+ for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
+ if (proc % 4 == 0)
+ fprintf(RTSflags.GcFlags.statsFile,"\n> ");
+ fprintf(RTSflags.GcFlags.statsFile,
+ "\tPE %d: %d ",proc,tot_sparks[proc]);
+ }
+ fprintf(RTSflags.GcFlags.statsFile,".\n");
+ }
+ }
+# endif
}
+# endif /* !DEPTH_FIRST_PRUNING */
+
# else /* !GRAN */
void
} else {
if (DO_QP_PROF)
QP_Event0(threadId++, *old);
-# ifdef PAR
- if(do_sp_profile)
- DumpSparkGranEvent(SP_PRUNED, threadId++);
+# if 0
+ /* ToDo: Fix log entries for pruned sparks in GUM */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ /* DumpSparkGranEvent(SP_PRUNED, threadId++);*/
+ DumpGranEvent(SP_PRUNED,Prelude_Z91Z93_closure);
+ ^^^^^^^^^^^ should be a TSO
# endif
}
}
a garbage collection.
\begin{code}
+extern void handleTimerExpiry PROTO((rtsBool));
void
ReallyPerformThreadGC(reqsize, do_full_collection)
Will & Phil 95/10
*/
- for(stack = AvailableStack; stack != Nil_closure; stack = next) {
+ for(stack = AvailableStack; stack != Prelude_Z91Z93_closure; stack = next) {
next = STKO_LINK(stack);
FREEZE_MUT_HDR(stack, ImMutArrayOfPtrs_info);
MUTUPLE_CLOSURE_SIZE(stack) = MUTUPLE_VHS;
}
- for(tso = AvailableTSO; tso != Nil_closure; tso = next) {
+ for(tso = AvailableTSO; tso != Prelude_Z91Z93_closure; tso = next) {
next = TSO_LINK(tso);
FREEZE_MUT_HDR(tso, ImMutArrayOfPtrs_info);
MUTUPLE_CLOSURE_SIZE(tso) = MUTUPLE_VHS;
}
- AvailableStack = AvailableTSO = Nil_closure;
+ AvailableStack = AvailableTSO = Prelude_Z91Z93_closure;
PruneSparks();
# if defined(GRAN)
- for(proc = 0; proc < max_proc; ++proc) {
-
-# if 0
- for(i = 0; i < SPARK_POOLS; i++) {
- if (PendingSparksHd[proc][i] != NULL)
- StorageMgrInfo.roots[num_ptr_roots++] = PendingSparksHd[proc][i];
- if ( PendingSparksTl[proc][i] != NULL)
- StorageMgrInfo.roots[num_ptr_roots++] = PendingSparksTl[proc][i];
- }
-# endif /* 0 */
-
+ /* Store head and tail of runnable lists as roots for GC */
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
- num_ptr_roots,proc,RunnableThreadsHd[proc]);
-# endif
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
+ num_ptr_roots,proc,RunnableThreadsHd[proc]);
+# endif
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[proc];
+ StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsHd[proc];
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
- num_ptr_roots,proc,RunnableThreadsTl[proc]);
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
+ num_ptr_roots,proc,RunnableThreadsTl[proc]);
# endif
- StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
+ StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
+
} /* forall proc ... */
- num_ptr_roots = SaveSparkRoots(num_ptr_roots);
- num_ptr_roots = SaveEventRoots(num_ptr_roots);
+ /* This is now done as part of collectHeap (see ../storage dir) */
+ /* num_ptr_roots = SaveSparkRoots(num_ptr_roots); */
+ /* num_ptr_roots = SaveEventRoots(num_ptr_roots); */
# else /* !GRAN */
StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsHd;
StorageMgrInfo.roots[num_ptr_roots++] = WaitingThreadsTl;
-# endif /* !GRAN */
+# endif /* GRAN */
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
fprintf(RTSflags.GcFlags.statsFile,"Saving CurrentTSO %d -- 0x%lx\n",
num_ptr_roots,CurrentTSO);
# endif
StorageMgrInfo.roots[num_ptr_roots++] = PendingFetches;
# endif
+# ifndef PAR
+ StorageMgrInfo.roots[num_ptr_roots++] = StorageMgrInfo.StablePointerTable;
+# endif
+
StorageMgrInfo.rootno = num_ptr_roots;
blockUserSignals();
-
+
+ /* For VTALRM timer ticks to be handled correctly, we need to record that
+ we are now about to enter GC, delaying the handling of timer expiry
+ for delayed threads till after the GC.
+ */
+ handleTimerExpiry(rtsFalse);
+
+ /* ====> The REAL THING happens here */
if (collectHeap(reqsize, &StorageMgrInfo, do_full_collection) != GC_SUCCESS) {
OutOfHeapHook(reqsize * sizeof(W_)); /*msg*/
/* must do all the restoring exactly backwards to the storing! */
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Restoring CurrentTSO %d -- new: 0x%lx\n",
- num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Restoring CurrentTSO %d -- new: 0x%lx\n",
+ num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
+# endif
+
+# ifndef PAR
+ StorageMgrInfo.StablePointerTable = StorageMgrInfo.roots[--num_ptr_roots];
# endif
# ifdef PAR
# else /* GRAN */
- num_ptr_roots = RestoreEventRoots(num_ptr_roots);
- num_ptr_roots = RestoreSparkRoots(num_ptr_roots);
-
- /* NB: PROC is unsigned datatype i.e. (PROC)-1 == (PROC)255 */
+ /* num_ptr_roots = RestoreEventRoots(num_ptr_roots); */
+ /* num_ptr_roots = RestoreSparkRoots(num_ptr_roots); */
- for(proc = max_proc - 1; (proc >= 0) && (proc < max_proc) ; --proc) {
+ /* NB: PROC is unsigned datatype i.e. (PROC)-1 > 0 ! */
+ for(proc = RTSflags.GranFlags.proc - 1;
+ (proc >= 0) && (proc < RTSflags.GranFlags.proc) ;
+ --proc) {
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
# endif
- RunnableThreadsTl[proc] = StorageMgrInfo.roots[--num_ptr_roots];
+ RunnableThreadsTl[proc] = StorageMgrInfo.roots[--num_ptr_roots];
# if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
- num_ptr_roots,proc,StorageMgrInfo.roots[num_ptr_roots]);
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
+ num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
# endif
- RunnableThreadsHd[proc] = StorageMgrInfo.roots[--num_ptr_roots];
-
-# if 0
- for(i = SPARK_POOLS - 1; i >= 0; --i) {
- if (PendingSparksTl[proc][i] != NULL)
- PendingSparksTl[proc][i] = StorageMgrInfo.roots[--num_ptr_roots];
- if (PendingSparksHd[proc][i] != NULL)
- PendingSparksHd[proc][i] = StorageMgrInfo.roots[--num_ptr_roots];
- }
-# endif
- }
+ RunnableThreadsHd[proc] = StorageMgrInfo.roots[--num_ptr_roots];
+ } /* forall proc ... */
# endif /* GRAN */
/* Semantics of GC ensures that a block of `reqsize' is now available */
SAVE_Hp += reqsize;
+ /* Activate the handling of entries on the WaitingThreads queue again */
+ handleTimerExpiry(rtsTrue);
+
unblockUserSignals();
}
\begin{code}
-#if defined(CONCURRENT) && !defined(GRAN)
+#if 0 /* defined(CONCURRENT) && !defined(GRAN) */
void
PerformReschedule(W_ liveness, W_ always_reenter_node)
{ }
\section[Stable-Pointers]{Creation and use of Stable Pointers}
\begin{code}
-#ifndef PAR
+#if !defined(PAR)
#include "rtsdefs.h"
\end{code}
is even more dated.)
\begin{code}
-#ifndef PAR
+#if !defined(PAR)
#include "rtsdefs.h"
}
\end{code}
-Despite the file name, we have two small malloc ptr operation - not
+Despite the file name, we have a little ForeignObj operation here - not
worth putting in a file by itself.
\begin{code}
StgInt
-eqMallocPtr(p1, p2)
- StgMallocPtr p1;
- StgMallocPtr p2;
+eqForeignObj(p1, p2)
+ StgForeignObj p1;
+ StgForeignObj p2;
{
return (p1 == p2);
}
DEBUG_BSTACK(lines) Print "lines" lines of the B Stack
DEBUG_UPDATES(frames) Print "frames" update frames
DEBUG_REGS() Print register values
- DEBUG_MP() Print the MallocPtr Lists
+ DEBUG_FO() Print the ForeignObj Lists
DEBUG_TSO(tso) (CONCURRENT) Print a Thread State Object
Not yet implemented:
/* There are no others in SMInfoTables.lh 11/5/94 ADR*/
default:
- printf("Invalid/unknown info type %d\n", INFO_TYPE(INFO_PTR(node)));
+ printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(node)));
break;
}
}
case INFO_INTLIKE_TYPE:
if (DEBUG_details > 1) printf("INTLIKE ");
- printf("%d",INTLIKE_VALUE(closure));
+ printf("%ld",INTLIKE_VALUE(closure));
break;
case INFO_BH_TYPE:
/* There are no others in SMInfoTables.lh 11/5/94 ADR*/
default:
- printf("Invalid/unknown info type %d\n", INFO_TYPE(INFO_PTR(closure)));
+ printf("Invalid/unknown info type %ld\n", INFO_TYPE(INFO_PTR(closure)));
break;
}
}
{
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
+
+ int i;
+ I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
+
+ printf("Dump of the Address Stack (SpA = 0x%lx, SuA = 0x%lx)\n", SpA, SuA);
+
+ for( i = 0; i < size; ++i ) {
+ printIndentation(1);
+ printf("SpA[%d] (0x%08lx):", i, SpA + AREL(i));
+ printClosure((P_)*(SpA + AREL(i)), 2, weight);
+ printf("\n");
+ }
+}
+
+void
+DEBUG_PrintB( int depth, int weight )
+{
+ PP_ SpA = SAVE_SpA;
P_ SpB = SAVE_SpB;
P_ SuB = SAVE_SuB;
+
+ I_ i;
+ I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
+
+ P_ updateFramePtr;
+ I_ update_count;
+
+ printf("Dump of the Value Stack (SpB = 0x%lx, SuB = 0x%lx)\n", SpB, SuB);
+
+ updateFramePtr = SuB;
+ update_count = 0;
+ i = 0;
+ while (i < size) {
+ if (updateFramePtr == SpB + BREL(i)) {
+
+ printIndentation(1);
+ printf("SpB[%ld] (0x%08lx): UpdateFrame[%d](",
+ i,
+ updateFramePtr,
+ update_count
+ );
+ printName( (P_) *(SpB + BREL(i)) );
+ printf(", UF[%d] (= SpB[%ld]), SpA[%ld], ",
+ update_count+1,
+ SUBTRACT_B_STK(SpB, GRAB_SuB(updateFramePtr)),
+ SUBTRACT_A_STK(SpA, GRAB_SuA(updateFramePtr))
+ );
+ printAddress( GRAB_UPDATEE(updateFramePtr) );
+ printf(")\n");
+
+ printIndentation(2);
+ printClosure( GRAB_UPDATEE(updateFramePtr), 3, weight );
+ printf("\n");
+
+ updateFramePtr = GRAB_SuB(updateFramePtr);
+ update_count = update_count + 1;
+
+ /* ToDo: GhcConstants.lh reveals that there are two other sizes possible */
+ i = i + STD_UF_SIZE;
+ } else {
+ printIndentation(1);
+ printf("SpB[%ld] (0x%08lx): ", i, SpB + BREL(i) );
+ printName((P_) *(SpB + BREL(i)) );
+ printf("\n");
+ i = i + 1;
+ }
+ }
+}
+
+#else /* CONCURRENT */
+
+static int
+minimum(int a, int b)
+{
+ if (a < b) {
+ return a;
+ } else {
+ return b;
+ }
+}
+
+void
+DEBUG_PrintA( int depth, int weight )
+{
+ P_ stko = SAVE_StkO;
+ PP_ SpA = STKO_SpA(stko);
+ PP_ SuA = STKO_SuA(stko);
+ P_ SpB = STKO_SpB(stko);
+ P_ SuB = STKO_SuB(stko);
P_ Hp = SAVE_Hp;
int i;
- I_ size = minimum(depth, SUBTRACT_A_STK(SpA, stackInfo.botA)+1);
+ I_ size = minimum(depth, SUBTRACT_A_STK(SpA, STKO_ASTK_BOT(stko))+1);
printf("Dump of the Address Stack (SpA = 0x%x, SuA = 0x%x)\n", SpA, SuA);
void
DEBUG_PrintB( int depth, int weight )
{
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
- P_ SuB = SAVE_SuB;
+ P_ stko = SAVE_StkO;
+ PP_ SpA = STKO_SpA(stko);
+ PP_ SuA = STKO_SuA(stko);
+ P_ SpB = STKO_SpB(stko);
+ P_ SuB = STKO_SuB(stko);
P_ Hp = SAVE_Hp;
I_ i;
- I_ size = minimum(depth, SUBTRACT_B_STK(SpB, stackInfo.botB)+1);
+ I_ size = minimum(depth, SUBTRACT_B_STK(SpB, STKO_BSTK_BOT(stko))+1);
P_ updateFramePtr;
I_ update_count;
}
}
}
+
#endif /* not CONCURRENT */
\end{code}
P_ SpB = STKO_SpB(SAVE_StkO);
P_ SuB = STKO_SuB(SAVE_StkO);
#else
- PP_ SpA = SAVE_SpA;
- PP_ SuA = SAVE_SuA;
- P_ SpB = SAVE_SpB;
P_ SuB = SAVE_SuB;
#endif
- P_ Hp = SAVE_Hp;
int depth = 1; /* There's always at least one stack */
for( i = size-1; i >= 0; --i ) {
printIndentation( indentation );
- printf("A[%ld][%ld]", depth, i);
+ printf("A[%ld][%d]", depth, i);
if (DEBUG_details > 1) printf(" (0x%08lx) ", SpA + AREL(i) );
printf("=");
printClosure( *(SpA + AREL(i)), indentation+2, weight );
for( i = size-1; i >= 0; --i) {
printIndentation( indentation );
- printf("B[%ld][%ld]", depth, i);
+ printf("B[%d][%d]", depth, i);
if (DEBUG_details > 1) printf(" (0x%08lx) ", SpB + BREL(i) );
printf("=");
printAddress( (P_) *(SpB + BREL(i)) );
ip_type, info_ptr,
(W_) ENTRY_CODE(info_ptr), (W_) UPDATE_CODE(info_ptr));
fprintf(stderr,
- "Tag: %d; Type: %d; Size: %lu; Ptrs: %lu\n\n",
+ "Tag: %ld; Type: %ld; Size: %lu; Ptrs: %lu\n\n",
INFO_TAG(info_ptr), INFO_TYPE(info_ptr),
INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
#if defined(GRIP)
#ifndef CONCURRENT
void
-DEBUG_MP()
+DEBUG_FO()
{
StgPtr mp;
StgInt i;
- fprintf(stderr,"MallocPtrList\n\n");
+ fprintf(stderr,"ForeignObjList\n\n");
- for(mp = StorageMgrInfo.MallocPtrList;
+ for(mp = StorageMgrInfo.ForeignObjList;
mp != NULL;
- mp = MallocPtr_CLOSURE_LINK(mp)) {
+ mp = ForeignObj_CLOSURE_LINK(mp)) {
- fprintf(stderr, "MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
+ fprintf(stderr,
+ "ForeignObjPtr(0x%lx) = 0x%lx, finaliser: 0x%lx\n",
+ mp,
+ ForeignObj_CLOSURE_DATA(mp),
+ ForeignObj_CLOSURE_FINALISER(mp));
/*
DEBUG_PRINT_NODE(mp);
}
# if defined(GCap) || defined(GCgn)
- fprintf(stderr,"\nOldMallocPtr List\n\n");
+ fprintf(stderr,"\nOldForeignObj List\n\n");
- for(mp = StorageMgrInfo.OldMallocPtrList;
+ for(mp = StorageMgrInfo.OldForeignObjList;
mp != NULL;
- mp = MallocPtr_CLOSURE_LINK(mp)) {
+ mp = ForeignObj_CLOSURE_LINK(mp)) {
- fprintf(stderr, " MallocPtr(0x%lx) = 0x%lx\n", mp, MallocPtr_CLOSURE_DATA(mp));
+ fprintf(stderr,
+ "ForeignObj(0x%lx) = 0x%lx, finaliser: 0x%lx\n",
+ mp,
+ ForeignObj_CLOSURE_DATA(mp),
+ ForeignObj_CLOSURE_FINALISER(mp));
/*
DEBUG_PRINT_NODE(mp);
*/
}
fprintf(stderr, "\n");
}
+
+
#endif /* not concurrent */
/*
#endif /* concurrent */
\end{code}
+
+%****************************************************************************
+%
+\subsection[GrAnSim-debug]{Debugging routines for GrAnSim}
+%
+%****************************************************************************
+
+Debugging routines, mainly for GrAnSim.
+They should really be in a separate file.
+There is some code duplication of above routines in here, I'm afraid.
+
+As a naming convention all GrAnSim debugging functions start with @G_@.
+The shorthand forms defined at the end start only with @G@.
+
+\begin{code}
+#if defined(GRAN) && defined(GRAN_CHECK)
+
+#define NULL_REG_MAP /* Not threaded */
+/* #include "stgdefs.h" */
+
+char *
+info_hdr_type(info_ptr)
+P_ info_ptr;
+{
+#if ! defined(PAR) && !defined(GRAN)
+ switch (INFO_TAG(info_ptr))
+ {
+ case INFO_OTHER_TAG:
+ return("OTHER_TAG");
+/* case INFO_IND_TAG:
+ return("IND_TAG");
+*/ default:
+ return("TAG<n>");
+ }
+#else /* PAR */
+ switch(BASE_INFO_TYPE(info_ptr))
+ {
+ case INFO_SPEC_TYPE:
+ return("SPEC");
+
+ case INFO_GEN_TYPE:
+ return("GEN");
+
+ case INFO_DYN_TYPE:
+ return("DYN");
+
+ case INFO_TUPLE_TYPE:
+ return("TUPLE");
+
+ case INFO_DATA_TYPE:
+ return("DATA");
+
+ case INFO_MUTUPLE_TYPE:
+ return("MUTUPLE");
+
+ case INFO_IMMUTUPLE_TYPE:
+ return("IMMUTUPLE");
+
+ case INFO_STATIC_TYPE:
+ return("STATIC");
+
+ case INFO_CONST_TYPE:
+ return("CONST");
+
+ case INFO_CHARLIKE_TYPE:
+ return("CHAR");
+
+ case INFO_INTLIKE_TYPE:
+ return("INT");
+
+ case INFO_BH_TYPE:
+ return("BHOLE");
+
+ case INFO_BQ_TYPE:
+ return("BQ");
+
+ case INFO_IND_TYPE:
+ return("IND");
+
+ case INFO_CAF_TYPE:
+ return("CAF");
+
+ case INFO_FM_TYPE:
+ return("FETCHME");
+
+ case INFO_TSO_TYPE:
+ return("TSO");
+
+ case INFO_STKO_TYPE:
+ return("STKO");
+
+ case INFO_SPEC_RBH_TYPE:
+ return("SPEC_RBH");
+
+ case INFO_GEN_RBH_TYPE:
+ return("GEN_RBH");
+
+ case INFO_BF_TYPE:
+ return("BF");
+
+ case INFO_INTERNAL_TYPE:
+ return("INTERNAL");
+
+ default:
+ fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
+ return("??");
+ }
+#endif /* PAR */
+}
+
+char *
+info_type(infoptr, str)
+P_ infoptr;
+char *str;
+{
+ strcpy(str,"");
+ if ( IS_NF(infoptr) )
+ strcat(str,"|_NF ");
+ else if ( IS_MUTABLE(infoptr) )
+ strcat(str,"|_MU");
+ else if ( IS_STATIC(infoptr) )
+ strcat(str,"|_ST");
+ else if ( IS_UPDATABLE(infoptr) )
+ strcat(str,"|_UP");
+ else if ( IS_BIG_MOTHER(infoptr) )
+ strcat(str,"|_BM");
+ else if ( IS_BLACK_HOLE(infoptr) )
+ strcat(str,"|_BH");
+ else if ( IS_INDIRECTION(infoptr) )
+ strcat(str,"|_IN");
+ else if ( IS_THUNK(infoptr) )
+ strcat(str,"|_TH");
+
+ return(str);
+}
+
+/*
+@var_hdr_size@ computes the size of the variable header for a closure.
+*/
+
+I_
+var_hdr_size(node)
+P_ node;
+{
+ switch(INFO_TYPE(INFO_PTR(node)))
+ {
+ case INFO_SPEC_U_TYPE: return(0); /* by decree */
+ case INFO_SPEC_N_TYPE: return(0);
+ case INFO_GEN_U_TYPE: return(GEN_VHS);
+ case INFO_GEN_N_TYPE: return(GEN_VHS);
+ case INFO_DYN_TYPE: return(DYN_VHS);
+ /*
+ case INFO_DYN_TYPE_N: return(DYN_VHS);
+ case INFO_DYN_TYPE_U: return(DYN_VHS);
+ */
+ case INFO_TUPLE_TYPE: return(TUPLE_VHS);
+ case INFO_DATA_TYPE: return(DATA_VHS);
+ case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS);
+ case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
+ case INFO_STATIC_TYPE: return(STATIC_VHS);
+ case INFO_CONST_TYPE: return(0);
+ case INFO_CHARLIKE_TYPE: return(0);
+ case INFO_INTLIKE_TYPE: return(0);
+ case INFO_BH_TYPE: return(0);
+ case INFO_IND_TYPE: return(0);
+ case INFO_CAF_TYPE: return(0);
+ case INFO_FETCHME_TYPE: return(0);
+ case INFO_BQ_TYPE: return(0);
+ /*
+ case INFO_BQENT_TYPE: return(0);
+ */
+ case INFO_TSO_TYPE: return(TSO_VHS);
+ case INFO_STKO_TYPE: return(STKO_VHS);
+ default:
+ fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
+ INFO_TYPE(INFO_PTR(node)));
+ return(0);
+ }
+}
+
+
+/* Determine the size and number of pointers for this kind of closure */
+void
+size_and_ptrs(node,size,ptrs)
+P_ node;
+W_ *size, *ptrs;
+{
+ switch(INFO_TYPE(INFO_PTR(node)))
+ {
+ case INFO_SPEC_U_TYPE:
+ case INFO_SPEC_N_TYPE:
+ *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */
+ *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */
+ /*
+ *size = SPEC_CLOSURE_SIZE(node);
+ *ptrs = SPEC_CLOSURE_NoPTRS(node);
+ */
+ break;
+
+ case INFO_GEN_U_TYPE:
+ case INFO_GEN_N_TYPE:
+ *size = GEN_CLOSURE_SIZE(node);
+ *ptrs = GEN_CLOSURE_NoPTRS(node);
+ break;
+
+ /*
+ case INFO_DYN_TYPE_U:
+ case INFO_DYN_TYPE_N:
+ */
+ case INFO_DYN_TYPE:
+ *size = DYN_CLOSURE_SIZE(node);
+ *ptrs = DYN_CLOSURE_NoPTRS(node);
+ break;
+
+ case INFO_TUPLE_TYPE:
+ *size = TUPLE_CLOSURE_SIZE(node);
+ *ptrs = TUPLE_CLOSURE_NoPTRS(node);
+ break;
+
+ case INFO_DATA_TYPE:
+ *size = DATA_CLOSURE_SIZE(node);
+ *ptrs = DATA_CLOSURE_NoPTRS(node);
+ break;
+
+ case INFO_IND_TYPE:
+ *size = IND_CLOSURE_SIZE(node);
+ *ptrs = IND_CLOSURE_NoPTRS(node);
+ break;
+
+/* ToDo: more (WDP) */
+
+ /* Don't know about the others */
+ default:
+ *size = *ptrs = 0;
+ break;
+ }
+}
+
+void
+G_PRINT_NODE(node)
+P_ node;
+{
+ P_ info_ptr, bqe; /* = INFO_PTR(node); */
+ I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0;
+ char info_hdr_ty[80], info_ty[80];
+
+ if (node==NULL) {
+ fprintf(stderr,"NULL\n");
+ return;
+ } else if (node==Prelude_Z91Z93_closure) {
+ fprintf(stderr,"Prelude_Z91Z93_closure\n");
+ return;
+ } else if (node==MUT_NOT_LINKED) {
+ fprintf(stderr,"MUT_NOT_LINKED\n");
+ return;
+ }
+ /* size_and_ptrs(node,&size,&ptrs); */
+ info_ptr = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_hdr_ty);
+
+ /* vhs = var_hdr_size(node); */
+ info_type(info_ptr,info_ty);
+
+ fprintf(stderr,"Node: 0x%lx", (W_) node);
+
+#if defined(PAR)
+ fprintf(stderr," [GA: 0x%lx]",GA(node));
+#endif
+
+#if defined(USE_COST_CENTRES)
+ fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
+#endif
+
+#if defined(GRAN)
+ fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
+#endif
+
+ if (info_ptr==INFO_TSO_TYPE)
+ fprintf(stderr," TSO: 0x%lx (%x) IP: 0x%lx (%s), type %s \n ",
+ node, TSO_ID(node), info_ptr, info_hdr_ty, info_ty);
+ else
+ fprintf(stderr," IP: 0x%lx (%s), type %s \n VHS: %d, size: %ld, ptrs:%ld, nonptrs: %ld\n ",
+ info_ptr,info_hdr_ty,info_ty,vhs,size,ptrs,nonptrs);
+
+ /* For now, we ignore the variable header */
+
+ fprintf(stderr," Ptrs: ");
+ for(i=0; i < ptrs; ++i)
+ {
+ if ( (i+1) % 6 == 0)
+ fprintf(stderr,"\n ");
+ fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
+ };
+
+ fprintf(stderr," Data: ");
+ for(i=0; i < nonptrs; ++i)
+ {
+ if( (i+1) % 6 == 0)
+ fprintf(stderr,"\n ");
+ fprintf(stderr," %lu[D]",*(node+_FHS+vhs+ptrs+i));
+ }
+ fprintf(stderr, "\n");
+
+
+ switch (INFO_TYPE(info_ptr))
+ {
+ case INFO_TSO_TYPE:
+ fprintf(stderr,"\n TSO_LINK: %#lx",
+ TSO_LINK(node));
+ break;
+
+ case INFO_BH_TYPE:
+ case INFO_BQ_TYPE:
+ bqe = (P_)BQ_ENTRIES(node);
+ fprintf(stderr," BQ of %#lx: ", node);
+ PRINT_BQ(bqe);
+ break;
+ case INFO_FMBQ_TYPE:
+ printf("Panic: found FMBQ Infotable in GrAnSim system.\n");
+ break;
+ case INFO_SPEC_RBH_TYPE:
+ bqe = (P_)SPEC_RBH_BQ(node);
+ fprintf(stderr," BQ of %#lx: ", node);
+ PRINT_BQ(bqe);
+ break;
+ case INFO_GEN_RBH_TYPE:
+ bqe = (P_)GEN_RBH_BQ(node);
+ fprintf(stderr," BQ of %#lx: ", node);
+ PRINT_BQ(bqe);
+ break;
+ }
+}
+
+void
+G_PPN(node) /* Extracted from PrintPacket in Pack.lc */
+P_ node;
+{
+ P_ info ;
+ I_ size = 0, ptrs = 0, nonptrs = 0, i, vhs = 0, locn = 0;
+ char info_type[80];
+
+ /* size_and_ptrs(node,&size,&ptrs); */
+ info = get_closure_info(node, &size, &ptrs, &nonptrs, &vhs, info_type);
+
+ if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
+ size = ptrs = nonptrs = vhs = 0;
+
+ if (IS_THUNK(info)) {
+ if (IS_UPDATABLE(info))
+ fputs("SHARED ", stderr);
+ else
+ fputs("UNSHARED ", stderr);
+ }
+ if (IS_BLACK_HOLE(info)) {
+ fputs("BLACK HOLE\n", stderr);
+ } else {
+ /* Fixed header */
+ fprintf(stderr, "(%s) FH [%#lx", info_type, node[locn++]);
+ for (i = 1; i < FIXED_HS; i++)
+ fprintf(stderr, " %#lx", node[locn++]);
+
+ /* Variable header */
+ if (vhs > 0) {
+ fprintf(stderr, "] VH [%#lx", node[locn++]);
+
+ for (i = 1; i < vhs; i++)
+ fprintf(stderr, " %#lx", node[locn++]);
+ }
+
+ fprintf(stderr, "] PTRS %u", ptrs);
+
+ /* Non-pointers */
+ if (nonptrs > 0) {
+ fprintf(stderr, " NPTRS [%#lx", node[locn++]);
+
+ for (i = 1; i < nonptrs; i++)
+ fprintf(stderr, " %#lx", node[locn++]);
+
+ putc(']', stderr);
+ }
+ putc('\n', stderr);
+ }
+
+ }
+
+#define INFO_MASK 0x80000000
+
+void
+G_MUT(node,verbose) /* Print mutables list starting with node */
+P_ node;
+{
+ if (verbose & 0x1) { G_PRINT_NODE(node); fprintf(stderr, "\n"); }
+ else fprintf(stderr, "0x%#lx, ", node);
+
+ if (node==NULL || node==Prelude_Z91Z93_closure || node==MUT_NOT_LINKED) {
+ return;
+ }
+ G_MUT(MUT_LINK(node), verbose);
+}
+
+
+void
+G_TREE(node)
+P_ node;
+{
+ W_ size = 0, ptrs = 0, i, vhs = 0;
+
+ /* Don't print cycles */
+ if((INFO_PTR(node) & INFO_MASK) != 0)
+ return;
+
+ size_and_ptrs(node,&size,&ptrs);
+ vhs = var_hdr_size(node);
+
+ G_PRINT_NODE(node);
+ fprintf(stderr, "\n");
+
+ /* Mark the node -- may be dangerous */
+ INFO_PTR(node) |= INFO_MASK;
+
+ for(i = 0; i < ptrs; ++i)
+ G_TREE((P_)node[i+vhs+_FHS]);
+
+ /* Unmark the node */
+ INFO_PTR(node) &= ~INFO_MASK;
+}
+
+
+void
+G_INFO_TABLE(node)
+P_ node;
+{
+ P_ info_ptr = (P_)INFO_PTR(node);
+ char *ip_type = info_hdr_type(info_ptr);
+
+ fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
+ ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
+
+ if (IS_THUNK(info_ptr) && IS_UPDATABLE(info_ptr) ) {
+ fprintf(stderr," RBH InfoPtr: %#lx\n",
+ RBH_INFOPTR(info_ptr));
+ }
+
+#if defined(PAR)
+ fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
+#endif
+
+#if defined(USE_COST_CENTRES)
+ fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr));
+#endif
+
+#if defined(_INFO_COPYING)
+ fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
+ INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
+#endif
+
+#if defined(_INFO_COMPACTING)
+ fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
+ (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
+ fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
+ (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
+#if 0 /* avoid INFO_TYPE */
+ if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
+ fprintf(stderr,"plus specialised code\n");
+ else
+ fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
+#endif /* 0 */
+#endif /* _INFO_COMPACTING */
+}
+#endif /* GRAN */
+
+\end{code}
+
+The remaining debugging routines are more or less specific for GrAnSim.
+
+\begin{code}
+#if defined(GRAN) && defined(GRAN_CHECK)
+void
+G_CURR_THREADQ(verbose)
+I_ verbose;
+{
+ fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
+ G_THREADQ(ThreadQueueHd, verbose);
+}
+
+void
+G_THREADQ(closure, verbose)
+P_ closure;
+I_ verbose;
+{
+ P_ x;
+
+ fprintf(stderr,"Thread Queue: ");
+ for (x=closure; x!=Prelude_Z91Z93_closure; x=TSO_LINK(x))
+ if (verbose)
+ G_TSO(x,0);
+ else
+ fprintf(stderr," %#lx",x);
+
+ if (closure==Prelude_Z91Z93_closure)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+/* Check with Threads.lh */
+static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
+
+void
+G_TSO(closure,verbose)
+P_ closure;
+I_ verbose;
+{
+
+ if (closure==Prelude_Z91Z93_closure) {
+ fprintf(stderr,"TSO at %#lx is Prelude_Z91Z93_closure!\n");
+ return;
+ }
+
+ if ( verbose & 0x08 ) { /* short info */
+ fprintf(stderr,"[TSO @ %#lx, PE %d]: Name: %#lx, Id: %#lx, Link: %#lx\n",
+ closure,where_is(closure),
+ TSO_NAME(closure),TSO_ID(closure),TSO_LINK(closure));
+ return;
+ }
+
+ fprintf(stderr,"TSO at %#lx has the following contents:\n",
+ closure);
+
+ fprintf(stderr,"> Name: \t%#lx",TSO_NAME(closure));
+ fprintf(stderr,"\tLink: \t%#lx\n",TSO_LINK(closure));
+ fprintf(stderr,"> Id: \t%#lx",TSO_ID(closure));
+#if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GranFlags.debug & 0x10)
+ fprintf(stderr,"\tType: \t%s %s\n",
+ type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
+ (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
+ else
+ fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
+#else
+ fprintf(stderr,"\tType: \t%s\n",type_name[TSO_TYPE(closure)]);
+#endif
+ fprintf(stderr,"> PC1: \t%#lx",TSO_PC1(closure));
+ fprintf(stderr,"\tPC2: \t%#lx\n",TSO_PC2(closure));
+ fprintf(stderr,"> ARG1: \t%#lx",TSO_ARG1(closure));
+ /* fprintf(stderr,"\tARG2: \t%#lx\n",TSO_ARG2(closure)); */
+ fprintf(stderr,"> SWITCH: \t%#lx", TSO_SWITCH(closure));
+#if defined(GRAN_PRI_SCHED)
+ fprintf(stderr,"\tPRI: \t%#lx\n", TSO_PRI(closure));
+#else
+ fprintf(stderr,"\n");
+#endif
+ if (verbose) {
+ fprintf(stderr,"} LOCKED: \t%#lx",TSO_LOCKED(closure));
+ fprintf(stderr,"\tSPARKNAME: \t%#lx\n", TSO_SPARKNAME(closure));
+ fprintf(stderr,"} STARTEDAT: \t%#lx", TSO_STARTEDAT(closure));
+ fprintf(stderr,"\tEXPORTED: \t%#lx\n", TSO_EXPORTED(closure));
+ fprintf(stderr,"} BASICBLOCKS: \t%#lx", TSO_BASICBLOCKS(closure));
+ fprintf(stderr,"\tALLOCS: \t%#lx\n", TSO_ALLOCS(closure));
+ fprintf(stderr,"} EXECTIME: \t%#lx", TSO_EXECTIME(closure));
+ fprintf(stderr,"\tFETCHTIME: \t%#lx\n", TSO_FETCHTIME(closure));
+ fprintf(stderr,"} FETCHCOUNT: \t%#lx", TSO_FETCHCOUNT(closure));
+ fprintf(stderr,"\tBLOCKTIME: \t%#lx\n", TSO_BLOCKTIME(closure));
+ fprintf(stderr,"} BLOCKCOUNT: \t%#lx", TSO_BLOCKCOUNT(closure));
+ fprintf(stderr,"\tBLOCKEDAT: \t%#lx\n", TSO_BLOCKEDAT(closure));
+ fprintf(stderr,"} GLOBALSPARKS:\t%#lx", TSO_GLOBALSPARKS(closure));
+ fprintf(stderr,"\tLOCALSPARKS:\t%#lx\n", TSO_LOCALSPARKS(closure));
+ }
+#if defined(GRAN_CHECK)
+ if ( verbose & 0x02 ) {
+ fprintf(stderr,"BQ that starts with this TSO: ");
+ PRINT_BQ(closure);
+ }
+#endif
+}
+
+void
+G_EVENT(event, verbose)
+eventq event;
+I_ verbose;
+{
+ if (verbose) {
+ print_event(event);
+ }else{
+ fprintf(stderr," %#lx",event);
+ }
+}
+
+void
+G_EVENTQ(verbose)
+I_ verbose;
+{
+ eventq x;
+
+ fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd);
+ for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
+ G_EVENT(x,verbose);
+ }
+ if (EventHd==NULL)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+void
+G_PE_EQ(pe,verbose)
+PROC pe;
+I_ verbose;
+{
+ eventq x;
+
+ fprintf(stderr,"Eventq (hd @%#lx):\n",EventHd);
+ for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
+ if (EVENT_PROC(x)==pe)
+ G_EVENT(x,verbose);
+ }
+ if (EventHd==NULL)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+void
+G_SPARK(spark, verbose)
+sparkq spark;
+I_ verbose;
+{
+ if (verbose)
+ print_spark(spark);
+ else
+ fprintf(stderr," %#lx",spark);
+}
+
+void
+G_SPARKQ(spark,verbose)
+sparkq spark;
+I_ verbose;
+{
+ sparkq x;
+
+ fprintf(stderr,"Sparkq (hd @%#lx):\n",spark);
+ for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
+ G_SPARK(x,verbose);
+ }
+ if (spark==NULL)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+void
+G_CURR_SPARKQ(verbose)
+I_ verbose;
+{
+ G_SPARKQ(SparkQueueHd,verbose);
+}
+
+void
+G_PROC(proc,verbose)
+I_ proc;
+I_ verbose;
+{
+ extern char *proc_status_names[];
+
+ fprintf(stderr,"Status of proc %d at time %d (%#lx): %s (%s)\n",
+ proc,CurrentTime[proc],CurrentTime[proc],
+ (CurrentProc==proc)?"ACTIVE":"INACTIVE",
+ proc_status_names[procStatus[proc]]);
+ G_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
+ if ( (CurrentProc==proc) )
+ G_TSO(CurrentTSO,1);
+
+ if (EventHd!=NULL)
+ fprintf(stderr,"Next event (%s) is on proc %d\n",
+ event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
+
+ if (verbose & 0x1) {
+ fprintf(stderr,"\nREQUIRED sparks: ");
+ G_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
+ fprintf(stderr,"\nADVISORY_sparks: ");
+ G_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
+ }
+}
+
+/* Debug Processor */
+void
+GP(proc)
+I_ proc;
+{ G_PROC(proc,1);
+}
+
+/* Debug Current Processor */
+void
+GCP(){ G_PROC(CurrentProc,2); }
+
+/* Debug TSO */
+void
+GT(P_ tso){
+ G_TSO(tso,1);
+}
+
+/* Debug CurrentTSO */
+void
+GCT(){
+ fprintf(stderr,"Current Proc: %d\n",CurrentProc);
+ G_TSO(CurrentTSO,1);
+}
+
+/* Shorthand for debugging event queue */
+void
+GEQ() { G_EVENTQ(1); }
+
+/* Shorthand for debugging thread queue of a processor */
+void
+GTQ(PROC p) { G_THREADQ(RunnableThreadsHd[p],1); }
+
+/* Shorthand for debugging thread queue of current processor */
+void
+GCTQ() { G_THREADQ(RunnableThreadsHd[CurrentProc],1); }
+
+/* Shorthand for debugging spark queue of a processor */
+void
+GSQ(PROC p) { G_SPARKQ(PendingSparksHd[p][1],1); }
+
+/* Shorthand for debugging spark queue of current processor */
+void
+GCSQ() { G_CURR_SPARKQ(1); }
+
+/* Shorthand for printing a node */
+void
+GN(P_ node) { G_PRINT_NODE(node); }
+
+/* Shorthand for printing info table */
+void
+GIT(P_ node) { G_INFO_TABLE(node); }
+
+/* Shorthand for some of ADRs debugging functions */
+
+void
+pC(P_ closure) { printClosure(closure, 0/*indentation*/, 10/*weight*/); }
+
+/* Print a closure on the heap */
+void
+DN(P_ closure) { DEBUG_NODE( closure, 1/*size*/ );}
+
+/* Print info-table of a closure */
+void
+DIT(P_ closure) { DEBUG_INFO_TABLE(closure); }
+
+/* (CONCURRENT) Print a Thread State Object */
+void
+DT(P_ tso) { DEBUG_TSO(tso); }
+
+/* Not yet implemented: */
+/* (CONCURRENT) Print a STacK Object
+void
+DS(P_ stko) { DEBUG_STKO(stko) ; }
+*/
+
+#endif /* GRAN */
+
+/* --------------------------- vvvv old vvvvv ------------------------*/
+
+#if 0 /* ngo' ngoq! veQ yIboS! */
+
+#define NULL_REG_MAP /* Not threaded */
+#include "stgdefs.h"
+
+char *
+info_hdr_type(info_ptr)
+W_ info_ptr;
+{
+#if ! defined(PAR) && !defined(GRAN)
+ switch (INFO_TAG(info_ptr))
+ {
+ case INFO_OTHER_TAG:
+ return("OTHER_TAG");
+/* case INFO_IND_TAG:
+ return("IND_TAG");
+*/ default:
+ return("TAG<n>");
+ }
+#else /* PAR */
+ switch(INFO_TYPE(info_ptr))
+ {
+ case INFO_SPEC_U_TYPE:
+ return("SPECU");
+
+ case INFO_SPEC_N_TYPE:
+ return("SPECN");
+
+ case INFO_GEN_U_TYPE:
+ return("GENU");
+
+ case INFO_GEN_N_TYPE:
+ return("GENN");
+
+ case INFO_DYN_TYPE:
+ return("DYN");
+
+ /*
+ case INFO_DYN_TYPE_N:
+ return("DYNN");
+
+ case INFO_DYN_TYPE_U:
+ return("DYNU");
+ */
+
+ case INFO_TUPLE_TYPE:
+ return("TUPLE");
+
+ case INFO_DATA_TYPE:
+ return("DATA");
+
+ case INFO_MUTUPLE_TYPE:
+ return("MUTUPLE");
+
+ case INFO_IMMUTUPLE_TYPE:
+ return("IMMUTUPLE");
+
+ case INFO_STATIC_TYPE:
+ return("STATIC");
+
+ case INFO_CONST_TYPE:
+ return("CONST");
+
+ case INFO_CHARLIKE_TYPE:
+ return("CHAR");
+
+ case INFO_INTLIKE_TYPE:
+ return("INT");
+
+ case INFO_BH_TYPE:
+ return("BHOLE");
+
+ case INFO_IND_TYPE:
+ return("IND");
+
+ case INFO_CAF_TYPE:
+ return("CAF");
+
+ case INFO_FETCHME_TYPE:
+ return("FETCHME");
+
+ case INFO_BQ_TYPE:
+ return("BQ");
+
+ /*
+ case INFO_BQENT_TYPE:
+ return("BQENT");
+ */
+
+ case INFO_TSO_TYPE:
+ return("TSO");
+
+ case INFO_STKO_TYPE:
+ return("STKO");
+
+ default:
+ fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
+ return("??");
+ }
+#endif /* PAR */
+}
+
+/*
+@var_hdr_size@ computes the size of the variable header for a closure.
+*/
+
+I_
+var_hdr_size(node)
+P_ node;
+{
+ switch(INFO_TYPE(INFO_PTR(node)))
+ {
+ case INFO_SPEC_U_TYPE: return(0); /* by decree */
+ case INFO_SPEC_N_TYPE: return(0);
+ case INFO_GEN_U_TYPE: return(GEN_VHS);
+ case INFO_GEN_N_TYPE: return(GEN_VHS);
+ case INFO_DYN_TYPE: return(DYN_VHS);
+ /*
+ case INFO_DYN_TYPE_N: return(DYN_VHS);
+ case INFO_DYN_TYPE_U: return(DYN_VHS);
+ */
+ case INFO_TUPLE_TYPE: return(TUPLE_VHS);
+ case INFO_DATA_TYPE: return(DATA_VHS);
+ case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS);
+ case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
+ case INFO_STATIC_TYPE: return(STATIC_VHS);
+ case INFO_CONST_TYPE: return(0);
+ case INFO_CHARLIKE_TYPE: return(0);
+ case INFO_INTLIKE_TYPE: return(0);
+ case INFO_BH_TYPE: return(0);
+ case INFO_IND_TYPE: return(0);
+ case INFO_CAF_TYPE: return(0);
+ case INFO_FETCHME_TYPE: return(0);
+ case INFO_BQ_TYPE: return(0);
+ /*
+ case INFO_BQENT_TYPE: return(0);
+ */
+ case INFO_TSO_TYPE: return(TSO_VHS);
+ case INFO_STKO_TYPE: return(STKO_VHS);
+ default:
+ fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
+ INFO_TYPE(INFO_PTR(node)));
+ return(0);
+ }
+}
+
+
+/* Determine the size and number of pointers for this kind of closure */
+void
+size_and_ptrs(node,size,ptrs)
+P_ node;
+W_ *size, *ptrs;
+{
+ switch(INFO_TYPE(INFO_PTR(node)))
+ {
+ case INFO_SPEC_U_TYPE:
+ case INFO_SPEC_N_TYPE:
+ *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */
+ *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */
+ /*
+ *size = SPEC_CLOSURE_SIZE(node);
+ *ptrs = SPEC_CLOSURE_NoPTRS(node);
+ */
+ break;
+
+ case INFO_GEN_U_TYPE:
+ case INFO_GEN_N_TYPE:
+ *size = GEN_CLOSURE_SIZE(node);
+ *ptrs = GEN_CLOSURE_NoPTRS(node);
+ break;
+
+ /*
+ case INFO_DYN_TYPE_U:
+ case INFO_DYN_TYPE_N:
+ */
+ case INFO_DYN_TYPE:
+ *size = DYN_CLOSURE_SIZE(node);
+ *ptrs = DYN_CLOSURE_NoPTRS(node);
+ break;
+
+ case INFO_TUPLE_TYPE:
+ *size = TUPLE_CLOSURE_SIZE(node);
+ *ptrs = TUPLE_CLOSURE_NoPTRS(node);
+ break;
+
+ case INFO_DATA_TYPE:
+ *size = DATA_CLOSURE_SIZE(node);
+ *ptrs = DATA_CLOSURE_NoPTRS(node);
+ break;
+
+ case INFO_IND_TYPE:
+ *size = IND_CLOSURE_SIZE(node);
+ *ptrs = IND_CLOSURE_NoPTRS(node);
+ break;
+
+/* ToDo: more (WDP) */
+
+ /* Don't know about the others */
+ default:
+ *size = *ptrs = 0;
+ break;
+ }
+}
+
+void
+DEBUG_PRINT_NODE(node)
+P_ node;
+{
+ W_ info_ptr = INFO_PTR(node);
+ I_ size = 0, ptrs = 0, i, vhs = 0;
+ char *info_type = info_hdr_type(info_ptr);
+
+ size_and_ptrs(node,&size,&ptrs);
+ vhs = var_hdr_size(node);
+
+ fprintf(stderr,"Node: 0x%lx", (W_) node);
+
+#if defined(PAR)
+ fprintf(stderr," [GA: 0x%lx]",GA(node));
+#endif
+
+#if defined(PROFILING)
+ fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
+#endif
+
+#if defined(GRAN)
+ fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
+#endif
+
+ fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n",
+ info_ptr,info_type,size,ptrs);
+
+ /* For now, we ignore the variable header */
+
+ for(i=0; i < size; ++i)
+ {
+ if(i == 0)
+ fprintf(stderr,"Data: ");
+
+ else if(i % 6 == 0)
+ fprintf(stderr,"\n ");
+
+ if(i < ptrs)
+ fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
+ else
+ fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i));
+ }
+ fprintf(stderr, "\n");
+}
+
+
+#define INFO_MASK 0x80000000
+
+void
+DEBUG_TREE(node)
+P_ node;
+{
+ W_ size = 0, ptrs = 0, i, vhs = 0;
+
+ /* Don't print cycles */
+ if((INFO_PTR(node) & INFO_MASK) != 0)
+ return;
+
+ size_and_ptrs(node,&size,&ptrs);
+ vhs = var_hdr_size(node);
+
+ DEBUG_PRINT_NODE(node);
+ fprintf(stderr, "\n");
+
+ /* Mark the node -- may be dangerous */
+ INFO_PTR(node) |= INFO_MASK;
+
+ for(i = 0; i < ptrs; ++i)
+ DEBUG_TREE((P_)node[i+vhs+_FHS]);
+
+ /* Unmark the node */
+ INFO_PTR(node) &= ~INFO_MASK;
+}
+
+
+void
+DEBUG_INFO_TABLE(node)
+P_ node;
+{
+ W_ info_ptr = INFO_PTR(node);
+ char *ip_type = info_hdr_type(info_ptr);
+
+ fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
+ ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
+#if defined(PAR)
+ fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
+#endif
+
+#if defined(PROFILING)
+ fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr));
+#endif
+
+#if defined(_INFO_COPYING)
+ fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
+ INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
+#endif
+
+#if defined(_INFO_COMPACTING)
+ fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
+ (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
+ fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
+ (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
+#if 0 /* avoid INFO_TYPE */
+ if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
+ fprintf(stderr,"plus specialised code\n");
+ else
+ fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
+#endif /* 0 */
+#endif /* _INFO_COMPACTING */
+}
+
+\end{code}
+
+The remaining debugging routines are more or less specific for GrAnSim.
+
+\begin{code}
+#if defined(GRAN) && defined(GRAN_CHECK)
+void
+DEBUG_CURR_THREADQ(verbose)
+I_ verbose;
+{
+ fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
+ DEBUG_THREADQ(ThreadQueueHd, verbose);
+}
+
+void
+DEBUG_THREADQ(closure, verbose)
+P_ closure;
+I_ verbose;
+{
+ P_ x;
+
+ fprintf(stderr,"Thread Queue: ");
+ for (x=closure; x!=Prelude_Z91Z93_closure; x=TSO_LINK(x))
+ if (verbose)
+ DEBUG_TSO(x,0);
+ else
+ fprintf(stderr," 0x%x",x);
+
+ if (closure==Prelude_Z91Z93_closure)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+/* Check with Threads.lh */
+static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
+
+void
+DEBUG_TSO(closure,verbose)
+P_ closure;
+I_ verbose;
+{
+
+ if (closure==Prelude_Z91Z93_closure) {
+ fprintf(stderr,"TSO at 0x%x is Prelude_Z91Z93_closure!\n");
+ return;
+ }
+
+ fprintf(stderr,"TSO at 0x%x has the following contents:\n",closure);
+
+ fprintf(stderr,"> Name: 0x%x",TSO_NAME(closure));
+ fprintf(stderr,"\tLink: 0x%x\n",TSO_LINK(closure));
+ fprintf(stderr,"> Id: 0x%x",TSO_ID(closure));
+#if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GranFlags.debug & 0x10)
+ fprintf(stderr,"\tType: %s %s\n",
+ type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
+ (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
+ else
+ fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
+#else
+ fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
+#endif
+ fprintf(stderr,"> PC1: 0x%x",TSO_PC1(closure));
+ fprintf(stderr,"\tPC2: 0x%x\n",TSO_PC2(closure));
+ fprintf(stderr,"> ARG1: 0x%x",TSO_ARG1(closure));
+ /* fprintf(stderr,"\tARG2: 0x%x\n",TSO_ARG2(closure)); */
+ fprintf(stderr,"> SWITCH: 0x%x\n", TSO_SWITCH(closure));
+
+ if (verbose) {
+ fprintf(stderr,"} LOCKED: 0x%x",TSO_LOCKED(closure));
+ fprintf(stderr,"\tSPARKNAME: 0x%x\n", TSO_SPARKNAME(closure));
+ fprintf(stderr,"} STARTEDAT: 0x%x", TSO_STARTEDAT(closure));
+ fprintf(stderr,"\tEXPORTED: 0x%x\n", TSO_EXPORTED(closure));
+ fprintf(stderr,"} BASICBLOCKS: 0x%x", TSO_BASICBLOCKS(closure));
+ fprintf(stderr,"\tALLOCS: 0x%x\n", TSO_ALLOCS(closure));
+ fprintf(stderr,"} EXECTIME: 0x%x", TSO_EXECTIME(closure));
+ fprintf(stderr,"\tFETCHTIME: 0x%x\n", TSO_FETCHTIME(closure));
+ fprintf(stderr,"} FETCHCOUNT: 0x%x", TSO_FETCHCOUNT(closure));
+ fprintf(stderr,"\tBLOCKTIME: 0x%x\n", TSO_BLOCKTIME(closure));
+ fprintf(stderr,"} BLOCKCOUNT: 0x%x", TSO_BLOCKCOUNT(closure));
+ fprintf(stderr,"\tBLOCKEDAT: 0x%x\n", TSO_BLOCKEDAT(closure));
+ fprintf(stderr,"} GLOBALSPARKS: 0x%x", TSO_GLOBALSPARKS(closure));
+ fprintf(stderr,"\tLOCALSPARKS: 0x%x\n", TSO_LOCALSPARKS(closure));
+ }
+}
+
+void
+DEBUG_EVENT(event, verbose)
+eventq event;
+I_ verbose;
+{
+ if (verbose) {
+ print_event(event);
+ }else{
+ fprintf(stderr," 0x%x",event);
+ }
+}
+
+void
+DEBUG_EVENTQ(verbose)
+I_ verbose;
+{
+ eventq x;
+
+ fprintf(stderr,"Eventq (hd @0x%x):\n",EventHd);
+ for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
+ DEBUG_EVENT(x,verbose);
+ }
+ if (EventHd==NULL)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+void
+DEBUG_SPARK(spark, verbose)
+sparkq spark;
+I_ verbose;
+{
+ if (verbose)
+ print_spark(spark);
+ else
+ fprintf(stderr," 0x%x",spark);
+}
+
+void
+DEBUG_SPARKQ(spark,verbose)
+sparkq spark;
+I_ verbose;
+{
+ sparkq x;
+
+ fprintf(stderr,"Sparkq (hd @0x%x):\n",spark);
+ for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
+ DEBUG_SPARK(x,verbose);
+ }
+ if (spark==NULL)
+ fprintf(stderr,"NIL\n");
+ else
+ fprintf(stderr,"\n");
+}
+
+void
+DEBUG_CURR_SPARKQ(verbose)
+I_ verbose;
+{
+ DEBUG_SPARKQ(SparkQueueHd,verbose);
+}
+
+void
+DEBUG_PROC(proc,verbose)
+I_ proc;
+I_ verbose;
+{
+ fprintf(stderr,"Status of proc %d at time %d (0x%x): %s\n",
+ proc,CurrentTime[proc],CurrentTime[proc],
+ (CurrentProc==proc)?"ACTIVE":"INACTIVE");
+ DEBUG_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
+ if ( (CurrentProc==proc) )
+ DEBUG_TSO(CurrentTSO,1);
+
+ if (EventHd!=NULL)
+ fprintf(stderr,"Next event (%s) is on proc %d\n",
+ event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
+
+ if (verbose & 0x1) {
+ fprintf(stderr,"\nREQUIRED sparks: ");
+ DEBUG_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
+ fprintf(stderr,"\nADVISORY_sparks: ");
+ DEBUG_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
+ }
+}
+
+/* Debug CurrentTSO */
+void
+DCT(){
+ fprintf(stderr,"Current Proc: %d\n",CurrentProc);
+ DEBUG_TSO(CurrentTSO,1);
+}
+
+/* Debug Current Processor */
+void
+DCP(){ DEBUG_PROC(CurrentProc,2); }
+
+/* Shorthand for debugging event queue */
+void
+DEQ() { DEBUG_EVENTQ(1); }
+
+/* Shorthand for debugging spark queue */
+void
+DSQ() { DEBUG_CURR_SPARKQ(1); }
+
+/* Shorthand for printing a node */
+void
+DN(P_ node) { DEBUG_PRINT_NODE(node); }
+
+#endif /* GRAN */
+
+#endif /* 0 */
+\end{code}
+
+++ /dev/null
-\begin{onlystandalone}
-\documentstyle[11pt,literate]{article}
-\begin{document}
-\title{GRIP Runtime Support}
-\author{Kevin Hammond, \\
-Department of Computing Science, \\
-University of Glasgow, \\
-Glasgow, G12 8QQ, UK. \\
-\\
-Email: glasgow-haskell-\{request,bugs\}\@dcs.glasgow.ac.uk}
-\maketitle
-\begin{rawlatex}
-\tableofcontents
-\end{rawlatex}
-\clearpage
-\end{onlystandalone}
-
-This document describes the runtime support code for the GRIP Multiprocessor.
-Most of the code described here is in fact generic, and could be ported to
-many parallel architectures with some changes (notably to the message-passing
-primitives).
-
-\input{grip/Macros.lh}
-
-\input{grip/Flush.lc}
-\input{grip/Fetch.lc}
-\input{grip/MipOp.lc}
-
-\input{threadroot.lit}
-
-\input{grip/GlobalGc.lc}
-
-\input{grip/RTS_Stats.lc}
-
-\input{grip/Comms.lc}
-
-\section[GRIP_misc]{GRIP Emulation}
-\downsection
-
-The routines in this section emulate the operating system or
-hardware on a sequential system. They should not be required in the final
-GRIP runtime system.
-
-\input{grip/BIP_Sim.lc}
-\input{grip/IMU_Sim.lc}
-\input{grip/GRIP_Debug.lc}
-\input{grip/Name.lc}
-\input{grip/OpNames.lc}
-\input{grip/PEOp.lc}
-\upsection
-
-\input{grip/Statistics.lc}
-
-\begin{onlystandalone}
-\printindex
-\end{document}
-\end{onlystandalone}
rGA = FETCHME_GA(Node);
ASSERT(rGA->loc.gc.gtid != mytid);
- TSO_LINK(CurrentTSO) = Nil_closure;
+ TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
SET_INFO_PTR(Node, FMBQ_info);
FMBQ_ENTRIES(Node) = (W_) CurrentTSO;
TSO_FETCHCOUNT(CurrentTSO)++;
TSO_QUEUE(CurrentTSO) = Q_FETCHING;
TSO_BLOCKEDAT(CurrentTSO) = now;
- DumpGranEventAndNode(GR_FETCH, CurrentTSO, (SAVE_R1).p,
- taskIDtoPE(rGA->loc.gc.gtid));
+ /* DumpGranEventAndNode(GR_FETCH, CurrentTSO, (SAVE_R1).p,
+ taskIDtoPE(rGA->loc.gc.gtid)); */
+ DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(rGA->loc.gc.gtid),GR_FETCH,
+ CurrentTSO,(SAVE_R1).p,0);
}
/* Assign a brand-new global address to the newly created FMBQ */
{
switch (INFO_TYPE(INFO_PTR(bh))) {
case INFO_BH_TYPE:
- BF_LINK(bf) = Nil_closure;
+ BF_LINK(bf) = Prelude_Z91Z93_closure;
SET_INFO_PTR(bh, BQ_info);
BQ_ENTRIES(bh) = (W_) bf;
P_ ip;
globalAddr rga;
- for (bf = PendingFetches; bf != Nil_closure; bf = next) {
+ for (bf = PendingFetches; bf != Prelude_Z91Z93_closure; bf = next) {
next = BF_LINK(bf);
/*
sendResume(&rga, size, graph);
}
}
- PendingFetches = Nil_closure;
+ PendingFetches = Prelude_Z91Z93_closure;
}
\end{code}
if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE) {
for(tso = (P_) FMBQ_ENTRIES(old);
- TSO_LINK(tso) != Nil_closure;
+ TSO_LINK(tso) != Prelude_Z91Z93_closure;
tso = TSO_LINK(tso))
;
}
- DumpGranEventAndNode(GR_REPLY, tso, old, taskIDtoPE(sender));
+ /* DumpGranEventAndNode(GR_REPLY, tso, old, taskIDtoPE(sender)); */
+ DumpRawGranEvent(CURRENT_PROC,taskIDtoPE(sender),GR_REPLY,
+ tso,old,0);
}
newGraph = UnpackGraph(packBuffer, &gagamap, &nGAs);
% (c) The Parade/AQUA Projects, Glasgow University, 1995
% Kevin Hammond, February 15th. 1995
%
-% This is for GUM only.
+% This is for GUM and for GrAnSim.
%
%************************************************************************
%* *
This module defines routines for packing closures in the parallel runtime
system (GUM).
+The GrAnSim version of the code defines routines for *simulating* the
+packing of closures in the same way it
+is done in the parallel runtime system. Basically GrAnSim only puts the
+addresses of the closures to be transferred into a buffer. This buffer will
+then be associated with the event of transferring the graph. When this
+event is scheduled, the @UnpackGraph@ routine is called and the buffer
+can be discarded afterwards.
+
+Note that in GrAnSim we need many buffers, not just one per PE.
+
\begin{code}
-#ifdef PAR /* whole file */
+#if defined(PAR) || defined(GRAN) /* whole file */
#include "rtsdefs.h"
+
+/* Which RTS flag should be used to get the size of the pack buffer ? */
+#if defined(PAR)
+#define PACK_BUFFER_SIZE RTSflags.ParFlags.packBufferSize
+#else /* GRAN */
+#define PACK_BUFFER_SIZE RTSflags.GranFlags.packBufferSize
+#endif
\end{code}
Static data and code declarations.
\begin{code}
-static W_ *PackBuffer = NULL; /* size: can be set via option */
+#if defined(GRAN)
+/* To be pedantic: in GrAnSim we're packing *addresses* of closures,
+ not the closures themselves.
+*/
+static P_ *PackBuffer = NULL; /* size: can be set via option */
+#else
+static W_ *PackBuffer = NULL; /* size: can be set via option */
+#endif
static W_ packlocn, clqsize, clqpos;
static W_ unpackedsize;
-static W_ reservedPAsize; /*Space reserved for primitive arrays*/
+static W_ reservedPAsize; /*Space reserved for primitive arrays*/
static rtsBool RoomInBuffer;
static void InitPacking(STG_NO_ARGS), DonePacking(STG_NO_ARGS);
-static rtsBool NotYetPacking PROTO((int offset)),
- RoomToPack PROTO((W_ size, W_ ptrs));
+#if defined(GRAN)
+static rtsBool NotYetPacking PROTO((P_ closure));
+static void Pack PROTO((P_ data));
+#else
+static rtsBool NotYetPacking PROTO((int offset));
+static void Pack PROTO((W_ data));
+#endif
+static rtsBool RoomToPack PROTO((W_ size, W_ ptrs));
static void AmPacking PROTO((P_ closure));
-static void PackClosure PROTO((P_ closure));
-static void Pack PROTO((W_ data)),
- PackPLC PROTO((P_ addr)),
- PackOffset PROTO((int offset)),
- GlobaliseAndPackGA PROTO((P_ closure));
+static void PackClosure PROTO((P_ closure))
+#if !defined(GRAN)
+ , PackPLC PROTO((P_ addr))
+ , PackOffset PROTO((int offset))
+ , GlobaliseAndPackGA PROTO((P_ closure))
+#endif
+ ;
static int OffsetFor PROTO((P_ closure));
\end{code}
+Bit of a hack for testing if a closure is the root of the graph. This is
+set in @PackNearbyGraph@ and tested in @PackClosure@.
+
+\begin{code}
+#if defined(GRAN)
+I_ packed_thunks = 0;
+P_ graphroot;
+#endif
+\end{code}
+
%************************************************************************
%* *
\subsection[PackNearbyGraph]{Packing Sections of Nearby Graph}
and their children are not queued for packing.
\begin{code}
+# if defined(PAR)
P_
PackNearbyGraph(closure, packbuffersize)
P_ closure;
W_ *packbuffersize;
+# else /* GRAN */
+P_
+PackNearbyGraph(closure, tso, packbuffersize)
+P_ closure;
+P_ tso;
+W_ *packbuffersize;
+# endif
{
/* Ensure enough heap for all possible RBH_Save closures */
- ASSERT(RTSflags.ParFlags.packBufferSize > 0);
+ ASSERT(PACK_BUFFER_SIZE > 0);
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr,"Packing graph with root at 0x%lx (PE %d); demanded by TSO %#lx (%d) (PE %d) ...\n",
+ closure, where_is(closure), tso, TSO_ID(tso), where_is(tso) );
+# endif /* GRAN */
if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
return NULL;
InitPacking();
+# if defined(GRAN)
+ graphroot = closure;
+# endif
QueueClosure(closure);
do {
PackClosure(DeQueueClosure());
} while (!QueueEmpty());
+# if defined(PAR)
/* Record how much space is needed to unpack the graph */
PackBuffer[0] = unpackedsize;
+# else /* GRAN */
+ /* Record how much space is needed to unpack the graph */
+ PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
+ PackBuffer[PACK_TSO_LOCN] = tso;
+ PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
+# endif
/* Set the size parameter */
+# if defined(PAR)
ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
*packbuffersize = packlocn;
+# else /* GRAN */
+ ASSERT(packlocn <= PackBuffer[PACK_SIZE_LOCN]);
+ /* ToDo: Print an earlier, more meaningful message */
+ if (packlocn==PACK_HDR_SIZE) { /* i.e. packet is empty */
+ fprintf(stderr,"EMPTY PACKET! Can't transfer closure %#lx at all!!\n",
+ closure);
+ EXIT(EXIT_FAILURE);
+ }
+ PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
+ *packbuffersize = packlocn;
+# endif
+
+# if !defined(GRAN)
+ DonePacking(); /* {GrAnSim}vaD 'ut'Ha' */
+# endif
- DonePacking();
+# if defined(GRAN) && defined(GRAN_CHECK)
+ tot_packets++;
+ tot_packet_size += packlocn-PACK_HDR_SIZE ;
- return (PackBuffer);
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ PrintPacket((P_)PackBuffer);
+ }
+# endif /* GRAN */
+
+ return ((P_)PackBuffer);
}
+
+#if defined(GRAN)
+/* This version is used when the node is already local */
+
+P_
+PackOneNode(closure, tso, packbuffersize)
+P_ closure;
+P_ tso;
+W_ *packbuffersize;
+{
+ int i, clpacklocn;
+
+ InitPacking();
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ W_ size, ptrs, nonptrs, vhs;
+ P_ info;
+ char str[80], junk_str[80];
+
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+ fprintf(stderr,"PackOneNode: %#lx (%s)(PE %#lx) requested by TSO %#lx (%d) (PE %#lx)\n",
+ closure, str, where_is(closure), tso, TSO_ID(tso), where_is(tso));
+ }
+# endif
+
+ Pack(closure);
+
+ /* Record how much space is needed to unpack the graph */
+ PackBuffer[PACK_FLAG_LOCN] = (P_) MAGIC_PACK_FLAG;
+ PackBuffer[PACK_TSO_LOCN] = tso;
+ PackBuffer[PACK_UNPACKED_SIZE_LOCN] = (P_) unpackedsize;
+
+ /* Set the size parameter */
+ ASSERT(packlocn <= PACK_BUFFER_SIZE);
+ PackBuffer[PACK_SIZE_LOCN] = (P_) packlocn;
+ *packbuffersize = packlocn;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ tot_packets++;
+ tot_packet_size += packlocn-PACK_HDR_SIZE ;
+
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ PrintPacket(PackBuffer);
+ }
+# endif /* GRAN */
+
+ return ((P_)PackBuffer);
+}
+#endif /* GRAN */
\end{code}
@PackTSO@ and @PackStkO@ are entry points for two special kinds of
Luckily, they're only needed when migrating threads between processors.
\begin{code}
+#if defined(GRAN)
+P_ *
+#else
W_ *
+#endif
PackTSO(tso,packbuffersize)
P_ tso;
W_ *packbuffersize;
return(PackBuffer);
}
+#if defined(GRAN)
+P_ *
+#else
W_ *
+#endif
PackStkO(stko,packbuffersize)
P_ stko;
W_ *packbuffersize;
closure.
\begin{code}
+#if defined(PAR)
+
void
PackClosure(closure)
P_ closure;
{
W_ size, ptrs, nonptrs, vhs;
int i, clpacklocn;
+ char str[80];
while (IS_INDIRECTION(INFO_PTR(closure))) {
/* Don't pack indirection closures */
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Shorted an indirection at %x", closure);
-#endif
+# endif
closure = (P_) IND_CLOSURE_PTR(closure);
}
switch (INFO_TYPE(INFO_PTR(closure))) {
case INFO_CHARLIKE_TYPE:
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Packing a charlike %s\n", CHARLIKE_VALUE(closure));
-#endif
+# endif
PackPLC((P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(closure)));
return;
case INFO_CONST_TYPE:
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Packing a const %s\n", CONST_STATIC_CLOSURE(INFO_PTR(closure)));
-#endif
+# endif
PackPLC(CONST_STATIC_CLOSURE(INFO_PTR(closure)));
return;
case INFO_STATIC_TYPE:
case INFO_CAF_TYPE: /* For now we ship indirections to CAFs: They are
* evaluated on each PE if needed */
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Packing a PLC %x\n", closure);
-#endif
+# endif
PackPLC(closure);
return;
I_ val = INTLIKE_VALUE(closure);
if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Packing a small intlike %d as a PLC\n", val);
-#endif
+# endif
PackPLC(INTLIKE_CLOSURE(val));
return;
} else {
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Packing a big intlike %d as a normal closure\n", val);
-#endif
+# endif
break;
}
}
default:
-#ifdef PACK_DEBUG
+# ifdef PACK_DEBUG
fprintf(stderr, "Not a PLC: ");
-#endif
+# endif
} /* Switch */
/* Otherwise it's not Fixed */
- info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs);
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
size = ptrs = nonptrs = vhs = 0;
W_ childSize, childPtrs, childNonPtrs, childVhs;
childInfo = get_closure_info(((PP_) (closure))[i + FIXED_HS + vhs],
- &childSize, &childPtrs, &childNonPtrs, &childVhs);
+ &childSize, &childPtrs, &childNonPtrs, &childVhs, str);
if (IS_BIG_MOTHER(childInfo)) {
reservedPAsize += PACK_GA_SIZE + FIXED_HS + childVhs + childNonPtrs
+ childPtrs * PACK_FETCHME_SIZE;
*/
if (IS_THUNK(info) && IS_UPDATABLE(info)) {
-#ifdef DEBUG
+# ifdef DEBUG
P_ rbh =
-#else
+# else
(void)
-#endif
+# endif
convertToRBH(closure);
ASSERT(rbh != NULL);
else
PackOffset(clpacklocn);
}
+
+#else /* GRAN */
+
+/* Fake the packing of a closure */
+
+void
+PackClosure(closure)
+P_ closure;
+{
+ W_ size, ptrs, nonptrs, vhs;
+ W_ childSize, childPtrs, junk; /*size, no. ptrs etc. of a child closure*/
+ P_ childInfo;
+ P_ info;
+ int i, clpacklocn;
+ W_ PAsize = 0; /*total size + no. ptrs of all child prim arrays*/
+ W_ PAptrs = 0;
+ char str[80], junk_str[80];
+ rtsBool will_be_rbh, no_more_thunks_please;
+
+ /* In GranSim we don't pack and unpack closures -- we just simulate */
+ /* that by updating the bitmask. So, the graph structure is unchanged */
+ /* i.e. we don't short out indirections here. -- HWL */
+
+ if (where_is(closure) != where_is(graphroot)) {
+ /* GUM would pack a FETCHME here; simulate that by increasing the */
+ /* unpacked size accordingly but don't pack anything -- HWL */
+ unpackedsize += FIXED_HS + FETCHME_CLOSURE_SIZE(closure);
+ return;
+ }
+ /* clpacklocn = OffsetFor(closure); */
+
+ /* If the closure's not already being packed */
+ if (NotYetPacking(closure)) {
+ switch (INFO_TYPE(INFO_PTR(closure))) {
+ case INFO_SPEC_RBH_TYPE:
+ case INFO_GEN_RBH_TYPE:
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ fprintf(stderr,"************ Avoid packing RBH @ %#lx!\n", closure);
+ }
+# endif
+ /* Just ignore RBHs i.e. they stay where they are */
+ return;
+
+ case INFO_CHARLIKE_TYPE:
+ case INFO_CONST_TYPE:
+ case INFO_STATIC_TYPE:
+ case INFO_CAF_TYPE: /* For now we ship indirections to CAFs:
+ * They are evaluated on each PE if needed */
+ Pack(closure);
+ return;
+
+ case INFO_INTLIKE_TYPE:
+ {
+ I_ val = INTLIKE_VALUE(closure);
+ if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
+ Pack(closure);
+ return;
+ } else {
+ break;
+ }
+ }
+ default:
+ /* Just fall through to the rest of the function */
+ } /* Switch */
+
+ /* Otherwise it's not Fixed */
+
+ info = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
+ will_be_rbh = IS_THUNK(info) && IS_UPDATABLE(info);
+ no_more_thunks_please =
+ (RTSflags.GranFlags.ThunksToPack>0) &&
+ (packed_thunks>=RTSflags.GranFlags.ThunksToPack);
+
+ if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
+ size = ptrs = nonptrs = vhs = 0;
+
+ /* Now peek ahead to see whether the closure has any primitive */
+ /* array children */
+ for (i = 0; i < ptrs; ++i) {
+ P_ childInfo;
+ W_ childSize, childPtrs, childNonPtrs, childVhs;
+
+ childInfo = get_closure_info(((StgPtrPtr) (closure))[i + FIXED_HS + vhs],
+ &childSize, &childPtrs, &childNonPtrs,
+ &childVhs, junk_str);
+ if (IS_BIG_MOTHER(childInfo)) {
+ reservedPAsize += PACK_GA_SIZE + FIXED_HS +
+ childVhs + childNonPtrs +
+ childPtrs * PACK_FETCHME_SIZE;
+ PAsize += PACK_GA_SIZE + FIXED_HS + childSize;
+ PAptrs += childPtrs;
+ }
+ }
+
+ /* Don't pack anything (GrAnSim) if it's a black hole, or the buffer
+ * is full and it isn't a primitive array. N.B. Primitive arrays are
+ * always packed (because their parents index into them directly) */
+
+ if (IS_BLACK_HOLE(info) ||
+ !(RoomToPack(PACK_GA_SIZE + FIXED_HS + vhs + nonptrs, ptrs)
+ || IS_BIG_MOTHER(info)))
+ return;
+
+ /* At last! A closure we can actually pack! */
+
+ if (IS_MUTABLE(info) && (INFO_TYPE(info) != INFO_FETCHME_TYPE))
+ fprintf(stderr,"Warning: Replicated a Mutable closure!");
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if (no_more_thunks_please && will_be_rbh) {
+ tot_cuts++;
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr,"PackClosure (w/ RTSflags.GranFlags.ThunksToPack=%d): Cutting tree with root at %#lx\n",
+ RTSflags.GranFlags.ThunksToPack, closure);
+ } else if (will_be_rbh || (closure==graphroot) ) {
+ packed_thunks++;
+ tot_thunks++;
+ }
+# endif
+ if (!(no_more_thunks_please && will_be_rbh)) {
+ Pack(closure); /* actual PACKING done here -- HWL */
+ for (i = 0; i < ptrs; ++i)
+ QueueClosure(((StgPtrPtr) (closure))[i + FIXED_HS + vhs]);
+
+ /* Turn thunk into a revertible black hole. */
+ if (will_be_rbh)
+ {
+ P_ rbh;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ fprintf(stderr,"> RBHing the following closure:\n (%#lx) ",
+ closure);
+ G_PPN(closure); /* see StgDebug */
+ }
+# endif
+ rbh = convertToRBH(closure);
+ ASSERT(rbh != NULL);
+ }
+ }
+ }
+ else /* !NotYetPacking(clpacklocn) */
+ /* Don't have to do anything in GrAnSim if closure is already */
+ /* packed -- HWL */
+ {
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr,"*** Closure %#lx is already packed and omitted now!\n",
+ closure);
+# endif
+ }
+}
+#endif /* PAR */
\end{code}
%************************************************************************
%* *
%************************************************************************
+About packet sizes in GrAnSim: In GrAnSim we use a malloced block of
+gransim_pack_buffer_size words to simulate a packet of pack_buffer_size
+words. In the simulated PackBuffer we only keep the addresses of the
+closures that would be packed in the parallel system (see Pack). To decide
+if a packet overflow occurs pack_buffer_size must be compared versus
+unpackedsize (see RoomToPack). Currently, there is no multi packet
+strategy implemented, so in the case of an overflow we just stop adding
+closures to the closure queue. If an overflow of the simulated packet
+occurs, we just realloc some more space for it and carry on as usual.
+% -- HWL
+
+\begin{code}
+#if defined(GRAN)
+static P_ *
+InstantiatePackBuffer () {
+
+ PackBuffer =
+ /* NB: gransim_pack_buffer_size instead of pack_buffer_size -- HWL */
+ (P_ *) stgMallocWords(RTSflags.GranFlags.packBufferSize_internal+PACK_HDR_SIZE,
+ "InstantiatePackBuffer") ;
+
+ PackBuffer[PACK_SIZE_LOCN] = (P_)RTSflags.GranFlags.packBufferSize_internal;
+
+ return (PackBuffer);
+}
+#endif
+\end{code}
+
@Pack@ is the basic packing routine. It just writes a word of
data into the pack buffer and increments the pack location.
\begin{code}
+#if defined(PAR)
static void
Pack(data)
W_ data;
ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
PackBuffer[packlocn++] = data;
}
+#else /* GRAN */
+static void
+Pack(addr)
+P_ addr;
+{
+ W_ size, ptrs, nonptrs, vhs;
+ P_ info;
+ char str[80];
+
+ /* This checks the size of the GrAnSim internal pack buffer. The simulated
+ pack buffer is checked via RoomToPack (as in GUM) */
+ if (packlocn >= (int)PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE) {
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x8000 ) {
+ fprintf(stderr, "Increasing size of PackBuffer %#lx to %d words (PE %u @ %d)\n",
+ PackBuffer, PackBuffer[PACK_SIZE_LOCN]+REALLOC_SZ,
+ CurrentProc, CurrentTime[CurrentProc]);
+ }
+# endif
+ PackBuffer = (P_ *) realloc(PackBuffer,
+ sizeof(P_)*(REALLOC_SZ +
+ (int)PackBuffer[PACK_SIZE_LOCN] +
+ PACK_HDR_SIZE)) ;
+ if (PackBuffer == NULL) {
+ fprintf(stderr,"Failing to realloc %d more words for PackBuffer %#lx (PE %u @ %d)\n",
+ REALLOC_SZ, PackBuffer, CurrentProc, CurrentTime[CurrentProc]);
+ EXIT(EXIT_FAILURE);
+ }
+ PackBuffer[PACK_SIZE_LOCN] += REALLOC_SZ;
+ }
+
+ ASSERT(packlocn < PackBuffer[PACK_SIZE_LOCN]+PACK_HDR_SIZE);
+
+ if (addr==NULL)
+ fprintf(stderr,"Qagh {Pack}Daq: Trying to pack 0\n");
+ PackBuffer[packlocn++] = addr;
+ /* ASSERT: Data is a closure in GrAnSim here */
+ info = get_closure_info(addr, &size, &ptrs, &nonptrs, &vhs, str);
+ unpackedsize += FIXED_HS + (size < MIN_UPD_SIZE ?
+ MIN_UPD_SIZE :
+ size);
+}
+#endif /* PAR */
\end{code}
If a closure is local, make it global. Then, divide its weight for export.
The GA is then packed into the pack buffer.
\begin{code}
+#if !defined(GRAN)
+
static void
GlobaliseAndPackGA(closure)
P_ closure;
Pack(0L); /* pe */
Pack(offset); /* slot/offset */
}
+#endif /* !GRAN */
\end{code}
%************************************************************************
the pack buffer of each closure which is packed.
\begin{code}
+#if defined(PAR)
static HashTable *offsettable;
\end{code}
AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
}
}
+#endif /* PAR */
static void
InitPacking(STG_NO_ARGS)
{
- /* InitPackBuffer(); now done in ParInit HWL_ */
+#if defined(GRAN)
+ PackBuffer = InstantiatePackBuffer(); /* for GrAnSim only -- HWL */
+ /* NB: free in UnpackGraph */
+#endif
packlocn = PACK_HDR_SIZE;
unpackedsize = 0;
reservedPAsize = 0;
RoomInBuffer = rtsTrue;
InitClosureQueue();
+#if defined(PAR)
offsettable = allocHashTable();
+#else
+ packed_thunks = 0;
+#endif
}
\end{code}
etc.
\begin{code}
+#if defined(PAR)
+
static void
DonePacking(STG_NO_ARGS)
{
{
return(offset < PACK_HDR_SIZE);
}
+
+#else /* GRAN */
+
+static rtsBool
+NotYetPacking(closure)
+P_ closure;
+{ int i;
+ rtsBool found = rtsFalse;
+
+ for (i=PACK_HDR_SIZE; (i<packlocn) && !found; i++)
+ found = PackBuffer[i]==closure;
+
+ return (!found);
+}
+#endif
\end{code}
@RoomToPack@ determines whether there's room to pack the closure into
RoomToPack(size, ptrs)
W_ size, ptrs;
{
+#if defined(PAR)
if (RoomInBuffer &&
(packlocn + reservedPAsize + size +
- ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= RTSflags.ParFlags.packBufferSize)) {
+ ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
+ {
#ifdef PACK_DEBUG
fprintf(stderr, "Buffer full\n");
#endif
RoomInBuffer = rtsFalse;
}
+#else /* GRAN */
+ if (RoomInBuffer &&
+ (unpackedsize + reservedPAsize + size +
+ ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE))
+ {
+#if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr, "Buffer full\n");
+#endif
+ RoomInBuffer = rtsFalse;
+ }
+#endif
return (RoomInBuffer);
}
\end{code}
{
clqpos = clqsize = 0;
- if ( ClosureQueue == NULL ) {
- AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
- }
+ if ( ClosureQueue == NULL )
+ AllocClosureQueue(PACK_BUFFER_SIZE);
}
\end{code}
QueueClosure(closure)
P_ closure;
{
- if(clqsize < RTSflags.ParFlags.packBufferSize)
+ if(clqsize < PACK_BUFFER_SIZE )
ClosureQueue[clqsize++] = closure;
else
{
of GA.
\begin{code}
+#if defined(PAR)
rtsBool
isOffset(ga)
globalAddr *ga;
{
return (ga->weight == 0);
}
+#endif
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-#ifdef DEBUG
+#if defined(DEBUG) || defined(GRAN_CHECK)
+
+#if defined(PAR)
void
PrintPacket(buffer)
P_ buffer;
{
W_ size, ptrs, nonptrs, vhs;
+ char str[80];
globalAddr ga;
fprintf(stderr, "[%u]: (%x, %d, %x) ", gastart,
ga.loc.gc.gtid, ga.loc.gc.slot, ga.weight);
- info = get_closure_info((P_) (buffer + closurestart), &size, &ptrs, &nonptrs, &vhs);
+ info = get_closure_info((P_) (buffer + closurestart), &size,
+ &ptrs, &nonptrs, &vhs, str);
if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
size = ptrs = nonptrs = vhs = 0;
if (parent == NULL)
break;
else {
- (void) get_closure_info(parent, &size, &pptrs, &nonptrs, &pvhs);
+ (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
+ &pvhs, str);
pptr = 0;
}
}
fprintf(stderr, "--- End ---\n\n");
}
-#endif
+#else /* GRAN */
+void
+PrintPacket(buffer)
+P_ buffer;
+{
+ extern char *info_hdr_type(P_ infoptr); /* defined in Threads.lc */
+ extern char *info_type(P_ infoptr); /* defined in Threads.lc */
+
+ char str1[80], str2[80], junk_str[80];
+
+ W_ size, ptrs, nonptrs, vhs;
+
+ /* globalAddr ga; */
+
+ W_ bufsize, unpackedsize ;
+ P_ parent;
+ W_ pptr = 0, pptrs = 0, pvhs;
+
+ W_ unpacklocn = PACK_HDR_SIZE;
+ W_ gastart = unpacklocn;
+ W_ closurestart = unpacklocn;
+
+ P_ info, tso;
+ P_ closure;
+
+ int i;
+
+ InitClosureQueue();
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
+ fprintf(stderr,"Packet @ 0x%lx hs no flag : 0x%lx\n",
+ buffer, buffer[PACK_FLAG_LOCN]);
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
+ tso = (P_) buffer[PACK_TSO_LOCN];
+
+ /* Unpack the header */
+ unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
+ bufsize = buffer[PACK_SIZE_LOCN];
+
+ fprintf(stderr, "Packed Packet %#lx, size %u (unpacked size is %u); demanded by TSO %#lx (%d)(PE %d)\n--- Begin ---\n",
+ buffer, bufsize, unpackedsize, tso, TSO_ID(tso), where_is(tso));
+
+ do {
+ closurestart = unpacklocn;
+ closure = (P_) buffer[unpacklocn++];
+
+ fprintf(stderr, "[%u]: (%#lx) ", closurestart, closure);
+
+ info = get_closure_info((P_) (closure),
+ &size, &ptrs, &nonptrs, &vhs,str1);
+ strcpy(str2,info_type(info));
+ fprintf(stderr, "(%s|%s) ", str1, str2);
+
+ if (INFO_TYPE(info) == INFO_FETCHME_TYPE || IS_BLACK_HOLE(info))
+ size = ptrs = nonptrs = vhs = 0;
+
+ if (IS_THUNK(info)) {
+ if (IS_UPDATABLE(info))
+ fputs("SHARED ", stderr);
+ else
+ fputs("UNSHARED ", stderr);
+ }
+ if (IS_BLACK_HOLE(info)) {
+ fputs("BLACK HOLE\n", stderr);
+ } else {
+ /* Fixed header */
+ fprintf(stderr, "FH [%#lx", closure[0]);
+ for (i = 1; i < FIXED_HS; i++)
+ fprintf(stderr, " %#lx", closure[i]);
+
+ /* Variable header */
+ if (vhs > 0) {
+ fprintf(stderr, "] VH [%#lx", closure[FIXED_HS]);
+
+ for (i = 1; i < vhs; i++)
+ fprintf(stderr, " %#lx", closure[FIXED_HS+i]);
+ }
+
+ fprintf(stderr, "] PTRS %u", ptrs);
+
+ /* Non-pointers */
+ if (nonptrs > 0) {
+ fprintf(stderr, " NPTRS [%#lx", closure[FIXED_HS+vhs]);
+
+ for (i = 1; i < nonptrs; i++)
+ fprintf(stderr, " %#lx", closure[FIXED_HS+vhs+i]);
+
+ putc(']', stderr);
+ }
+ putc('\n', stderr);
+ }
+ } while (unpacklocn<bufsize) ; /* (parent != NULL); */
+
+ fprintf(stderr, "--- End ---\n\n");
+}
+#endif /* PAR */
+#endif /* DEBUG || GRAN_CHECK */
\end{code}
%************************************************************************
\begin{code}
P_
-get_closure_info(closure, size, ptrs, nonptrs, vhs)
+get_closure_info(closure, size, ptrs, nonptrs, vhs, type)
P_ closure;
W_ *size, *ptrs, *nonptrs, *vhs;
+char *type;
{
- P_ ip = (P_) INFO_PTR(closure);
+ P_ ip = (P_) INFO_PTR(closure);
+
+ if (closure==NULL) {
+ fprintf(stderr, "Qagh {get_closure_info}Daq: NULL closure\n");
+ *size = *ptrs = *nonptrs = *vhs = 0;
+ strcpy(type,"ERROR in get_closure_info");
+ return;
+ } else if (closure==Prelude_Z91Z93_closure) {
+ /* fprintf(stderr, "Qagh {get_closure_info}Daq: Prelude_Z91Z93_closure closure\n"); */
+ *size = *ptrs = *nonptrs = *vhs = 0;
+ strcpy(type,"Prelude_Z91Z93_closure");
+ return;
+ };
+
+ ip = (P_) INFO_PTR(closure);
switch (INFO_TYPE(ip)) {
case INFO_SPEC_U_TYPE:
*ptrs = SPEC_CLOSURE_NoPTRS(closure);
*nonptrs = SPEC_CLOSURE_NoNONPTRS(closure);
*vhs = 0 /*SPEC_VHS*/;
+ strcpy(type,"SPEC");
break;
case INFO_GEN_U_TYPE:
*ptrs = GEN_CLOSURE_NoPTRS(closure);
*nonptrs = GEN_CLOSURE_NoNONPTRS(closure);
*vhs = GEN_VHS;
+ strcpy(type,"GEN");
break;
case INFO_DYN_TYPE:
*ptrs = DYN_CLOSURE_NoPTRS(closure);
*nonptrs = DYN_CLOSURE_NoNONPTRS(closure);
*vhs = DYN_VHS;
+ strcpy(type,"DYN");
break;
case INFO_TUPLE_TYPE:
*ptrs = TUPLE_CLOSURE_NoPTRS(closure);
*nonptrs = TUPLE_CLOSURE_NoNONPTRS(closure);
*vhs = TUPLE_VHS;
+ strcpy(type,"TUPLE");
break;
case INFO_DATA_TYPE:
*ptrs = DATA_CLOSURE_NoPTRS(closure);
*nonptrs = DATA_CLOSURE_NoNONPTRS(closure);
*vhs = DATA_VHS;
+ strcpy(type,"DATA");
break;
case INFO_IMMUTUPLE_TYPE:
*ptrs = MUTUPLE_CLOSURE_NoPTRS(closure);
*nonptrs = MUTUPLE_CLOSURE_NoNONPTRS(closure);
*vhs = MUTUPLE_VHS;
+ strcpy(type,"(IM)MUTUPLE");
break;
case INFO_STATIC_TYPE:
*ptrs = STATIC_CLOSURE_NoPTRS(closure);
*nonptrs = STATIC_CLOSURE_NoNONPTRS(closure);
*vhs = STATIC_VHS;
+ strcpy(type,"STATIC");
break;
case INFO_CAF_TYPE:
*ptrs = IND_CLOSURE_NoPTRS(closure);
*nonptrs = IND_CLOSURE_NoNONPTRS(closure);
*vhs = IND_VHS;
+ strcpy(type,"CAF|IND");
break;
case INFO_CONST_TYPE:
*ptrs = CONST_CLOSURE_NoPTRS(closure);
*nonptrs = CONST_CLOSURE_NoNONPTRS(closure);
*vhs = CONST_VHS;
+ strcpy(type,"CONST");
break;
case INFO_SPEC_RBH_TYPE:
} else
*ptrs -= 1;
*vhs = SPEC_RBH_VHS;
+ strcpy(type,"SPEC_RBH");
break;
case INFO_GEN_RBH_TYPE:
} else
*ptrs -= 1;
*vhs = GEN_RBH_VHS;
+ strcpy(type,"GEN_RBH");
break;
case INFO_CHARLIKE_TYPE:
*ptrs = CHARLIKE_CLOSURE_NoPTRS(closure);
*nonptrs = CHARLIKE_CLOSURE_NoNONPTRS(closure);
*vhs = CHARLIKE_VHS;
+ strcpy(type,"CHARLIKE");
break;
case INFO_INTLIKE_TYPE:
*ptrs = INTLIKE_CLOSURE_NoPTRS(closure);
*nonptrs = INTLIKE_CLOSURE_NoNONPTRS(closure);
*vhs = INTLIKE_VHS;
+ strcpy(type,"INTLIKE");
break;
+# if !defined(GRAN)
case INFO_FETCHME_TYPE:
*size = FETCHME_CLOSURE_SIZE(closure);
*ptrs = FETCHME_CLOSURE_NoPTRS(closure);
*nonptrs = FETCHME_CLOSURE_NoNONPTRS(closure);
*vhs = FETCHME_VHS;
+ strcpy(type,"FETCHME");
break;
case INFO_FMBQ_TYPE:
*ptrs = FMBQ_CLOSURE_NoPTRS(closure);
*nonptrs = FMBQ_CLOSURE_NoNONPTRS(closure);
*vhs = FMBQ_VHS;
+ strcpy(type,"FMBQ");
break;
+# endif
case INFO_BQ_TYPE:
*size = BQ_CLOSURE_SIZE(closure);
*ptrs = BQ_CLOSURE_NoPTRS(closure);
*nonptrs = BQ_CLOSURE_NoNONPTRS(closure);
*vhs = BQ_VHS;
+ strcpy(type,"BQ");
break;
case INFO_BH_TYPE:
*ptrs = BH_CLOSURE_NoPTRS(closure);
*nonptrs = BH_CLOSURE_NoNONPTRS(closure);
*vhs = BH_VHS;
+ strcpy(type,"BH");
break;
+ case INFO_TSO_TYPE:
+ *size = 0; /* TSO_CLOSURE_SIZE(closure); */
+ *ptrs = 0; /* TSO_CLOSURE_NoPTRS(closure); */
+ *nonptrs = 0; /* TSO_CLOSURE_NoNONPTRS(closure); */
+ *vhs = TSO_VHS;
+ strcpy(type,"TSO");
+ break;
+
+ case INFO_STKO_TYPE:
+ *size = 0;
+ *ptrs = 0;
+ *nonptrs = 0;
+ *vhs = STKO_VHS;
+ strcpy(type,"STKO");
+ break;
+
default:
fprintf(stderr, "get_closure_info: Unexpected closure type (%lu), closure %lx\n",
INFO_TYPE(ip), (W_) closure);
is available, but it will not perform garbage collection.
\begin{code}
-
P_
AllocateHeap(size)
W_ size;
return newClosure;
}
+#if defined(PAR)
+
void
doGlobalGC(STG_NO_ARGS)
{
EXIT(EXIT_FAILURE);
fishing = rtsFalse;
}
+
+#endif /* PAR */
\end{code}
\begin{code}
-#endif /* PAR -- whole file */
+#endif /* PAR || GRAN -- whole file */
\end{code}
%************************************************************************
\begin{code}
-#ifdef PAR /* whole file */
+#if defined(PAR) || defined(GRAN) /* whole file */
#include "rtsdefs.h"
\end{code}
P_ infoPtr, newInfoPtr;
W_ size, ptrs, nonptrs, vhs;
P_ rbh_save;
- int isSpec;
+ rtsBool isSpec;
+ char str[80];
if ((rbh_save = AllocateHeap(SPEC_HS + 2)) == NULL)
return NULL;
- infoPtr = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs);
+ infoPtr = get_closure_info(closure, &size, &ptrs, &nonptrs, &vhs, str);
ASSERT(size >= MIN_UPD_SIZE);
switch (BASE_INFO_TYPE(infoPtr)) {
case INFO_SPEC_TYPE:
- isSpec = 1;
+ isSpec = rtsTrue;
break;
case INFO_GEN_TYPE:
- isSpec = 0;
+ isSpec = rtsFalse;
break;
default:
fprintf(stderr, "Panic: turn %#lx (IP %#lx) into RBH\n", (W_)closure, (W_)infoPtr);
awaken the blocking queue. What a nuisance! Fortunately,
@AwakenBlockingQueue@ should now know what to do.
+A note on GrAnSim: In GrAnSim we don't have FetchMe closures. However, we
+have to turn a RBH back to its original form when the simulated transfer
+of the closure has been finished. Therefore we need the @convertFromRBH@
+routine below. After converting the RBH back to its original form and
+awakening all TSOs, the first TSO will reenter the closure which is now
+local and carry on merrily reducing it (the other TSO will be less merrily
+blocked on the now local closure; we're costing the difference between
+local and global blocks in the BQ code).
+
\begin{code}
+#if defined(PAR)
+
EXTDATA_RO(FetchMe_info);
void
if (IS_MUTABLE(INFO_PTR(bqe)))
AwakenBlockingQueue(bqe);
}
+#else /* GRAN */
+/* Prototype */
+void UnlinkFromMUT(P_ closure);
+
+void
+convertFromRBH(closure) /* The corresponding function in GUM is: */
+ /* convertToFetchMe */
+P_ closure;
+{
+ P_ ip = (P_) INFO_PTR(closure);
+ P_ bqe, rbh_save = Prelude_Z91Z93_closure;
+ int isSpec;
+#if defined(GCap) || defined(GCgn)
+ rtsBool linked = IS_MUTABLE(ip) && MUT_LINK(closure) != MUT_NOT_LINKED;
+ P_ oldLink = MUT_LINK(closure);
+#endif
+
+ switch(INFO_TYPE(ip)) {
+ case INFO_SPEC_RBH_TYPE:
+ bqe = (P_) SPEC_RBH_BQ(closure);
+ isSpec = 1;
+ break;
+ case INFO_GEN_RBH_TYPE:
+ bqe = (P_) GEN_RBH_BQ(closure);
+ isSpec = 0;
+ break;
+ default:
+#if 1
+ fprintf(stderr, "Weird...just tried to convert %#lx (IP %#lx) to FetchMe\n",
+ closure, ip);
+#endif
+ return;
+ }
+
+# if defined(GCap) || defined(GCgn)
+ /* If the RBH is turned back to a SPEC or GEN closure we have to take
+ it off the mutables list */
+
+ if (linked) {
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x100) {
+ fprintf(stderr,"\n**>>>> Unlinking closure %#lx from mutables list on PE %d @ %ld (next mutable=%#lx)\n",
+ closure,
+ where_is(closure), CurrentTime[where_is(closure)],
+ MUT_LINK(closure));
+ GN(closure);
+ }
+# endif
+ UnlinkFromMUT(closure);
+ }
+# endif
+
+ /* FETCHME_GA(closure) = ga; */
+ if (IS_MUTABLE(INFO_PTR(bqe))) {
+ PROC old_proc = CurrentProc, /* NB: For AwakenBlockingQueue, */
+ new_proc = where_is(closure); /* CurentProc must be where */
+ /* closure lives. */
+ CurrentProc = new_proc;
+
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x100)
+ fprintf(stderr,"===== AwBQ of node 0x%lx (%s) [PE %2u]\n",
+ closure, (isSpec ? "SPEC_RBH" : "GEN_RBH"), new_proc);
+# endif
+
+ rbh_save = AwakenBlockingQueue(bqe); /* AwakenBlockingQueue(bqe); */
+ CurrentProc = old_proc;
+ } else {
+ rbh_save = bqe;
+ }
+
+ /* Put data from special RBH save closures back into the closure */
+ if ( rbh_save == Prelude_Z91Z93_closure ) {
+ fprintf(stderr,"convertFromRBH: No RBH_Save_? closure found at end of BQ!\n");
+ EXIT(EXIT_FAILURE);
+ } else {
+ closure[isSpec ? SPEC_HS : GEN_HS] = rbh_save[SPEC_HS];
+ closure[(isSpec ? SPEC_HS : GEN_HS) + 1] = rbh_save[SPEC_HS + 1];
+ }
+
+ /* Put back old info pointer (only in GrAnSim) -- HWL */
+ SET_INFO_PTR(closure, REVERT_INFOPTR(INFO_PTR(closure)));
+
+}
+
+/* Remove closure from the mutables list */
+
+void
+UnlinkFromMUT(P_ closure)
+{
+ P_ curr = StorageMgrInfo.OldMutables, prev = NULL;
+
+ while (curr != NULL && curr != closure) {
+ ASSERT(MUT_LINK(curr)!=MUT_NOT_LINKED);
+ prev=curr;
+ curr=MUT_LINK(curr);
+ }
+ if (curr==closure) {
+ if (prev==NULL)
+ StorageMgrInfo.OldMutables = MUT_LINK(curr);
+ else
+ MUT_LINK(prev) = MUT_LINK(curr);
+ MUT_LINK(curr) = MUT_NOT_LINKED;
+ }
+}
+
+#endif /* PAR */
#endif /* PAR -- whole file */
\end{code}
%
% (c) The Parade/AQUA Projects, Glasgow University, 1994-1995.
% P. Trinder, November 30th. 1994.
-%
+%
%****************************************************************************
The Sysman task currently controls initiation, termination, of a
argv++; argc--;
}
sysman_id = pvm_mytid();/* This must be the first PVM call */
+
checkerr(sysman_id);
/*
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) {
- nPEs--;
/* Initialise the PE task arguments from Sysman's arguments */
pargv = argv + 2;
#if 0
% (c) Parade/AQUA Projects, Glasgow University, 1995
% Kevin Hammond, February 15th. 1995
%
-% This is for GUM only.
+% This is for GUM and GrAnSim.
%
%************************************************************************
%* *
This module defines routines for unpacking closures in the parallel runtime
system (GUM).
-\begin{code}
-#ifdef PAR /* whole file */
+In the case of GrAnSim, this module defines routines for *simulating* the
+unpacking of closures as it is done in the parallel runtime system.
+\begin{code}
#include "rtsdefs.h"
+
+#if defined(PAR)
+
EXTDATA_RO(FetchMe_info);
\end{code}
bqe = (P_) GEN_RBH_BQ(src);
break;
case INFO_FETCHME_TYPE:
- bqe = Nil_closure;
+ bqe = Prelude_Z91Z93_closure;
break;
case INFO_FMBQ_TYPE:
bqe = (P_) FMBQ_ENTRIES(src);
W_ bufsize;
P_ graphroot, graph, parent;
W_ pptr = 0, pptrs = 0, pvhs;
+ char str[80];
int i;
globalAddr *gaga;
* same way as they will be in the heap...at least up through the
* end of the variable header.
*/
- ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs);
+ ip = get_closure_info(bufptr, &size, &ptrs, &nonptrs, &vhs, str);
/* Fill in the fixed header */
for (i = 0; i < FIXED_HS; i++)
if (parent == NULL)
break;
else {
- (void) get_closure_info(parent, &size, &pptrs, &nonptrs, &pvhs);
+ (void) get_closure_info(parent, &size, &pptrs, &nonptrs,
+ &pvhs, str);
pptr = 0;
}
}
/* ToDo: are we *certain* graphroot has been set??? WDP 95/07 */
return (graphroot);
}
+#endif /* PAR */
\end{code}
+For GrAnSim:
+In general no actual unpacking should be necessary. We just have to walk
+over the graph and set the bitmasks appropriately. -- HWL
+
\begin{code}
-#endif /* PAR -- whole file */
+#if defined(GRAN)
+/* This code fakes the unpacking of a somewhat virtual buffer */
+P_
+UnpackGraph(buffer)
+P_ buffer;
+{
+ W_ size, ptrs, nonptrs, vhs;
+ P_ bufptr, closurestart;
+ P_ slotptr;
+ P_ closure, existing;
+ P_ ip, oldip;
+ W_ bufsize, unpackedsize;
+ P_ graphroot, graph, parent;
+ W_ pptr = 0, pptrs = 0, pvhs;
+ char str[80];
+ int i;
+ P_ tso;
+
+ bufptr = buffer + PACK_HDR_SIZE;
+ graphroot = *bufptr;
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if (buffer[PACK_FLAG_LOCN] != MAGIC_PACK_FLAG) {
+ fprintf(stderr,"Qagh: no magic flag at start of packet @ 0x%lx\n",
+ buffer);
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
+ tso = buffer[PACK_TSO_LOCN];
+
+ /* Unpack the header */
+ unpackedsize = buffer[PACK_UNPACKED_SIZE_LOCN];
+ bufsize = buffer[PACK_SIZE_LOCN];
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr,"\nUnpacking buffer @ 0x%x (root @ 0x%x, PE %d,size
+= %d), demanded by TSO 0x%x (%d)(PE %d)\n",
+ buffer,graphroot,where_is(graphroot), bufsize, tso, TSO_ID(tso), where_is(tso));
+# endif
+
+ do {
+ closurestart = bufptr;
+ closure = *bufptr++; /* that's all we need for GrAnSim -- HWL */
+
+ /* Actually only ip is needed; rest is useful for TESTING -- HWL */
+ ip = get_closure_info(closure,
+ &size, &ptrs, &nonptrs, &vhs, str);
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr,"(0x%x): Bitmask changed [%s]: 0x%x ",
+ closure, (IS_NF(INFO_PTR(closure)) ? "NF" : "__"),
+ PROCS(closure));
+# endif
+
+ if ( (INFO_TYPE(ip) == INFO_SPEC_RBH_TYPE) ||
+ (INFO_TYPE(ip) == INFO_GEN_RBH_TYPE) ) {
+ PROCS(closure) = PE_NUMBER(CurrentProc); /* Move node */
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ fprintf(stderr," ---> 0x%x\n", PROCS(closure));
+ fprintf(stderr,"< Converting RBH @ 0x%x into an updatable
+closure again\n",
+ closure);
+ }
+# endif
+ convertFromRBH(closure); /* In GUM that's done by convertToFetchMe */
+ } else if (IS_BLACK_HOLE(ip)) {
+ PROCS(closure) |= PE_NUMBER(CurrentProc); /* Copy node */
+ } else if ( (PROCS(closure) & PE_NUMBER(CurrentProc)) == 0 ) {
+ if (IS_NF(ip)) /* Old: || IS_BQ(node) */
+ PROCS(closure) |= PE_NUMBER(CurrentProc); /* Copy node */
+ else
+ PROCS(closure) = PE_NUMBER(CurrentProc); /* Move node */
+ }
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( RTSflags.GranFlags.debug & 0x100 )
+ fprintf(stderr," ---> 0x%x\n", PROCS(closure));
+# endif
+
+ } while (bufptr<(buffer+bufsize)) ; /* (parent != NULL); */
+
+ /* In GrAnSim we allocate pack buffers dynamically! -- HWL */
+ free(buffer);
+
+ return (graphroot);
+}
+#endif /* GRAN */
\end{code}
+
--- /dev/null
+\begin{code}
+#include "rtsdefs.h"
+
+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
+ 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
+ */
+}
+\end{code}
--- /dev/null
+
+
+\begin{code}
+#ifdef CONCURRENT /* the whole thing! */
+#include "rtsdefs.h"
+
+void
+NoRunnableThreadsHook ()
+{
+ fprintf(stderr, "No runnable threads!\n");
+}
+#endif /* CONCURRENT */
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[acceptSocket.lc]{Server wait for client to connect}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+StgInt
+acceptSocket(I_ sockfd, A_ peer, A_ addrlen)
+{
+ StgInt fd;
+
+ while ((fd = accept((int)sockfd, (struct sockaddr *)peer, (int *)addrlen)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address not in writeable part of user address space";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor not a socket";
+ break;
+ case GHC_EOPNOTSUPP:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not of type that supports listen";
+ break;
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "No sockets are present to be accepted";
+ break;
+ }
+ return -1;
+ }
+ }
+ return fd;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1995
+%
+\subsection[bindSocket.lc]{Assign name to unnamed socket}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+StgInt
+bindSocket(I_ sockfd, A_ myaddr, I_ addrlen, I_ isUnixDomain)
+{
+ int rc;
+
+ while ((rc = bind((int)sockfd, (struct sockaddr *)myaddr, (int)addrlen)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ if (isUnixDomain != 0)
+ ghc_errstr = "For a component of path prefix of path name";
+ else
+ ghc_errstr = "Requested address protected, cannot bind socket";
+ break;
+ case GHC_EISCONN:
+ case GHC_EADDRINUSE:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "Address already in use";
+ break;
+ case GHC_EADDRNOTAVAIL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Address not available from local machine";
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid socket file descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address not in valid part of user address space";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Specified size of structure not equal valid address for family";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Descriptor for file, not a socket";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Could not make directory entry or alloc inode";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "A null path name was given";
+ break;
+ case GHC_ELOOP:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Too many symbolic links encountered";
+ break;
+ case GHC_ENAMETOOLONG:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Max length of path name exceeded";
+ break;
+ case GHC_ENOENT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix does not exist";
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix is not a directory";
+ break;
+ case GHC_EROFS:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "The inode would reside on read only file system";
+ break;
+ }
+ return -1;
+ }
+ }
+ return 0;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1995
+%
+\subsection[connectSocket.lc]{Assign name to client socket}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+StgInt
+connectSocket(I_ sockfd, A_ servaddr, I_ addrlen, I_ isUnixDomain)
+{
+ int rc;
+
+ while ((rc = connect((int)sockfd, (struct sockaddr *)servaddr, (int)addrlen)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ if (isUnixDomain != 0)
+ ghc_errstr = "For a component of path prefix of path name";
+ else
+ ghc_errstr = "Requested address protected, cannot bind socket";
+ break;
+ case GHC_EISCONN:
+ case GHC_EADDRINUSE:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "Address already in use";
+ break;
+ case GHC_EADDRNOTAVAIL:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Address not available from local machine";
+ break;
+ case GHC_EAFNOSUPPORT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address cannot be used with socket";
+ break;
+ case GHC_EINPROGRESS:
+ case GHC_EALREADY:
+ ghc_errtype = ERR_RESOURCEBUSY;
+ ghc_errstr = "Non-blocking socket, previous connection attempt not completed";
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid socket file descriptor";
+ break;
+ case GHC_ECONNREFUSED:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Connection rejected";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Address not in valid part of process address space";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Specified size of structure not equal valid address for family";
+ break;
+ break;
+ case GHC_ENETUNREACH:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "Network not reachable from host";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Descriptor for file, not a socket";
+ break;
+ case GHC_ETIMEDOUT:
+ ghc_errtype = ERR_TIMEEXPIRED;
+ ghc_errstr = "Connection attempt timed out";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Could not make directory entry or alloc inode";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "A null path name was given";
+ break;
+ case GHC_ELOOP:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Too many symbolic links encountered";
+ break;
+ case GHC_ENAMETOOLONG:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Max length of path name exceeded";
+ break;
+ case GHC_ENOENT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix does not exist";
+ break;
+ case GHC_ENOTDIR:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Component in path prefix is not a directory";
+ break;
+ case GHC_EPROTOTYPE:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "File referred to is a socket of differing type";
+ break;
+ }
+ return -1;
+ }
+ }
+ return 0;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1995
+%
+\subsection[createSocket.lc]{Create a socket file descriptor}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+StgInt
+createSocket(I_ family, I_ type, I_ protocol)
+{
+ int fd;
+
+ if ((fd = socket((int)family, (int)type, (int)protocol)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EACCES:
+ ghc_errtype = ERR_PERMISSIONDENIED;
+ ghc_errstr = "cannot create socket";
+ break;
+ case GHC_EMFILE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Too many open files";
+ break;
+ case GHC_ENFILE:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "System file table overflow";
+ break;
+ case GHC_EPROTONOSUPPORT:
+ ghc_errtype = ERR_UNSUPPORTEDOPERATION;
+ ghc_errstr = "Protocol type not supported";
+ break;
+ case GHC_EPROTOTYPE:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Protocol wrong type for socket";
+ break;
+ }
+ return (StgInt)-1;
+ }
+ }
+ return (StgInt)fd;
+}
+
+\end{code}
return 0;
}
-/* Set or replace an environment variable */
+/* Set or replace an environment variable
+ * simonm 14/2/96 - this is different to the standard C library
+ * implementation and the prototypes clash, so I'm calling it _setenv.
+ */
int
-setenv(mapping)
+_setenv(mapping)
char *mapping;
{
int i, keylen;
\begin{code}
+#define NON_POSIX_SOURCE
+
#include "rtsdefs.h"
#include "stgio.h"
#include "libposix.h"
\subsection[getCPUTime.lc]{getCPUTime Runtime Support}
\begin{code}
+#define NON_POSIX_SOURCE /*needed for solaris2 only?*/
+/* how is this to work given we have not read platform.h yet? */
#ifdef hpux_TARGET_OS
#define _INCLUDE_HPUX_SOURCE
#endif
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[getPeerName.lc]{Return name of peer process}
+
+Returns name of peer process connected to a socket.
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+StgInt
+getPeerName(int sockfd, struct sockaddr *peer, int *namelen)
+{
+ StgInt name;
+
+ while ((name = getpeername(sockfd, peer, namelen)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data not in writeable part of user address space";
+ break;
+ case GHC_ENOBUFS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Insuffcient resources";
+ break;
+ case GHC_ENOTCONN:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not connected";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor is not a socket";
+ break;
+ }
+ return -1;
+ }
+ }
+ return name;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[getSockName.lc]{Return name of process assoc with socket}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+
+StgInt
+getSockName(int sockfd, struct sockaddr *peer, int *namelen)
+{
+ StgInt name;
+
+ while ((name = getsockname(sockfd, peer, namelen)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data not in writeable part of user address space";
+ break;
+ case GHC_ENOBUFS:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Insuffcient resources";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor is not a socket";
+ break;
+ }
+ return -1;
+ }
+ }
+ return name;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[listenSocket.lc]{Indicate willingness to receive connections}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_SOCKET_H
+#include <sys/socket.h>
+#endif
+
+StgInt
+listenSocket(int sockfd, int backlog)
+{
+ int rc;
+
+ while ((rc = listen(sockfd, backlog)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid descriptor";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor not a socket";
+ break;
+ case GHC_EOPNOTSUPP:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not of type that supports listen";
+ break;
+ }
+ return -1;
+ }
+ }
+ return 0;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[readDescriptor.lc]{Suck some bytes from a descriptor}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+StgInt
+readDescriptor(int fd, char *buf, int nbytes)
+{
+ StgInt sucked;
+
+ while ((sucked = read(fd, buf, nbytes)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EBADMSG:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Message waiting to be read is not a data message";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data buffer not in writeable part of user address space";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Seek pointer associated with descriptor negative";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "I/O error occurred while writing to file system";
+ break;
+ case GHC_EISDIR:
+ ghc_errtype = ERR_INAPPROPRIATETYPE;
+ ghc_errstr = "Descriptor refers to a directory";
+ break;
+ case GHC_EAGAIN:
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "No data could be written immediately";
+ break;
+ }
+ return -1;
+ }
+ }
+ return sucked;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[shutdownSocket.lc]{Shut down part of full duplex connection}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+StgInt
+shutdownSocket(int sockfd, int how)
+{
+ StgInt rc;
+
+ while ((rc = shutdown(sockfd, how)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_ENOTCONN:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Socket not connected";
+ break;
+ case GHC_ENOTSOCK:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Descriptor is not a socket";
+ break;
+ }
+ return -1;
+ }
+ }
+ return rc;
+}
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1996
+%
+\subsection[writeDescriptor.lc]{Stuff bytes down a descriptor}
+
+\begin{code}
+
+#include "rtsdefs.h"
+#include "stgio.h"
+
+StgInt
+writeDescriptor(int fd, char *buf, int nbytes)
+{
+ StgInt dumped;
+
+ while ((dumped = write(fd, buf, nbytes)) < 0) {
+ if (errno != EINTR) {
+ cvtErrno();
+ switch (ghc_errno) {
+ default:
+ stdErrno();
+ break;
+ case GHC_EBADF:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Not a valid write descriptor";
+ break;
+ case GHC_EDQUOT:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Disk quota exhausted";
+ break;
+ case GHC_EFAULT:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Data not in writeable part of user address space";
+ break;
+ case GHC_EFBIG:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "Maximum process or system file size exceeded";
+ break;
+ case GHC_EINVAL:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Seek pointer associated with descriptor negative";
+ break;
+ case GHC_EIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "I/O error occurred while writing to file system";
+ break;
+ case GHC_ENOSPC:
+ ghc_errtype = ERR_RESOURCEEXHAUSTED;
+ ghc_errstr = "No space left on device";
+ break;
+ case GHC_ENXIO:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Hangup occurred";
+ break;
+ case GHC_EPIPE:
+ ghc_errtype = ERR_SYSTEMERROR;
+ ghc_errstr = "Write to not read pipe/unconnected socket caught";
+ break;
+ case GHC_ERANGE:
+ ghc_errtype = ERR_INVALIDARGUMENT;
+ ghc_errstr = "Too much or too little written to descriptor";
+ break;
+ case GHC_EAGAIN:
+ case GHC_EWOULDBLOCK:
+ ghc_errtype = ERR_OTHERERROR;
+ ghc_errstr = "No data could be written immediately";
+ break;
+ }
+ return -1;
+ }
+ }
+ return dumped;
+}
+
+\end{code}
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1995 - 1996
+% Hans Wolfgang Loidl
+%
+% Time-stamp: <Wed Jun 19 1996 16:38:25 Stardate: [-31]7683.25 hwloidl>
%
%************************************************************************
%* *
#define NON_POSIX_SOURCE /* gettimeofday */
-#include "rtsdefs.h"
+#include "rtsdefs.h"
+
+/* qaStaH nuq Sovpu' ngoqvam ghItlhpu'bogh nuv 'e' vItul */
+# if defined(HAVE_GETCLOCK)
+# if defined(HAVE_SYS_TIMERS_H)
+# define POSIX_4D9 1
+# include <sys/timers.h>
+# endif
+# else
+# if defined(HAVE_GETTIMEOFDAY)
+# if defined(HAVE_SYS_TIME_H)
+# include <sys/time.h>
+# endif
+# else
+# ifdef HAVE_TIME_H
+# include <time.h>
+# endif
+# endif
+# endif
+\end{code}
-#ifdef HAVE_GETCLOCK
+%****************************************************************
+%* *
+\subsection[GranSim-data-types]{Basic data types and set-up variables for GranSim}
+%* *
+%****************************************************************
-#ifdef HAVE_SYS_TIMERS_H
-#define POSIX_4D9 1
-#include <sys/timers.h>
-#endif
+\begin{code}
-#else
-#ifdef HAVE_GETTIMEOFDAY
+/* See GranSim.lh for the definition of the enum gran_event_types */
+char *gran_event_names[] = {
+ "START", "START(Q)",
+ "STEALING", "STOLEN", "STOLEN(Q)",
+ "FETCH", "REPLY", "BLOCK", "RESUME", "RESUME(Q)",
+ "SCHEDULE", "DESCHEDULE",
+ "END",
+ "SPARK", "SPARKAT", "USED", "PRUNED", "EXPORTED", "ACQUIRED",
+ "ALLOC",
+ "TERMINATE",
+ "SYSTEM_START", "SYSTEM_END", /* only for debugging */
+ "??"
+};
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#endif
+#if defined(GRAN)
+char *proc_status_names[] = {
+ "Idle", "Sparking", "Starting", "Fetching", "Fishing", "Busy",
+ "UnknownProcStatus"
+};
-#else
+#define RAND_MAX 0x7fffffff /* 2^31-1 = 0x80000000 - 1 (see lrand48(3) */
-#ifdef HAVE_TIME_H
-#include <time.h>
-#endif
+unsigned CurrentProc = 0;
+rtsBool IgnoreEvents = rtsFalse; /* HACK only for testing */
-#endif
-#endif
+#endif /* GRAN */
+\end{code}
-void grputw PROTO((TIME v));
+The following variables control the behaviour of GrAnSim. In general, there
+is one RTS option for enabling each of these features. In getting the
+desired setup of GranSim the following questions have to be answered:
+\begin{itemize}
+\item {\em Which scheduling algorithm} to use (@RTSflags.GranFlags.DoFairSchedule@)?
+ Currently only unfair scheduling is supported.
+\item What to do when remote data is fetched (@RTSflags.GranFlags.DoReScheduleOnFetch@)?
+ Either block and wait for the
+ data or reschedule and do some other work.
+ Thus, if this variable is true, asynchronous communication is
+ modelled. Block on fetch mainly makes sense for incremental fetching.
+
+ There is also a simplified fetch variant available
+ (@RTSflags.GranFlags.SimplifiedFetch@). This variant does not use events to model
+ communication. It is faster but the results will be less accurate.
+\item How aggressive to be in getting work after a reschedule on fetch
+ (@RTSflags.GranFlags.FetchStrategy@)?
+ This is determined by the so-called {\em fetching
+ strategy\/}. Currently, there are four possibilities:
+ \begin{enumerate}
+ \item Only run a runnable thread.
+ \item Turn a spark into a thread, if necessary.
+ \item Steal a remote spark, if necessary.
+ \item Steal a runnable thread from another processor, if necessary.
+ \end{itemize}
+ The variable @RTSflags.GranFlags.FetchStrategy@ determines how far to go in this list
+ when rescheduling on a fetch.
+\item Should sparks or threads be stolen first when looking for work
+ (@RTSflags.GranFlags.DoStealThreadsFirst@)?
+ The default is to steal sparks first (much cheaper).
+\item Should the RTS use a lazy thread creation scheme
+ (@RTSflags.GranFlags.DoAlwaysCreateThreads@)? By default yes i.e.\ sparks are only
+ turned into threads when work is needed. Also note, that sparks
+ can be discarded by the RTS (this is done in the case of an overflow
+ of the spark pool). Setting @RTSflags.GranFlags.DoAlwaysCreateThreads@ to @True@ forces
+ the creation of threads at the next possibility (i.e.\ when new work
+ is demanded the next time).
+\item Should data be fetched closure-by-closure or in packets
+ (@RTSflags.GranFlags.DoGUMMFetching@)? The default strategy is a GRIP-like incremental
+ (i.e.\ closure-by-closure) strategy. This makes sense in a
+ low-latency setting but is bad in a high-latency system. Setting
+ @RTSflags.GranFlags.DoGUMMFetching@ to @True@ enables bulk (packet) fetching. Other
+ parameters determine the size of the packets (@pack_buffer_size@) and the number of
+ thunks that should be put into one packet (@RTSflags.GranFlags.ThunksToPack@).
+\item If there is no other possibility to find work, should runnable threads
+ be moved to an idle processor (@RTSflags.GranFlags.DoThreadMigration@)? In any case, the
+ RTS tried to get sparks (either local or remote ones) first. Thread
+ migration is very expensive, since a whole TSO has to be transferred
+ and probably data locality becomes worse in the process. Note, that
+ the closure, which will be evaluated next by that TSO is not
+ transferred together with the TSO (that might block another thread).
+\item Should the RTS distinguish between sparks created by local nodes and
+ stolen sparks (@RTSflags.GranFlags.PreferSparksOfLocalNodes@)? The idea is to improve
+ data locality by preferring sparks of local nodes (it is more likely
+ that the data for those sparks is already on the local processor).
+ However, such a distinction also imposes an overhead on the spark
+ queue management, and typically a large number of sparks are
+ generated during execution. By default this variable is set to @False@.
+\item Should the RTS use granularity control mechanisms? The idea of a
+ granularity control mechanism is to make use of granularity
+ information provided via annotation of the @par@ construct in order
+ to prefer bigger threads when either turning a spark into a thread or
+ when choosing the next thread to schedule. Currently, three such
+ mechanisms are implemented:
+ \begin{itemize}
+ \item Cut-off: The granularity information is interpreted as a
+ priority. If a threshold priority is given to the RTS, then
+ only those sparks with a higher priority than the threshold
+ are actually created. Other sparks are immediately discarded.
+ This is similar to a usual cut-off mechanism often used in
+ parallel programs, where parallelism is only created if the
+ input data is lage enough. With this option, the choice is
+ hidden in the RTS and only the threshold value has to be
+ provided as a parameter to the runtime system.
+ \item Priority Sparking: This mechanism keeps priorities for sparks
+ and chooses the spark with the highest priority when turning
+ a spark into a thread. After that the priority information is
+ discarded. The overhead of this mechanism comes from
+ maintaining a sorted spark queue.
+ \item Priority Scheduling: This mechanism keeps the granularity
+ information for threads, to. Thus, on each reschedule the
+ largest thread is chosen. This mechanism has a higher
+ overhead, as the thread queue is sorted, too.
+ \end{itemize}
+\end{itemize}
+\begin{code}
#if defined(GRAN)
-/* Pointer to the event queue; events are currently malloc'ed */
-static eventq EventHd = NULL;
+/* Do we need to reschedule following a fetch? */
+rtsBool NeedToReSchedule = rtsFalse;
+TIME TimeOfNextEvent, EndOfTimeSlice; /* checked from the threaded world! */
+/* I_ avoidedCS=0; */ /* Unused!! ToDo: Remake libraries and nuke this var */
+
+/* For internal use (event statistics) only */
+char *event_names[] =
+ { "STARTTHREAD", "CONTINUETHREAD", "RESUMETHREAD",
+ "MOVESPARK", "MOVETHREAD", "FINDWORK",
+ "FETCHNODE", "FETCHREPLY",
+ "GLOBALBLOCK", "UNBLOCKTHREAD"
+ };
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+I_ noOfEvents = 0;
+I_ event_counts[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 };
+
+I_ fetch_misses = 0;
+I_ tot_low_pri_sparks = 0;
+
+I_ rs_sp_count=0, rs_t_count=0, ntimes_total=0, fl_total=0, no_of_steals=0;
+
+/* Variables for gathering packet and queue statistics */
+I_ tot_packets = 0, tot_packet_size = 0, tot_cuts = 0, tot_thunks = 0;
+I_ tot_sq_len = 0, tot_sq_probes = 0, tot_sparks = 0, withered_sparks = 0;
+I_ tot_add_threads = 0, tot_tq_len = 0, non_end_add_threads = 0;
+# endif
+
+# if defined(GRAN_COUNT)
+/* Count the number of updates that are done. Mainly for testing, but
+ could be useful for other purposes, too. */
+I_ nUPDs = 0, nUPDs_old = 0, nUPDs_new = 0, nUPDs_BQ = 0, nPAPs = 0,
+ BQ_lens = 0;
+# endif
+
+/* Prototypes */
+I_ HandleFetchRequest(P_, PROC, P_);
+/* void HandleFetchRequest(P_, PROC, P_); changed for GUMMFeching */
+static I_ blockFetch(P_ tso, PROC proc, P_ bh);
+
+#endif /* GRAN */
+\end{code}
+
+%****************************************************************
+%* *
+\subsection[global-address-op]{Global Address Operations}
+%* *
+%****************************************************************
+
+These functions perform operations on the global-address (ga) part
+of a closure. The ga is the only new field (1 word) in a closure introduced
+by GrAnSim. It serves as a bitmask, indicating on which processor
+the closure is residing. Since threads are described by Thread State
+Object (TSO), which is nothing but another kind of closure, this
+scheme allows gives placement information about threads.
+
+A ga is just a bitmask, so the operations on them are mainly bitmask
+manipulating functions. Note, that there are important macros like PROCS,
+IS_LOCAL_TO etc. They are defined in @GrAnSim.lh@.
+
+NOTE: In GrAnSim-light we don't maintain placement information. This
+allows to simulate an arbitrary number of processors. The price we have
+to be is the lack of costing any communication properly. In short,
+GrAnSim-light is meant to reveal the maximal parallelism in a program.
+From an implementation point of view the important thing is:
+{\em GrAnSim-light does not maintain global-addresses}.
+
+\begin{code}
+#if defined(GRAN)
+
+/* ga_to_proc returns the first processor marked in the bitmask ga.
+ Normally only one bit in ga should be set. But for PLCs all bits
+ are set. That shouldn't hurt since we only need IS_LOCAL_TO for PLCs */
+
PROC
ga_to_proc(W_ ga)
{
PROC i;
-
for (i = 0; i < MAX_PROC && !IS_LOCAL_TO(ga, i); i++);
-
return (i);
}
where_is(P_ node)
{ return (ga_to_proc(PROCS(node))); } /* Access the GA field of the node */
-#if 0
-PROC
-no_of_copies(W_ ga) /* DaH lo'lu'Qo'; currently unused */
-{
- PROC i, n;
-
- for (i = 0, n = 0; i < MAX_PROC; i++)
- if (IS_LOCAL_TO(ga, i))
- n++;;
+rtsBool
+any_idle() {
+ I_ i;
+ rtsBool any_idle;
+ for(i=0, any_idle=rtsFalse;
+ !any_idle && i<RTSflags.GranFlags.proc;
+ any_idle = any_idle || IS_IDLE(i), i++)
+ {} ;
+}
- return (n);
+int
+idlers() {
+ I_ i, j;
+ for(i=0, j=0;
+ i<RTSflags.GranFlags.proc;
+ j += IS_IDLE(i)?1:0, i++)
+ {} ;
+ return j;
}
-#endif
+#endif /* GRAN */
+\end{code}
+
+%****************************************************************
+%* *
+\subsection[event-queue]{The Global Event Queue}
+%* *
+%****************************************************************
+
+The following routines implement an ADT of an event-queue (FIFO).
+ToDo: Put that in an own file(?)
+
+\begin{code}
+#if defined(GRAN)
+
+/* Pointer to the global event queue; events are currently malloc'ed */
+eventq EventHd = NULL;
eventq
-getnextevent()
+get_next_event()
{
static eventq entry = NULL;
if(EventHd == NULL)
{
fprintf(stderr,"No next event\n");
- exit(EXIT_FAILURE); /* why not EXIT??? WDP 95/07 */
+ EXIT(EXIT_FAILURE);
}
if(entry != NULL)
free((char *)entry);
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (debug & 0x20) { /* count events */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GranFlags.debug & 0x20) { /* count events */
noOfEvents++;
- event_counts[(EVENT_TYPE(EventHd)>=CONTINUETHREAD1) ?
- CONTINUETHREAD :
- EVENT_TYPE(EventHd)]++;
+ event_counts[EVENT_TYPE(EventHd)]++;
}
-#endif
+# endif
entry = EventHd;
EventHd = EVENT_NEXT(EventHd);
return(entry);
}
-/* ToDo: replace malloc/free with a free list */
+/* When getting the time of the next event we ignore CONTINUETHREAD events:
+ we don't want to be interrupted before the end of the current time slice
+ unless there is something important to handle.
+*/
+TIME
+get_time_of_next_event()
+{
+ eventq event = EventHd;
+
+ while (event != NULL && EVENT_TYPE(event)==CONTINUETHREAD) {
+ event = EVENT_NEXT(event);
+ }
+ if(event == NULL)
+ return ((TIME) 0);
+ else
+ return (EVENT_TIME(event));
+}
-/* NB: newevent unused (WDP 95/07) */
+/* ToDo: replace malloc/free with a free list */
static
-newevent(proc,creator,time,evttype,tso,node,spark)
- PROC proc, creator;
- TIME time;
- EVTTYPE evttype;
- P_ tso, node;
- sparkq spark;
+insert_event(newentry)
+eventq newentry;
+{
+ EVTTYPE evttype = EVENT_TYPE(newentry);
+ eventq event, *prev;
+
+ /* if(evttype >= CONTINUETHREAD1) evttype = CONTINUETHREAD; */
+
+ /* Search the queue and insert at the right point:
+ FINDWORK before everything, CONTINUETHREAD after everything.
+
+ This ensures that we find any available work after all threads have
+ executed the current cycle. This level of detail would normally be
+ irrelevant, but matters for ridiculously low latencies...
+ */
+
+ /* Changed the ordering: Now FINDWORK comes after everything but
+ CONTINUETHREAD. This makes sure that a MOVESPARK comes before a
+ FINDWORK. This is important when a GranSimSparkAt happens and
+ DoAlwaysCreateThreads is turned on. Also important if a GC occurs
+ when trying to build a new thread (see much_spark) -- HWL 02/96 */
+
+ if(EventHd == NULL)
+ EventHd = newentry;
+ else {
+ for (event = EventHd, prev=&EventHd;
+ event != NULL;
+ prev = &(EVENT_NEXT(event)), event = EVENT_NEXT(event)) {
+ switch (evttype) {
+ case FINDWORK: if ( EVENT_TIME(event) < EVENT_TIME(newentry) ||
+ ( (EVENT_TIME(event) == EVENT_TIME(newentry)) &&
+ (EVENT_TYPE(event) != CONTINUETHREAD) ) )
+ continue;
+ else
+ break;
+ case CONTINUETHREAD: if ( EVENT_TIME(event) <= EVENT_TIME(newentry) )
+ continue;
+ else
+ break;
+ default: if ( EVENT_TIME(event) < EVENT_TIME(newentry) ||
+ ((EVENT_TIME(event) == EVENT_TIME(newentry)) &&
+ (EVENT_TYPE(event) == EVENT_TYPE(newentry))) )
+ continue;
+ else
+ break;
+ }
+ /* Insert newentry here (i.e. before event) */
+ *prev = newentry;
+ EVENT_NEXT(newentry) = event;
+ break;
+ }
+ if (event == NULL)
+ *prev = newentry;
+ }
+}
+
+void
+new_event(proc,creator,time,evttype,tso,node,spark)
+PROC proc, creator;
+TIME time;
+EVTTYPE evttype;
+P_ tso, node;
+sparkq spark;
{
- eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "newevent");
+ eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "new_event");
EVENT_PROC(newentry) = proc;
EVENT_CREATOR(newentry) = creator;
EVENT_TSO(newentry) = tso;
EVENT_NODE(newentry) = node;
EVENT_SPARK(newentry) = spark;
+ EVENT_GC_INFO(newentry) = 0;
EVENT_NEXT(newentry) = NULL;
insert_event(newentry);
}
-#endif /* GRAN ; HWL */
+void
+prepend_event(eventq event) /* put event at beginning of EventQueue */
+{ /* only used for GC! */
+ EVENT_NEXT(event) = EventHd;
+ EventHd = event;
+}
+
+eventq
+grab_event() /* undo prepend_event i.e. get the event */
+{ /* at the head of EventQ but don't free anything */
+ eventq event = EventHd;
+
+ if(EventHd == NULL) {
+ fprintf(stderr,"No next event (in grab_event)\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ EventHd = EVENT_NEXT(EventHd);
+ return (event);
+}
+
+void
+print_event(event)
+eventq event;
+{
+
+ char str_tso[16], str_node[16];
+
+ sprintf(str_tso,((EVENT_TSO(event)==Prelude_Z91Z93_closure) ? "______" : "%#6lx"),
+ EVENT_TSO(event));
+ sprintf(str_node,((EVENT_NODE(event)==Prelude_Z91Z93_closure) ? "______" : "%#6lx"),
+ EVENT_NODE(event));
+
+ if (event==NULL)
+ fprintf(stderr,"Evt: NIL\n");
+ else
+ fprintf(stderr,"Evt: %s (%u), PE %u [%u], Time %lu, TSO %s (%x), node %s\n",
+ event_names[EVENT_TYPE(event)],EVENT_TYPE(event),
+ EVENT_PROC(event), EVENT_CREATOR(event), EVENT_TIME(event),
+ str_tso, TSO_ID(EVENT_TSO(event)), str_node
+ /*, EVENT_SPARK(event), EVENT_NEXT(event)*/ );
+
+}
+
+void
+print_eventq(hd)
+eventq hd;
+{
+ eventq x;
+
+ fprintf(stderr,"Event Queue with root at %x:\n",hd);
+ for (x=hd; x!=NULL; x=EVENT_NEXT(x)) {
+ print_event(x);
+ }
+}
+
+void
+print_spark(spark)
+ sparkq spark;
+{
+ char str[16];
+
+ sprintf(str,((SPARK_NODE(spark)==Prelude_Z91Z93_closure) ? "______" : "%#6lx"),
+ (W_) SPARK_NODE(spark));
+
+ if (spark==NULL)
+ fprintf(stderr,"Spark: NIL\n");
+ else
+ fprintf(stderr,"Spark: Node %8s, Name %#6lx, Exported %5s, Prev %#6x, Next %#6x\n",
+ str, SPARK_NAME(spark),
+ ((SPARK_EXPORTED(spark))?"True":"False"),
+ SPARK_PREV(spark), SPARK_NEXT(spark) );
+}
+
+void
+print_sparkq(hd)
+sparkq hd;
+{
+ sparkq x;
+
+ fprintf(stderr,"Spark Queue with root at %x:\n",hd);
+ for (x=hd; x!=NULL; x=SPARK_NEXT(x)) {
+ print_spark(x);
+ }
+}
+
+
+#endif /* GRAN */
\end{code}
%****************************************************************************
%
-\subsection[GrAnSim-profile]{Writing profiling info for GrAnSim}
+\subsection[entry-points]{Routines directly called from Haskell world}
%
%****************************************************************************
-Event dumping routines.
+The @GranSim...@ routines in here are directly called via macros from the
+threaded world.
+
+First some auxiliary routines.
\begin{code}
+#if defined(GRAN)
+/* Take the current thread off the thread queue and thereby activate the */
+/* next thread. It's assumed that the next ReSchedule after this uses */
+/* NEW_THREAD as param. */
+/* This fct is called from GranSimBlock and GranSimFetch */
-FILE *gr_file = NULL;
+void
+ActivateNextThread (PROC proc)
+{
+ ASSERT(RunnableThreadsHd[proc]!=Prelude_Z91Z93_closure);
+
+ RunnableThreadsHd[proc] = TSO_LINK(RunnableThreadsHd[proc]);
+ if(RunnableThreadsHd[proc]==Prelude_Z91Z93_closure) {
+ MAKE_IDLE(proc);
+ RunnableThreadsTl[proc] = Prelude_Z91Z93_closure;
+ } else {
+ CurrentTime[proc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
+ if (RTSflags.GranFlags.granSimStats &&
+ (!RTSflags.GranFlags.Light || (RTSflags.GranFlags.debug & 0x20000)))
+ DumpRawGranEvent(proc,0,GR_SCHEDULE,RunnableThreadsHd[proc],
+ Prelude_Z91Z93_closure,0);
+ }
+}
+\end{code}
-char *gran_event_names[] = {
- "START", "START(Q)",
- "STEALING", "STOLEN", "STOLEN(Q)",
- "FETCH", "REPLY", "BLOCK", "RESUME", "RESUME(Q)",
- "SCHEDULE", "DESCHEDULE",
- "END",
- "SPARK", "SPARKAT", "USED", "PRUNED", "EXPORTED", "ACQUIRED",
- "TERMINATE",
- "??"
-};
+Now the main stg-called routines:
+
+\begin{code}
+/* ------------------------------------------------------------------------ */
+/* The following GranSim... fcts are stg-called from the threaded world. */
+/* ------------------------------------------------------------------------ */
+
+/* Called from HEAP_CHK -- NB: node and liveness are junk here now.
+ They are left temporarily to avoid complete recompilation.
+ KH
+*/
+void
+GranSimAllocate(n,node,liveness)
+I_ n;
+P_ node;
+W_ liveness;
+{
+ TSO_ALLOCS(CurrentTSO) += n;
+ ++TSO_BASICBLOCKS(CurrentTSO);
+
+ if (RTSflags.GranFlags.granSimStats_Heap) {
+ DumpRawGranEvent(CurrentProc,0,GR_ALLOC,CurrentTSO,
+ Prelude_Z91Z93_closure,n);
+ }
+
+ TSO_EXECTIME(CurrentTSO) += RTSflags.GranFlags.gran_heapalloc_cost;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_heapalloc_cost;
+}
+
+/*
+ Subtract the values added above, if a heap check fails and
+ so has to be redone.
+*/
+void
+GranSimUnallocate(n,node,liveness)
+W_ n;
+P_ node;
+W_ liveness;
+{
+ TSO_ALLOCS(CurrentTSO) -= n;
+ --TSO_BASICBLOCKS(CurrentTSO);
+
+ TSO_EXECTIME(CurrentTSO) -= RTSflags.GranFlags.gran_heapalloc_cost;
+ CurrentTime[CurrentProc] -= RTSflags.GranFlags.gran_heapalloc_cost;
+}
+
+/* NB: We now inline this code via GRAN_EXEC rather than calling this fct */
+void
+GranSimExec(ariths,branches,loads,stores,floats)
+W_ ariths,branches,loads,stores,floats;
+{
+ W_ cost = RTSflags.GranFlags.gran_arith_cost*ariths +
+ RTSflags.GranFlags.gran_branch_cost*branches +
+ RTSflags.GranFlags.gran_load_cost * loads +
+ RTSflags.GranFlags.gran_store_cost*stores +
+ RTSflags.GranFlags.gran_float_cost*floats;
+
+ TSO_EXECTIME(CurrentTSO) += cost;
+ CurrentTime[CurrentProc] += cost;
+}
+
+
+/*
+ Fetch the node if it isn't local
+ -- result indicates whether fetch has been done.
+
+ This is GRIP-style single item fetching.
+*/
+
+/* This function in Threads.lc is only needed for SimplifiedFetch */
+extern FetchNode PROTO((P_ node,PROC CurrentProc));
+
+I_
+GranSimFetch(node /* , liveness_mask */ )
+P_ node;
+/* I_ liveness_mask; */
+{
+ if (RTSflags.GranFlags.Light) {
+ /* Always reschedule in GrAnSim-Light to prevent one TSO from
+ running off too far
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,CurrentTSO,node,NULL);
+ */
+ NeedToReSchedule = rtsFalse;
+ return(0);
+ }
+
+ /* Note: once a node has been fetched, this test will be passed */
+ if(!IS_LOCAL_TO(PROCS(node),CurrentProc))
+ {
+ /* Add mpacktime to the remote PE for the reply */
+ {
+ PROC p = where_is(node);
+ TIME fetchtime;
+
+# ifdef GRAN_CHECK
+ if ( ( RTSflags.GranFlags.debug & 0x40 ) &&
+ p == CurrentProc )
+ fprintf(stderr,"GranSimFetch: Trying to fetch from own processor%u\n", p);
+# endif /* GRAN_CHECK */
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+ /* NB: Fetch is counted on arrival (FETCHREPLY) */
+
+ if (RTSflags.GranFlags.SimplifiedFetch)
+ {
+ FetchNode(node,CurrentProc);
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime+
+ RTSflags.GranFlags.gran_fetchtime+
+ RTSflags.GranFlags.gran_munpacktime;
+ return(1);
+ }
+
+ fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
+ RTSflags.GranFlags.gran_latency;
+
+ new_event(p,CurrentProc,fetchtime,FETCHNODE,CurrentTSO,node,NULL);
+ if (!RTSflags.GranFlags.DoReScheduleOnFetch)
+ MAKE_FETCHING(CurrentProc);
+ ++OutstandingFetches[CurrentProc];
+
+ if (fetchtime<TimeOfNextEvent)
+ TimeOfNextEvent = fetchtime;
+
+ /* About to block */
+ TSO_BLOCKEDAT(CurrentTSO) = CurrentTime[CurrentProc];
+
+ if (RTSflags.GranFlags.DoReScheduleOnFetch)
+ {
+ /* Remove CurrentTSO from the queue
+ -- assumes head of queue == CurrentTSO */
+ if(!RTSflags.GranFlags.DoFairSchedule)
+ {
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,
+ node,0);
+
+ ActivateNextThread(CurrentProc);
+
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x10) {
+ if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
+ fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
+ CurrentTSO,CurrentTime[CurrentProc]);
+ EXIT(EXIT_FAILURE);
+ } else {
+ TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
+ }
+ }
+# endif
+ TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
+ /* CurrentTSO = Prelude_Z91Z93_closure; */
+
+ /* ThreadQueueHd is now the next TSO to schedule or NULL */
+ /* CurrentTSO is pointed to by the FETCHNODE event */
+ }
+ else /* fair scheduling currently not supported -- HWL */
+ {
+ fprintf(stderr,"Reschedule-on-fetch is not yet compatible with fair scheduling\n");
+ EXIT(EXIT_FAILURE);
+ }
+ }
+ else /* !RTSflags.GranFlags.DoReScheduleOnFetch */
+ {
+ /* Note: CurrentProc is still busy as it's blocked on fetch */
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(CurrentProc,p,GR_FETCH,CurrentTSO,node,0);
+
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x04)
+ BlockedOnFetch[CurrentProc] = CurrentTSO; /*- rtsTrue; -*/
+ if (RTSflags.GranFlags.debug & 0x10) {
+ if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
+ fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
+ CurrentTSO,CurrentTime[CurrentProc]);
+ EXIT(EXIT_FAILURE);
+ } else {
+ TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
+ }
+ CurrentTSO = Prelude_Z91Z93_closure;
+ }
+# endif
+ }
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+
+ /* Rescheduling is necessary */
+ NeedToReSchedule = rtsTrue;
+
+ return(1);
+ }
+ }
+ return(0);
+}
+
+void
+GranSimSpark(local,node)
+W_ local;
+P_ node;
+{
+ /* ++SparksAvail; Nope; do that in add_to_spark_queue */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,(PROC)0,SP_SPARK,Prelude_Z91Z93_closure,node,
+ spark_queue_len(CurrentProc,ADVISORY_POOL)-1);
+
+ /* Force the PE to take notice of the spark */
+ if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
+ if (CurrentTime[CurrentProc]<TimeOfNextEvent)
+ TimeOfNextEvent = CurrentTime[CurrentProc];
+ }
+
+ if(local)
+ ++TSO_LOCALSPARKS(CurrentTSO);
+ else
+ ++TSO_GLOBALSPARKS(CurrentTSO);
+}
+
+void
+GranSimSparkAt(spark,where,identifier)
+sparkq spark;
+P_ where; /* This should be a node; alternatively could be a GA */
+I_ identifier;
+{
+ PROC p = where_is(where);
+ GranSimSparkAtAbs(spark,p,identifier);
+}
+
+void
+GranSimSparkAtAbs(spark,proc,identifier)
+sparkq spark;
+PROC proc;
+I_ identifier;
+{
+ TIME exporttime;
+
+ if ( spark == (sparkq)NULL) /* Note: Granularity control might have */
+ return; /* turned a spark into a NULL. */
+
+ /* ++SparksAvail; Nope; do that in add_to_spark_queue */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(proc,0,SP_SPARKAT,Prelude_Z91Z93_closure,SPARK_NODE(spark),
+ spark_queue_len(proc,ADVISORY_POOL));
+
+ if (proc!=CurrentProc) {
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+ exporttime = (CurrentTime[proc] > CurrentTime[CurrentProc]?
+ CurrentTime[proc]: CurrentTime[CurrentProc])
+ + RTSflags.GranFlags.gran_latency;
+ } else {
+ exporttime = CurrentTime[CurrentProc];
+ }
+
+ if ( RTSflags.GranFlags.Light )
+ /* Need CurrentTSO in event field to associate costs with creating
+ spark even in a GrAnSim Light setup */
+ new_event(proc,CurrentProc,exporttime,
+ MOVESPARK,CurrentTSO,Prelude_Z91Z93_closure,spark);
+ else
+ new_event(proc,CurrentProc,exporttime,
+ MOVESPARK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,spark);
+ /* Bit of a hack to treat placed sparks the same as stolen sparks */
+ ++OutstandingFishes[proc];
+
+ /* Force the PE to take notice of the spark (FINDWORK is put after a
+ MOVESPARK into the sparkq!) */
+ if(RTSflags.GranFlags.DoAlwaysCreateThreads) {
+ new_event(CurrentProc,CurrentProc,exporttime+1,
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
+ }
+
+ if (exporttime<TimeOfNextEvent)
+ TimeOfNextEvent = exporttime;
+
+ if (proc!=CurrentProc) {
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+ ++TSO_GLOBALSPARKS(CurrentTSO);
+ } else {
+ ++TSO_LOCALSPARKS(CurrentTSO);
+ }
+}
+
+/* This function handles local and global blocking */
+/* It's called either from threaded code (RBH_entry, BH_entry etc) or */
+/* from blockFetch when trying to fetch an BH or RBH */
+
+void
+GranSimBlock(P_ tso, PROC proc, P_ node)
+{
+ PROC node_proc = where_is(node);
+
+ ASSERT(tso==RunnableThreadsHd[proc]);
+
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(proc,node_proc,GR_BLOCK,tso,node,0);
+
+ ++TSO_BLOCKCOUNT(tso);
+ /* Distinction between local and global block is made in blockFetch */
+ TSO_BLOCKEDAT(tso) = CurrentTime[proc];
+
+ CurrentTime[proc] += RTSflags.GranFlags.gran_threadqueuetime;
+ ActivateNextThread(proc);
+ TSO_LINK(tso) = Prelude_Z91Z93_closure; /* not really necessary; only for testing */
+}
+
+#endif /* GRAN */
+
+\end{code}
+
+%****************************************************************************
+%
+\subsection[GrAnSim-profile]{Writing profiling info for GrAnSim}
+%
+%****************************************************************************
+
+Event dumping routines.
+
+\begin{code}
/*
* If you're not using GNUC and you're on a 32-bit machine, you're
#endif /* !GRAN */
+#if defined(GRAN) || defined(PAR)
void
DumpGranEvent(name, tso)
enum gran_event_types name;
P_ tso;
{
- DumpRawGranEvent(CURRENT_PROC, name, TSO_ID(tso));
+ DumpRawGranEvent(CURRENT_PROC, (PROC)0, name, tso, Prelude_Z91Z93_closure, 0);
}
void
-DumpSparkGranEvent(name, id)
+DumpRawGranEvent(proc, p, name, tso, node, len)
+PROC proc, p; /* proc ... where it happens; p ... where node lives */
enum gran_event_types name;
-W_ id;
+P_ tso, node;
+I_ len;
{
- DumpRawGranEvent(CURRENT_PROC, name, id);
-}
-
-void
-DumpGranEventAndNode(name, tso, node, proc)
- enum gran_event_types name;
- P_ tso, node;
- PROC proc;
-{
- PROC pe = CURRENT_PROC;
- W_ id;
+ W_ id;
+ char time_string[500], node_str[16]; /*ToDo: kill magic constants */
+ ullong_format_string(TIME_ON_PROC(proc), time_string, rtsFalse/*no commas!*/);
+#if defined(GRAN)
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
+#endif
- char time_string[500]; /*ToDo: kill magic constant */
- ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
+ id = tso == NULL ? -1 : TSO_ID(tso);
+ if (node==Prelude_Z91Z93_closure)
+ strcpy(node_str,"________"); /* "Prelude_Z91Z93_closure"); */
+ else
+ sprintf(node_str,"0x%-6lx",node);
-#ifdef PAR
- id = tso == NULL ? -1 : TSO_ID(tso);
-#else
- id = TSO_ID(tso);
-#endif
- if (name > GR_EVENT_MAX)
+ if (name > GR_EVENT_MAX)
name = GR_EVENT_MAX;
- if (RTSflags.ParFlags.granSimStats_Binary) {
- grputw(name);
- grputw(pe);
- abort(); /* die please: a single word doesn't represent long long times */
- grputw(CURRENT_TIME); /* this line is bound to do the wrong thing */
- grputw(id);
- } else
- fprintf(gr_file, "PE %2u [%s]: %s %lx \t0x%lx\t(from %2u)\n",
- pe, time_string, gran_event_names[name], id, (W_) node, proc);
+ if(GRANSIMSTATS_BINARY)
+ /* ToDo: fix code for writing binary GrAnSim statistics */
+ switch (name) {
+ case GR_START:
+ case GR_STARTQ:
+ grputw(name);
+ grputw(proc);
+ abort(); /* die please: a single word */
+ /* doesn't represent long long times */
+ grputw(TIME_ON_PROC(proc));
+ grputw((W_)node);
+ break;
+ case GR_FETCH:
+ case GR_REPLY:
+ case GR_BLOCK:
+ grputw(name);
+ grputw(proc);
+ abort(); /* die please: a single word */
+ /* doesn't represent long long times */
+ grputw(TIME_ON_PROC(proc)); /* this line is bound to */
+ grputw(id); /* do the wrong thing */
+ break;
+ default:
+ grputw(name);
+ grputw(proc);
+ abort(); /* die please: a single word */
+ /* doesn't represent long long times */
+ grputw(TIME_ON_PROC(proc));
+ grputw((W_)node);
+ }
+ else
+ switch (name) {
+ case GR_START:
+ case GR_STARTQ:
+ /* fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n", */
+ /* using spark queue length as optional argument ^^^^^^^^^ */
+ fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[SN %u]\n",
+ /* using spark name as optional argument ^^^^^^ */
+ proc,time_string,gran_event_names[name],
+ id,node_str,(len & NEW_SPARKNAME_MASK));
+ break;
+ case GR_FETCH:
+ case GR_REPLY:
+ case GR_BLOCK:
+ case GR_STOLEN:
+ case GR_STOLENQ:
+ fprintf(gr_file, "PE %2u [%s]: %-9s\t%lx \t%s\t(from %2u)\n",
+ proc, time_string, gran_event_names[name],
+ id,node_str,p);
+ break;
+ case GR_RESUME:
+ case GR_RESUMEQ:
+ case GR_SCHEDULE:
+ case GR_DESCHEDULE:
+ fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx \n",
+ proc,time_string,gran_event_names[name],id);
+ break;
+ case GR_STEALING:
+ fprintf(gr_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(gr_file,"PE %2u [%s]: %-9s\t%lx\t \tallocating %u words\n",
+ proc,time_string,gran_event_names[name],id,len);
+ break;
+ default:
+ fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n",
+ proc,time_string,gran_event_names[name],id,node_str,len);
+ }
}
+
+#if defined(GRAN)
+/* Only needed for special dynamic spark labelling support */
void
-DumpRawGranEvent(pe, name, id)
-PROC pe;
+DumpStartEventAt(time, proc, p, name, tso, node, len)
+TIME time;
+PROC proc, p; /* proc ... where it happens; p ... where node lives */
enum gran_event_types name;
-W_ id;
+P_ tso, node;
+I_ len;
{
- char time_string[500]; /* ToDo: kill magic constant */
-
- if (name > GR_EVENT_MAX)
+ W_ id;
+ char time_string[500], node_str[16]; /*ToDo: kill magic constants */
+ ullong_format_string(time, time_string, rtsFalse/*no commas!*/);
+ /* ^^^^ only important change to DumpRawGranEvent */
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
+
+ id = tso == NULL ? -1 : TSO_ID(tso);
+ if (node==Nil_closure)
+ strcpy(node_str,"________"); /* "Nil_closure"); */
+ else
+ sprintf(node_str,"0x%-6lx",node);
+
+ if (name > GR_EVENT_MAX)
name = GR_EVENT_MAX;
- ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
-
- if (RTSflags.ParFlags.granSimStats_Binary) {
- grputw(name);
- grputw(pe);
- abort(); /* die please: a single word doesn't represent long long times */
- grputw(CURRENT_TIME); /* this line is bound to fail */
- grputw(id);
- } else
- fprintf(gr_file, "PE %2u [%s]: %s %lx\n",
- pe, time_string, gran_event_names[name], id);
+ if(GRANSIMSTATS_BINARY)
+ /* ToDo: fix code for writing binary GrAnSim statistics */
+ switch (name) {
+ case GR_START:
+ case GR_STARTQ:
+ grputw(name);
+ grputw(proc);
+ abort(); /* die please: a single word */
+ /* doesn't represent long long times */
+ grputw(TIME_ON_PROC(proc));
+ grputw((W_)node);
+ break;
+ default:
+ fprintf(stderr,"Error in DumpStartEventAt: event %s is not a START event\n",
+ gran_event_names[name]);
+ }
+ else
+ switch (name) {
+ case GR_START:
+ case GR_STARTQ:
+ /* fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[sparks %u]\n", */
+ /* using spark queue length as optional argument ^^^^^^^^^ */
+ fprintf(gr_file,"PE %2u [%s]: %-9s\t%lx\t%s\t[SN %u]\n",
+ /* using spark name as optional argument ^^^^^^ */
+ proc,time_string,gran_event_names[name],
+ id,node_str,(len & NEW_SPARKNAME_MASK));
+ break;
+ default:
+ fprintf(stderr,"Error in DumpStartEventAt: event %s is not a START event\n",
+ gran_event_names[name]);
+ }
}
+#endif /* GRAN */
void
-DumpGranInfo(pe, tso, mandatory_thread)
-PROC pe;
+DumpGranInfo(proc, tso, mandatory_thread)
+PROC proc;
P_ tso;
rtsBool mandatory_thread;
{
char time_string[500]; /* ToDo: kill magic constant */
ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
- if (RTSflags.ParFlags.granSimStats_Binary) {
+#if defined(GRAN)
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
+#endif
+
+ if (GRANSIMSTATS_BINARY) {
grputw(GR_END);
- grputw(pe);
+ grputw(proc);
abort(); /* die please: a single word doesn't represent long long times */
grputw(CURRENT_TIME); /* this line is bound to fail */
grputw(TSO_ID(tso));
} else {
/*
- * NB: DumpGranEvent cannot be used because PE may be wrong (as well as the
- * extra info)
+ * NB: DumpGranEvent cannot be used because PE may be wrong
+ * (as well as the extra info)
*/
fprintf(gr_file, "PE %2u [%s]: END %lx, SN %lu, ST %lu, EXP %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu), LS %lu, GS %lu, MY %c\n"
- ,pe
+ ,proc
,time_string
,TSO_ID(tso)
,TSO_SPARKNAME(tso)
}
}
+void
+DumpTSO(tso)
+P_ tso;
+{
+ fprintf(stderr,"TSO 0x%lx, NAME 0x%lx, ID %lu, LINK 0x%lx, TYPE %s\n"
+ ,tso
+ ,TSO_NAME(tso)
+ ,TSO_ID(tso)
+ ,TSO_LINK(tso)
+ ,TSO_TYPE(tso)==T_MAIN?"MAIN":
+ TSO_TYPE(tso)==T_FAIL?"FAIL":
+ TSO_TYPE(tso)==T_REQUIRED?"REQUIRED":
+ TSO_TYPE(tso)==T_ADVISORY?"ADVISORY":
+ "???"
+ );
+
+ fprintf(stderr,"PC (0x%lx,0x%lx), ARG (0x%lx), SWITCH %lx0x\n"
+ ,TSO_PC1(tso)
+ ,TSO_PC2(tso)
+ ,TSO_ARG1(tso)
+ /* ,TSO_ARG2(tso) */
+ ,TSO_SWITCH(tso)
+ );
+
+ fprintf(gr_file,"TSO %lx: SN %lu, ST %lu, GBL %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu) LS %lu, GS %lu\n"
+ ,TSO_ID(tso)
+ ,TSO_SPARKNAME(tso)
+ ,TSO_STARTEDAT(tso)
+ ,TSO_EXPORTED(tso)?'T':'F'
+ ,TSO_BASICBLOCKS(tso)
+ ,TSO_ALLOCS(tso)
+ ,TSO_EXECTIME(tso)
+ ,TSO_BLOCKTIME(tso)
+ ,TSO_BLOCKCOUNT(tso)
+ ,TSO_FETCHTIME(tso)
+ ,TSO_FETCHCOUNT(tso)
+ ,TSO_LOCALSPARKS(tso)
+ ,TSO_GLOBALSPARKS(tso)
+ );
+}
+
/*
Output a terminate event and an 8-byte time.
*/
grterminate(v)
TIME v;
{
- DumpGranEvent(GR_TERMINATE, 0);
+#if defined(GRAN)
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
+#endif
+
+ DumpGranEvent(GR_TERMINATE, Prelude_Z91Z93_closure);
if (sizeof(TIME) == 4) {
putc('\0', gr_file);
grputw(v)
TIME v;
{
- if (v <= 0x3fl) {
+#if defined(GRAN)
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
+#endif
+
+ if (v <= 0x3fl) { /* length v = 1 byte */
fputc(v & 0x3f, gr_file);
- } else if (v <= 0x3fffl) {
+ } else if (v <= 0x3fffl) { /* length v = 2 byte */
fputc((v >> 8l) | 0x40l, gr_file);
fputc(v & 0xffl, gr_file);
- } else if (v <= 0x3fffffffl) {
+ } else if (v <= 0x3fffffffl) { /* length v = 4 byte */
fputc((v >> 24l) | 0x80l, gr_file);
fputc((v >> 16l) & 0xffl, gr_file);
fputc((v >> 8l) & 0xffl, gr_file);
}
}
+#endif /* GRAN || PAR */
\end{code}
%****************************************************************************
%
%****************************************************************************
+General routines for GranSim. Mainly, startup and shutdown routines, called
+from @main.lc@.
+
\begin{code}
-#ifdef GRAN
+#if defined(GRAN)
+FILE *gr_file = NULL;
char gr_filename[STATS_FILENAME_MAXLEN];
-I_ do_gr_sim = 0;
+/* I_ do_gr_sim = 0; */ /* In GrAnSim setup always do simulation */
int
init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv)
{
I_ i;
- if (do_gr_sim) {
- char *extension = RTSflags.ParFlags.granSimStats_Binary ? "gb" : "gr";
+ char *extension = RTSflags.GranFlags.granSimStats_Binary ? "gb" : "gr";
- sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0], extension);
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
- if ((gr_file = fopen(gr_filename, "w")) == NULL) {
- fprintf(stderr, "Can't open granularity simulation report file %s\n", gr_filename);
- exit(EXIT_FAILURE); /* why not EXIT??? WDP 95/07 */
- }
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (DoReScheduleOnFetch)
+ sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0], extension);
+
+ if ((gr_file = fopen(gr_filename, "w")) == NULL) {
+ fprintf(stderr, "Can't open granularity simulation report file %s\n", gr_filename);
+ EXIT(EXIT_FAILURE);
+ }
+# if 0 /* that's obsolete now, I think -- HWL */
+ if (RTSflags.GranFlags.DoReScheduleOnFetch)
setbuf(gr_file, NULL);
-#endif
+# endif
fputs("Granularity Simulation for ", gr_file);
for (i = 0; i < prog_argc; ++i) {
fputc(' ', gr_file);
}
}
+
+ fputs("\nStart time: ", gr_file);
+ fputs(time_str(), gr_file); /* defined in main.lc */
+ fputc('\n', gr_file);
+
fputs("\n\n--------------------\n\n", gr_file);
fputs("General Parameters:\n\n", gr_file);
- fprintf(gr_file, "PEs %u, %s Scheduler, %sMigrate Threads%s ????? %s\n",
- max_proc, DoFairSchedule ? "Fair" : "Unfair",
- DoThreadMigration ? "" : "Don't ",
- DoThreadMigration && DoStealThreadsFirst ? " Before Sparks" : "",
- DoReScheduleOnFetch ? "" : "Don't ");
-
- fprintf(gr_file, "%s, Fetch %s in Each Packet\n",
- SimplifiedFetch ? "Simplified Fetch" : (DoReScheduleOnFetch ? "Reschedule on Fetch" : "Block on Fetch"),
- DoGUMMFetching ? "Many Closures" : "Exactly One Closure");
- fprintf(gr_file, "Fetch Strategy(%lu): If outstanding fetches %s\n",
- FetchStrategy,
- FetchStrategy == 1 ? "only run runnable threads (don't create new ones" :
- FetchStrategy == 2 ? "create threads only from local sparks" :
- FetchStrategy == 3 ? "create threads from local or global sparks" :
- FetchStrategy == 4 ? "create sparks and steal threads if necessary" :
- "unknown");
+ if (RTSflags.GranFlags.Light)
+ fprintf(gr_file, "GrAnSim-Light\nPEs infinite, %s Scheduler, %sMigrate Threads %s, %s\n",
+ RTSflags.GranFlags.DoFairSchedule?"Fair":"Unfair",
+ RTSflags.GranFlags.DoThreadMigration?"":"Don't ",
+ RTSflags.GranFlags.DoThreadMigration && RTSflags.GranFlags.DoStealThreadsFirst?" Before Sparks":"",
+ RTSflags.GranFlags.SimplifiedFetch ? "Simplified Fetch" :
+ RTSflags.GranFlags.DoReScheduleOnFetch ? "Reschedule on Fetch" :
+ "Block on Fetch");
+ else
+ fprintf(gr_file, "PEs %u, %s Scheduler, %sMigrate Threads %s, %s\n",
+ RTSflags.GranFlags.proc,RTSflags.GranFlags.DoFairSchedule?"Fair":"Unfair",
+ RTSflags.GranFlags.DoThreadMigration?"":"Don't ",
+ RTSflags.GranFlags.DoThreadMigration && RTSflags.GranFlags.DoStealThreadsFirst?" Before Sparks":"",
+ RTSflags.GranFlags.SimplifiedFetch ? "Simplified Fetch" :
+ RTSflags.GranFlags.DoReScheduleOnFetch ? "Reschedule on Fetch" :
+ "Block on Fetch");
+
+ if (RTSflags.GranFlags.DoGUMMFetching)
+ if (RTSflags.GranFlags.ThunksToPack)
+ fprintf(gr_file, "Bulk Fetching: Fetch %d Thunks in Each Packet (Packet Size = %d closures)\n",
+ RTSflags.GranFlags.ThunksToPack,
+ RTSflags.GranFlags.packBufferSize);
+ else
+ fprintf(gr_file, "Bulk Fetching: Fetch as many closures as possible (Packet Size = %d closures)\n",
+ RTSflags.GranFlags.packBufferSize);
+ else
+ fprintf(gr_file, "Incremental Fetching: Fetch Exactly One Closure in Each Packet\n");
+
+ fprintf(gr_file, "Fetch Strategy(%u):If outstanding fetches %s\n",
+ RTSflags.GranFlags.FetchStrategy,
+ RTSflags.GranFlags.FetchStrategy==0 ?
+ " block (block-on-fetch)":
+ RTSflags.GranFlags.FetchStrategy==1 ?
+ "only run runnable threads":
+ RTSflags.GranFlags.FetchStrategy==2 ?
+ "create threads only from local sparks":
+ RTSflags.GranFlags.FetchStrategy==3 ?
+ "create threads from local or global sparks":
+ RTSflags.GranFlags.FetchStrategy==4 ?
+ "create sparks and steal threads if necessary":
+ "unknown");
+
+ if (RTSflags.GranFlags.DoPrioritySparking)
+ fprintf(gr_file, "Priority Sparking (i.e. keep sparks ordered by priority)\n");
+
+ if (RTSflags.GranFlags.DoPriorityScheduling)
+ fprintf(gr_file, "Priority Scheduling (i.e. keep threads ordered by priority)\n");
fprintf(gr_file, "Thread Creation Time %lu, Thread Queue Time %lu\n",
- gran_threadcreatetime, gran_threadqueuetime);
+ RTSflags.GranFlags.gran_threadcreatetime,
+ RTSflags.GranFlags.gran_threadqueuetime);
fprintf(gr_file, "Thread DeSchedule Time %lu, Thread Schedule Time %lu\n",
- gran_threaddescheduletime, gran_threadscheduletime);
+ RTSflags.GranFlags.gran_threaddescheduletime,
+ RTSflags.GranFlags.gran_threadscheduletime);
fprintf(gr_file, "Thread Context-Switch Time %lu\n",
- gran_threadcontextswitchtime);
+ RTSflags.GranFlags.gran_threadcontextswitchtime);
fputs("\n\n--------------------\n\n", gr_file);
fputs("Communication Metrics:\n\n", gr_file);
fprintf(gr_file,
"Latency %lu (1st) %lu (rest), Fetch %lu, Notify %lu (Global) %lu (Local)\n",
- gran_latency, gran_additional_latency, gran_fetchtime,
- gran_gunblocktime, gran_lunblocktime);
+ RTSflags.GranFlags.gran_latency,
+ RTSflags.GranFlags.gran_additional_latency,
+ RTSflags.GranFlags.gran_fetchtime,
+ RTSflags.GranFlags.gran_gunblocktime,
+ RTSflags.GranFlags.gran_lunblocktime);
fprintf(gr_file,
"Message Creation %lu (+ %lu after send), Message Read %lu\n",
- gran_mpacktime, gran_mtidytime, gran_munpacktime);
+ RTSflags.GranFlags.gran_mpacktime,
+ RTSflags.GranFlags.gran_mtidytime,
+ RTSflags.GranFlags.gran_munpacktime);
fputs("\n\n--------------------\n\n", gr_file);
fputs("Instruction Metrics:\n\n", gr_file);
fprintf(gr_file, "Arith %lu, Branch %lu, Load %lu, Store %lu, Float %lu, Alloc %lu\n",
- gran_arith_cost, gran_branch_cost,
- gran_load_cost, gran_store_cost, gran_float_cost, gran_heapalloc_cost);
+ RTSflags.GranFlags.gran_arith_cost,
+ RTSflags.GranFlags.gran_branch_cost,
+ RTSflags.GranFlags.gran_load_cost,
+ RTSflags.GranFlags.gran_store_cost,
+ RTSflags.GranFlags.gran_float_cost,
+ RTSflags.GranFlags.gran_heapalloc_cost);
fputs("\n\n++++++++++++++++++++\n\n", gr_file);
- }
- if (RTSflags.ParFlags.granSimStats_Binary)
+
+ if (RTSflags.GranFlags.granSimStats_Binary)
grputw(sizeof(TIME));
- Idlers = max_proc;
return (0);
}
void
end_gr_simulation(STG_NO_ARGS)
{
- if (do_gr_sim) {
- fprintf(stderr, "The simulation is finished. Look at %s for details.\n",
- gr_filename);
- fclose(gr_file);
- }
-}
+ char time_string[500]; /* ToDo: kill magic constant */
+ ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
-#endif /* GRAN */
+ if (RTSflags.GranFlags.granSimStats_suppressed)
+ return;
-#ifdef PAR
+#if defined(GRAN_CHECK) && defined(GRAN)
+ /* Print event stats */
+ if (RTSflags.GranFlags.debug & 0x20) {
+ int i;
+
+ fprintf(stderr,"Event statistics (number of events: %d):\n",
+ noOfEvents);
+ for (i=0; i<=MAX_EVENT; i++) {
+ fprintf(stderr," %s (%d): \t%ld \t%f%%\t%f%%\n",
+ event_names[i],i,event_counts[i],
+ (float)(100*event_counts[i])/(float)(noOfEvents),
+ (i==CONTINUETHREAD ? 0.0 :
+ (float)(100*(event_counts[i])/(float)(noOfEvents-event_counts[CONTINUETHREAD])) ));
+ }
+ fprintf(stderr,"Randomized steals: %u sparks, %u threads \n \t(Sparks: #%u (avg ntimes=%f; avg fl=%f) \n",
+ rs_sp_count, rs_t_count, no_of_steals,
+ (float)ntimes_total/(float)STG_MAX(no_of_steals,1),
+ (float)fl_total/(float)STG_MAX(no_of_steals,1));
+ fprintf(stderr,"Moved sparks: %d Withered sparks: %d (%.2f %%)\n",
+ tot_sparks,withered_sparks,
+ ( tot_sparks == 0 ? 0 :
+ (float)(100*withered_sparks)/(float)(tot_sparks)) );
+ /* Print statistics about priority sparking */
+ if (RTSflags.GranFlags.DoPrioritySparking) {
+ fprintf(stderr,"About Priority Sparking:\n");
+ fprintf(stderr," Total no. NewThreads: %d Avg. spark queue len: %.2f \n", tot_sq_probes, (float)tot_sq_len/(float)tot_sq_probes);
+ }
+ /* Print statistics about priority sparking */
+ if (RTSflags.GranFlags.DoPriorityScheduling) {
+ fprintf(stderr,"About Priority Scheduling:\n");
+ fprintf(stderr," Total no. of StartThreads: %d (non-end: %d) Avg. thread queue len: %.2f\n",
+ tot_add_threads, non_end_add_threads,
+ (float)tot_tq_len/(float)tot_add_threads);
+ }
+ /* Print packet statistics if GUMM fetching is turned on */
+ if (RTSflags.GranFlags.DoGUMMFetching) {
+ fprintf(stderr,"Packet statistcs:\n");
+ fprintf(stderr," Total no. of packets: %d Avg. packet size: %.2f \n", tot_packets, (float)tot_packet_size/(float)tot_packets);
+ fprintf(stderr," Total no. of thunks: %d Avg. thunks/packet: %.2f \n", tot_thunks, (float)tot_thunks/(float)tot_packets);
+ fprintf(stderr," Total no. of cuts: %d Avg. cuts/packet: %.2f\n", tot_cuts, (float)tot_cuts/(float)tot_packets);
+ /*
+ if (closure_queue_overflows>0)
+ fprintf(stderr," Number of closure queue overflows: %u\n",
+ closure_queue_overflows);
+ */
+ }
+ }
+
+ if (RTSflags.GranFlags.PrintFetchMisses)
+ fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);
+
+# if defined(GRAN_COUNT)
+ fprintf(stderr,"Update count statistics:\n");
+ fprintf(stderr," Total number of updates: %u\n",nUPDs);
+ fprintf(stderr," Needed to awaken BQ: %u with avg BQ len of: %f\n",
+ nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
+ fprintf(stderr," Number of PAPs: %u\n",nPAPs);
+# endif
+
+#endif /* GRAN_CHECK */
+
+ fprintf(stderr, "Simulation finished after @ %s @ cycles. Look at %s for details.\n",
+ time_string,gr_filename);
+ if (RTSflags.GranFlags.granSimStats)
+ fclose(gr_file);
+}
+#elif defined(PAR)
+FILE *gr_file = NULL;
char gr_filename[STATS_FILENAME_MAXLEN];
-I_ do_sp_profile = 0;
+/* I_ do_sp_profile = 0; */
void
init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv)
}
fputc('\n', gr_file);
+ fputs("Start-Time: ", gr_file);
+ fputs(time_str(), gr_file); /* defined in main.lc */
+ fputc('\n', gr_file);
+
startTime = CURRENT_TIME;
if (startTime > LL(1000000000)) {
}
#endif /* PAR */
-#endif /* GRAN || PAR */
+#endif /* GRAN || PAR */
\end{code}
static FILE * open_stats_file (I_ arg,
int argc, char *argv[], int rts_argc, char *rts_argv[],
const char *FILENAME_FMT);
+#ifdef GRAN
+static void process_gran_option(int arg,
+ int *rts_argc, char *rts_argv[], rtsBool *error);
+#endif
/* extern decls */
long strtol PROTO((const char *, char **, int));
#endif /* PROFILING or PAR */
#ifdef PROFILING
- RTSflags.ProfFlags.doHeapProfile = rtsFalse;
+ RTSflags.ProfFlags.doHeapProfile = rtsFalse;
+
+ RTSflags.ProfFlags.ccSelector = NULL;
+ RTSflags.ProfFlags.modSelector = NULL;
+ RTSflags.ProfFlags.grpSelector = NULL;
+ RTSflags.ProfFlags.descrSelector = NULL;
+ RTSflags.ProfFlags.typeSelector = NULL;
+ RTSflags.ProfFlags.kindSelector = NULL;
#endif /* PROFILING */
#ifdef CONCURRENT
RTSflags.ParFlags.packBufferSize = 1024;
#endif /* PAR */
+#ifdef GRAN
+ RTSflags.GranFlags.granSimStats = rtsFalse;
+ RTSflags.GranFlags.granSimStats_suppressed = rtsFalse;
+ RTSflags.GranFlags.granSimStats_Binary = rtsFalse;
+ RTSflags.GranFlags.granSimStats_Sparks = rtsFalse;
+ RTSflags.GranFlags.granSimStats_Heap = rtsFalse;
+ RTSflags.GranFlags.labelling = rtsFalse;
+ RTSflags.GranFlags.packBufferSize = 1024;
+ RTSflags.GranFlags.packBufferSize_internal = GRANSIM_DEFAULT_PACK_BUFFER_SIZE;
+
+ RTSflags.GranFlags.proc = MAX_PROC;
+ RTSflags.GranFlags.max_fishes = MAX_FISHES;
+ RTSflags.GranFlags.time_slice = GRAN_TIME_SLICE;
+ RTSflags.GranFlags.Light = rtsFalse;
+
+ RTSflags.GranFlags.gran_latency = LATENCY;
+ RTSflags.GranFlags.gran_additional_latency = ADDITIONAL_LATENCY;
+ RTSflags.GranFlags.gran_fetchtime = FETCHTIME;
+ RTSflags.GranFlags.gran_lunblocktime = LOCALUNBLOCKTIME;
+ RTSflags.GranFlags.gran_gunblocktime = GLOBALUNBLOCKTIME;
+ RTSflags.GranFlags.gran_mpacktime = MSGPACKTIME;
+ RTSflags.GranFlags.gran_munpacktime = MSGUNPACKTIME;
+ RTSflags.GranFlags.gran_mtidytime = MSGTIDYTIME;
+
+ RTSflags.GranFlags.gran_threadcreatetime = THREADCREATETIME;
+ RTSflags.GranFlags.gran_threadqueuetime = THREADQUEUETIME;
+ RTSflags.GranFlags.gran_threaddescheduletime = THREADDESCHEDULETIME;
+ RTSflags.GranFlags.gran_threadscheduletime = THREADSCHEDULETIME;
+ RTSflags.GranFlags.gran_threadcontextswitchtime = THREADCONTEXTSWITCHTIME;
+
+ RTSflags.GranFlags.gran_arith_cost = ARITH_COST;
+ RTSflags.GranFlags.gran_branch_cost = BRANCH_COST;
+ RTSflags.GranFlags.gran_load_cost = LOAD_COST;
+ RTSflags.GranFlags.gran_store_cost = STORE_COST;
+ RTSflags.GranFlags.gran_float_cost = FLOAT_COST;
+
+ RTSflags.GranFlags.gran_heapalloc_cost = HEAPALLOC_COST;
+
+ RTSflags.GranFlags.gran_pri_spark_overhead = PRI_SPARK_OVERHEAD;
+ RTSflags.GranFlags.gran_pri_sched_overhead = PRI_SCHED_OVERHEAD;
+
+ RTSflags.GranFlags.DoFairSchedule = rtsFalse;
+ RTSflags.GranFlags.DoReScheduleOnFetch = rtsFalse;
+ RTSflags.GranFlags.DoStealThreadsFirst = rtsFalse;
+ RTSflags.GranFlags.SimplifiedFetch = rtsFalse;
+ RTSflags.GranFlags.DoAlwaysCreateThreads = rtsFalse;
+ RTSflags.GranFlags.DoGUMMFetching = rtsFalse;
+ RTSflags.GranFlags.DoThreadMigration = rtsFalse;
+ RTSflags.GranFlags.FetchStrategy = 2;
+ RTSflags.GranFlags.PreferSparksOfLocalNodes = rtsFalse;
+ RTSflags.GranFlags.DoPrioritySparking = rtsFalse;
+ RTSflags.GranFlags.DoPriorityScheduling = rtsFalse;
+ RTSflags.GranFlags.SparkPriority = 0;
+ RTSflags.GranFlags.SparkPriority2 = 0;
+ RTSflags.GranFlags.RandomPriorities = rtsFalse;
+ RTSflags.GranFlags.InversePriorities = rtsFalse;
+ RTSflags.GranFlags.IgnorePriorities = rtsFalse;
+ RTSflags.GranFlags.ThunksToPack = 0;
+ RTSflags.GranFlags.RandomSteal = rtsTrue;
+ RTSflags.GranFlags.NoForward = rtsFalse;
+ RTSflags.GranFlags.PrintFetchMisses = rtsFalse;
+
+ RTSflags.GranFlags.debug = 0x0;
+ RTSflags.GranFlags.event_trace = rtsFalse;
+ RTSflags.GranFlags.event_trace_all = rtsFalse;
+#endif
+
#ifdef TICKY_TICKY
RTSflags.TickyFlags.showTickyStats = rtsFalse;
RTSflags.TickyFlags.tickyFile = NULL;
" -p<sort> Produce cost centre time profile (output file <program>.prof)",
" sort: T = time (default), A = alloc, C = cost centre label",
" -P<sort> Produce serial time profile (output file <program>.time)",
-" and a -p profile with detailed caf/enter/tick/alloc info",
+" and a -p profile with detailed tick/alloc info",
# if defined(PROFILING)
"",
" -h<break-down> Heap residency profile (output file <program>.hp)",
" -d Turn on PVM-ish debugging",
" -O Disable output for performance measurement",
# endif /* PAR */
+# ifdef GRAN /* ToDo: fill in decent Docu here */
+" -b... All GranSim options start with -b, and there are many of them",
+# endif
#endif /* CONCURRENT */
"",
"Other RTS options may be available for programs compiled a different way.",
#endif
#ifdef PROFILING
-# define PROFILING_BUILD_ONLY(x)
+# define PROFILING_BUILD_ONLY(x) x
#else
# define PROFILING_BUILD_ONLY(x) \
fprintf(stderr, "setupRtsFlags: GHC not built for: -prof\n"); \
#endif
#ifdef CONCURRENT
-# define CONCURRENT_BUILD_ONLY(x)
+# define CONCURRENT_BUILD_ONLY(x) x
#else
# define CONCURRENT_BUILD_ONLY(x) \
fprintf(stderr, "setupRtsFlags: GHC not built for: -concurrent\n"); \
#endif
#ifdef PAR
-# define PAR_BUILD_ONLY(x)
+# define PAR_BUILD_ONLY(x) x
#else
# define PAR_BUILD_ONLY(x) \
fprintf(stderr, "setupRtsFlags: GHC not built for: -parallel\n"); \
#endif
#ifdef GRAN
-# define GRAN_BUILD_ONLY(x)
+# define GRAN_BUILD_ONLY(x) x
#else
# define GRAN_BUILD_ONLY(x) \
fprintf(stderr, "setupRtsFlags: GHC not built for: -gransim\n"); \
break;
default:
fprintf(stderr, "Invalid profiling sort option %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
) break;
default:
fprintf(stderr, "Invalid heap profile option: %s\n",
rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
) break;
max_cc_no = (hash_t) decode(rts_argv[arg]+3);
if (max_cc_no == 0) {
fprintf(stderr, "Bad number of cost centres %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
break;
case MODchar:
max_mod_no = (hash_t) decode(rts_argv[arg]+3);
if (max_mod_no == 0) {
fprintf(stderr, "Bad number of modules %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
break;
case GRPchar:
max_grp_no = (hash_t) decode(rts_argv[arg]+3);
if (max_grp_no == 0) {
fprintf(stderr, "Bad number of groups %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
break;
case DESCRchar:
max_descr_no = (hash_t) decode(rts_argv[arg]+3);
if (max_descr_no == 0) {
fprintf(stderr, "Bad number of closure descriptions %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
break;
case TYPEchar:
max_type_no = (hash_t) decode(rts_argv[arg]+3);
if (max_type_no == 0) {
fprintf(stderr, "Bad number of type descriptions %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
break;
default:
fprintf(stderr, "Invalid index table size option: %s\n",
rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
}
) break;
case 'y': /* closure type select */
case 'k': /* closure kind select */
PROFILING_BUILD_ONLY(
+ {char *left = strchr(rts_argv[arg], '{');
+ char *right = strrchr(rts_argv[arg], '}');
- left = strchr(rts_argv[arg], '{');
- right = strrchr(rts_argv[arg], '}');
if (! left || ! right ||
strrchr(rts_argv[arg], '{') != left ||
strchr(rts_argv[arg], '}') != right) {
fprintf(stderr, "Invalid heap profiling selection bracketing\n %s\n", rts_argv[arg]);
- error = 1;
+ error = rtsTrue;
} else {
*right = '\0';
switch (rts_argv[arg][1]) {
case 'c': /* cost centre label select */
- select_cc = left + 1;
+ RTSflags.ProfFlags.ccSelector = left + 1;
break;
case 'm': /* cost centre module select */
- select_mod = left + 1;
+ RTSflags.ProfFlags.modSelector = left + 1;
break;
case 'g': /* cost centre group select */
- select_grp = left + 1;
+ RTSflags.ProfFlags.grpSelector = left + 1;
break;
case 'd': /* closure descr select */
- select_descr = left + 1;
+ RTSflags.ProfFlags.descrSelector = left + 1;
break;
case 't': /* closure type select */
- select_type = left + 1;
+ RTSflags.ProfFlags.typeSelector = left + 1;
break;
case 'k': /* closure kind select */
- select_kind = left + 1;
+ RTSflags.ProfFlags.kindSelector = left + 1;
break;
- }
- }
+ }
+ }}
) break;
/* =========== CONCURRENT ========================= */
case 'b':
GRAN_BUILD_ONLY(
- process_gran_option();
+ process_gran_option(arg, rts_argc, rts_argv, &error);
) break;
/* =========== TICKY ============================== */
}
-#ifdef GRAN
+#if defined(GRAN)
+void
+enable_GrAnSimLight() {
+
+ fprintf(stderr,"GrAnSim Light enabled (infinite number of processors; 0 communication costs)\n");
+ RTSflags.GranFlags.Light=rtsTrue;
+ RTSflags.GranFlags.gran_latency =
+ RTSflags.GranFlags.gran_fetchtime =
+ RTSflags.GranFlags.gran_additional_latency =
+ RTSflags.GranFlags.gran_gunblocktime =
+ RTSflags.GranFlags.gran_lunblocktime =
+ RTSflags.GranFlags.gran_threadcreatetime =
+ RTSflags.GranFlags.gran_threadqueuetime =
+ RTSflags.GranFlags.gran_threadscheduletime =
+ RTSflags.GranFlags.gran_threaddescheduletime =
+ RTSflags.GranFlags.gran_threadcontextswitchtime = 0;
+
+ RTSflags.GranFlags.gran_mpacktime =
+ RTSflags.GranFlags.gran_munpacktime = 0;
+
+ RTSflags.GranFlags.DoFairSchedule = rtsTrue;
+ RTSflags.GranFlags.DoReScheduleOnFetch = rtsFalse;
+ RTSflags.GranFlags.DoAlwaysCreateThreads = rtsTrue;
+ /* FetchStrategy is irrelevant in GrAnSim-Light */
+
+ /* GrAnSim Light often creates an abundance of parallel threads,
+ each with its own stack etc. Therefore, it's in general a good
+ idea to use small stack chunks (use the -o<size> option to
+ increase it again).
+ */
+ RTSflags.ConcFlags.stkChunkSize = 100;
+
+ RTSflags.GranFlags.proc = 1;
+}
+
static void
-process_gran_option()
+process_gran_option(int arg, int *rts_argc, char *rts_argv[], rtsBool *error)
{
- if (rts_argv[arg][2] != '\0') {
+ if (rts_argv[arg][1] != 'b') /* All GranSim options start with -b */
+ return;
/* Should we emulate hbcpp */
- if(strequal((rts_argv[arg]+2),"roken")) {
- ++DoAlwaysCreateThreads;
+ if(strcmp((rts_argv[arg]+2),"roken")==0) {
+ RTSflags.GranFlags.DoAlwaysCreateThreads=rtsTrue;
strcpy(rts_argv[arg]+2,"oring");
}
/* or a ridiculously idealised simulator */
- if(strequal((rts_argv[arg]+2),"oring")) {
- gran_latency = gran_fetchtime = gran_additional_latency =
- gran_gunblocktime = gran_lunblocktime
- = gran_threadcreatetime = gran_threadqueuetime
- = gran_threadscheduletime = gran_threaddescheduletime
- = gran_threadcontextswitchtime
- = 0;
-
- gran_mpacktime = gran_munpacktime = 0;
-
- gran_arith_cost = gran_float_cost = gran_load_cost
- = gran_store_cost = gran_branch_cost = 0;
-
- gran_heapalloc_cost = 1;
-
- /* ++DoFairSchedule; */
- ++DoStealThreadsFirst;
- ++DoThreadMigration;
- RTSflags.ParFlags.granSimStats = rtsTrue;
+ if(strcmp((rts_argv[arg]+2),"oring")==0) {
+ RTSflags.GranFlags.gran_latency =
+ RTSflags.GranFlags.gran_fetchtime =
+ RTSflags.GranFlags.gran_additional_latency =
+ RTSflags.GranFlags.gran_gunblocktime =
+ RTSflags.GranFlags.gran_lunblocktime =
+ RTSflags.GranFlags.gran_threadcreatetime =
+ RTSflags.GranFlags.gran_threadqueuetime =
+ RTSflags.GranFlags.gran_threadscheduletime =
+ RTSflags.GranFlags.gran_threaddescheduletime =
+ RTSflags.GranFlags.gran_threadcontextswitchtime = 0;
+
+ RTSflags.GranFlags.gran_mpacktime =
+ RTSflags.GranFlags.gran_munpacktime = 0;
+
+ RTSflags.GranFlags.gran_arith_cost =
+ RTSflags.GranFlags.gran_float_cost =
+ RTSflags.GranFlags.gran_load_cost =
+ RTSflags.GranFlags.gran_store_cost =
+ RTSflags.GranFlags.gran_branch_cost = 0;
+
+ RTSflags.GranFlags.gran_heapalloc_cost = 1;
+
+ /* ++RTSflags.GranFlags.DoFairSchedule; */
+ RTSflags.GranFlags.DoStealThreadsFirst = rtsTrue; /* -bZ */
+ RTSflags.GranFlags.DoThreadMigration = rtsTrue; /* -bM */
+ RTSflags.GranFlags.granSimStats = rtsTrue; /* -bP */
+ return;
}
- /* or a ridiculously idealised simulator */
- if(strequal((rts_argv[arg]+2),"onzo")) {
- gran_latency = gran_fetchtime = gran_additional_latency =
- gran_gunblocktime = gran_lunblocktime
- = gran_threadcreatetime = gran_threadqueuetime
- = gran_threadscheduletime = gran_threaddescheduletime
- = gran_threadcontextswitchtime
- = 0;
-
- gran_mpacktime = gran_munpacktime = 0;
-
- /* Keep default values for these
- gran_arith_cost = gran_float_cost = gran_load_cost
- = gran_store_cost = gran_branch_cost = 0;
- */
-
- gran_heapalloc_cost = 1;
-
- /* ++DoFairSchedule; */ /* -b-R */
- /* ++DoStealThreadsFirst; */ /* -b-T */
- ++DoReScheduleOnFetch; /* -bZ */
- ++DoThreadMigration; /* -bM */
- RTSflags.ParFlags.granSimStats = rtsTrue; /* -bP */
-# if defined(GRAN_CHECK) && defined(GRAN)
- debug = 0x20; /* print event statistics */
-# endif
+ /* or a somewhat idealised simulator */
+ if(strcmp((rts_argv[arg]+2),"onzo")==0) {
+ RTSflags.GranFlags.gran_latency =
+ RTSflags.GranFlags.gran_fetchtime =
+ RTSflags.GranFlags.gran_additional_latency =
+ RTSflags.GranFlags.gran_gunblocktime =
+ RTSflags.GranFlags.gran_lunblocktime =
+ RTSflags.GranFlags.gran_threadcreatetime =
+ RTSflags.GranFlags.gran_threadqueuetime =
+ RTSflags.GranFlags.gran_threadscheduletime =
+ RTSflags.GranFlags.gran_threaddescheduletime =
+ RTSflags.GranFlags.gran_threadcontextswitchtime = 0;
+
+ RTSflags.GranFlags.gran_mpacktime =
+ RTSflags.GranFlags.gran_munpacktime = 0;
+
+ RTSflags.GranFlags.gran_heapalloc_cost = 1;
+
+ /* RTSflags.GranFlags.DoFairSchedule = rtsTrue; */ /* -b-R */
+ /* RTSflags.GranFlags.DoStealThreadsFirst = rtsTrue; */ /* -b-T */
+ RTSflags.GranFlags.DoReScheduleOnFetch = rtsTrue; /* -bZ */
+ RTSflags.GranFlags.DoThreadMigration = rtsTrue; /* -bM */
+ RTSflags.GranFlags.granSimStats = rtsTrue; /* -bP */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ RTSflags.GranFlags.debug = 0x20; /* print event statistics */
+# endif
+ return;
}
/* Communication and task creation cost parameters */
- else switch(rts_argv[arg][2]) {
- case 'l':
+ switch(rts_argv[arg][2]) {
+ case ':':
+ enable_GrAnSimLight(); /* set flags for GrAnSim-Light mode */
+ break;
+
+ case 'l':
if (rts_argv[arg][3] != '\0')
{
- gran_gunblocktime = gran_latency = decode(rts_argv[arg]+3);
- gran_fetchtime = 2* gran_latency;
+ RTSflags.GranFlags.gran_gunblocktime =
+ RTSflags.GranFlags.gran_latency = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_fetchtime = 2*RTSflags.GranFlags.gran_latency;
}
else
- gran_latency = LATENCY;
+ RTSflags.GranFlags.gran_latency = LATENCY;
break;
- case 'a':
+ case 'a':
if (rts_argv[arg][3] != '\0')
- gran_additional_latency = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_additional_latency = decode(rts_argv[arg]+3);
else
- gran_additional_latency = ADDITIONAL_LATENCY;
+ RTSflags.GranFlags.gran_additional_latency = ADDITIONAL_LATENCY;
break;
- case 'm':
+ case 'm':
if (rts_argv[arg][3] != '\0')
- gran_mpacktime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_mpacktime = decode(rts_argv[arg]+3);
else
- gran_mpacktime = MSGPACKTIME;
+ RTSflags.GranFlags.gran_mpacktime = MSGPACKTIME;
break;
- case 'x':
+ case 'x':
if (rts_argv[arg][3] != '\0')
- gran_mtidytime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_mtidytime = decode(rts_argv[arg]+3);
else
- gran_mtidytime = 0;
+ RTSflags.GranFlags.gran_mtidytime = 0;
break;
- case 'r':
+ case 'r':
if (rts_argv[arg][3] != '\0')
- gran_munpacktime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_munpacktime = decode(rts_argv[arg]+3);
else
- gran_munpacktime = MSGUNPACKTIME;
+ RTSflags.GranFlags.gran_munpacktime = MSGUNPACKTIME;
break;
-
- case 'f':
+
+ case 'g':
if (rts_argv[arg][3] != '\0')
- gran_fetchtime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_fetchtime = decode(rts_argv[arg]+3);
else
- gran_fetchtime = FETCHTIME;
+ RTSflags.GranFlags.gran_fetchtime = FETCHTIME;
break;
-
- case 'n':
+
+ case 'n':
if (rts_argv[arg][3] != '\0')
- gran_gunblocktime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_gunblocktime = decode(rts_argv[arg]+3);
else
- gran_gunblocktime = GLOBALUNBLOCKTIME;
+ RTSflags.GranFlags.gran_gunblocktime = GLOBALUNBLOCKTIME;
break;
- case 'u':
+ case 'u':
if (rts_argv[arg][3] != '\0')
- gran_lunblocktime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_lunblocktime = decode(rts_argv[arg]+3);
else
- gran_lunblocktime = LOCALUNBLOCKTIME;
+ RTSflags.GranFlags.gran_lunblocktime = LOCALUNBLOCKTIME;
break;
/* Thread-related metrics */
- case 't':
+ case 't':
if (rts_argv[arg][3] != '\0')
- gran_threadcreatetime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_threadcreatetime = decode(rts_argv[arg]+3);
else
- gran_threadcreatetime = THREADCREATETIME;
+ RTSflags.GranFlags.gran_threadcreatetime = THREADCREATETIME;
break;
-
- case 'q':
+
+ case 'q':
if (rts_argv[arg][3] != '\0')
- gran_threadqueuetime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_threadqueuetime = decode(rts_argv[arg]+3);
else
- gran_threadqueuetime = THREADQUEUETIME;
+ RTSflags.GranFlags.gran_threadqueuetime = THREADQUEUETIME;
break;
-
- case 'c':
+
+ case 'c':
if (rts_argv[arg][3] != '\0')
- gran_threadscheduletime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_threadscheduletime = decode(rts_argv[arg]+3);
else
- gran_threadscheduletime = THREADSCHEDULETIME;
-
- gran_threadcontextswitchtime = gran_threadscheduletime
- + gran_threaddescheduletime;
+ RTSflags.GranFlags.gran_threadscheduletime = THREADSCHEDULETIME;
+
+ RTSflags.GranFlags.gran_threadcontextswitchtime = RTSflags.GranFlags.gran_threadscheduletime
+ + RTSflags.GranFlags.gran_threaddescheduletime;
break;
- case 'd':
+ case 'd':
if (rts_argv[arg][3] != '\0')
- gran_threaddescheduletime = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_threaddescheduletime = decode(rts_argv[arg]+3);
else
- gran_threaddescheduletime = THREADDESCHEDULETIME;
-
- gran_threadcontextswitchtime = gran_threadscheduletime
- + gran_threaddescheduletime;
+ RTSflags.GranFlags.gran_threaddescheduletime = THREADDESCHEDULETIME;
+
+ RTSflags.GranFlags.gran_threadcontextswitchtime = RTSflags.GranFlags.gran_threadscheduletime
+ + RTSflags.GranFlags.gran_threaddescheduletime;
break;
/* Instruction Cost Metrics */
- case 'A':
+ case 'A':
if (rts_argv[arg][3] != '\0')
- gran_arith_cost = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_arith_cost = decode(rts_argv[arg]+3);
else
- gran_arith_cost = ARITH_COST;
+ RTSflags.GranFlags.gran_arith_cost = ARITH_COST;
break;
- case 'F':
+ case 'F':
if (rts_argv[arg][3] != '\0')
- gran_float_cost = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_float_cost = decode(rts_argv[arg]+3);
else
- gran_float_cost = FLOAT_COST;
+ RTSflags.GranFlags.gran_float_cost = FLOAT_COST;
break;
-
- case 'B':
+
+ case 'B':
if (rts_argv[arg][3] != '\0')
- gran_branch_cost = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_branch_cost = decode(rts_argv[arg]+3);
else
- gran_branch_cost = BRANCH_COST;
+ RTSflags.GranFlags.gran_branch_cost = BRANCH_COST;
break;
- case 'L':
+ case 'L':
if (rts_argv[arg][3] != '\0')
- gran_load_cost = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_load_cost = decode(rts_argv[arg]+3);
else
- gran_load_cost = LOAD_COST;
+ RTSflags.GranFlags.gran_load_cost = LOAD_COST;
+ break;
+
+ case 'S':
+ if (rts_argv[arg][3] != '\0')
+ RTSflags.GranFlags.gran_store_cost = decode(rts_argv[arg]+3);
+ else
+ RTSflags.GranFlags.gran_store_cost = STORE_COST;
break;
- case 'S':
+ case 'H':
if (rts_argv[arg][3] != '\0')
- gran_store_cost = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_heapalloc_cost = decode(rts_argv[arg]+3);
else
- gran_store_cost = STORE_COST;
+ RTSflags.GranFlags.gran_heapalloc_cost = 0;
break;
- case 'H':
+ case 'y':
+ RTSflags.GranFlags.DoReScheduleOnFetch = rtsTrue;
+ if (rts_argv[arg][3] != '\0')
+ RTSflags.GranFlags.FetchStrategy = decode(rts_argv[arg]+3);
+ if (RTSflags.GranFlags.FetchStrategy == 0)
+ RTSflags.GranFlags.DoReScheduleOnFetch = rtsFalse;
+ else
+ RTSflags.GranFlags.FetchStrategy = 2; /* default: fetch everything */
+ break;
+
+ case 'K': /* sort overhead (per elem in spark list) */
if (rts_argv[arg][3] != '\0')
- gran_heapalloc_cost = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_pri_spark_overhead = decode(rts_argv[arg]+3);
else
- gran_heapalloc_cost = 0;
+ RTSflags.GranFlags.gran_pri_spark_overhead = PRI_SPARK_OVERHEAD;
+ fprintf(stderr,"Overhead for pri spark: %d (per elem).\n",
+ RTSflags.GranFlags.gran_pri_spark_overhead);
break;
- case 'y':
+ case 'O': /* sort overhead (per elem in spark list) */
if (rts_argv[arg][3] != '\0')
- FetchStrategy = decode(rts_argv[arg]+3);
+ RTSflags.GranFlags.gran_pri_sched_overhead = decode(rts_argv[arg]+3);
else
- FetchStrategy = 4; /* default: fetch everything */
+ RTSflags.GranFlags.gran_pri_sched_overhead = PRI_SCHED_OVERHEAD;
+ fprintf(stderr,"Overhead for pri sched: %d (per elem).\n",
+ RTSflags.GranFlags.gran_pri_sched_overhead);
break;
- /* General Parameters */
- case 'p':
+ /* General Parameters */
+ case 'p':
if (rts_argv[arg][3] != '\0')
{
- max_proc = decode(rts_argv[arg]+3);
- if(max_proc > MAX_PROC || max_proc < 1)
+ RTSflags.GranFlags.proc = decode(rts_argv[arg]+3);
+ if (RTSflags.GranFlags.proc==0) {
+ enable_GrAnSimLight(); /* set flags for GrAnSim-Light mode */
+ } else if (RTSflags.GranFlags.proc > MAX_PROC ||
+ RTSflags.GranFlags.proc < 1)
{
- fprintf(stderr,"setupRtsFlags: no more than %u processors allowed\n", MAX_PROC);
- error = rtsTrue;
+ fprintf(stderr,"setupRtsFlags: no more than %u processors
+allowed\n",
+ MAX_PROC);
+ *error = rtsTrue;
}
}
else
- max_proc = MAX_PROC;
+ RTSflags.GranFlags.proc = MAX_PROC;
break;
- case 'C':
- ++DoAlwaysCreateThreads;
- ++DoThreadMigration;
+ case 'f':
+ if (rts_argv[arg][3] != '\0')
+ RTSflags.GranFlags.max_fishes = decode(rts_argv[arg]+3);
+ else
+ RTSflags.GranFlags.max_fishes = 1;
break;
-
- case 'G':
- ++DoGUMMFetching;
+
+ case 'w':
+ if (rts_argv[arg][3] != '\0')
+ RTSflags.GranFlags.time_slice = decode(rts_argv[arg]+3);
+ else
+ RTSflags.GranFlags.time_slice = GRAN_TIME_SLICE;
break;
-
- case 'M':
- ++DoThreadMigration;
+
+ case 'C':
+ RTSflags.GranFlags.DoAlwaysCreateThreads=rtsTrue;
+ RTSflags.GranFlags.DoThreadMigration=rtsTrue;
break;
- case 'R':
- ++DoFairSchedule;
+ case 'G':
+ fprintf(stderr,"Bulk fetching enabled.\n");
+ RTSflags.GranFlags.DoGUMMFetching=rtsTrue;
break;
-
- case 'T':
- ++DoStealThreadsFirst;
- ++DoThreadMigration;
+
+ case 'M':
+ fprintf(stderr,"Thread migration enabled.\n");
+ RTSflags.GranFlags.DoThreadMigration=rtsTrue;
break;
- case 'Z':
- ++DoReScheduleOnFetch;
+ case 'R':
+ fprintf(stderr,"Fair Scheduling enabled.\n");
+ RTSflags.GranFlags.DoFairSchedule=rtsTrue;
+ break;
+
+ case 'I':
+ fprintf(stderr,"Priority Scheduling enabled.\n");
+ RTSflags.GranFlags.DoPriorityScheduling=rtsTrue;
break;
- case 'z':
- ++SimplifiedFetch;
+ case 'T':
+ RTSflags.GranFlags.DoStealThreadsFirst=rtsTrue;
+ RTSflags.GranFlags.DoThreadMigration=rtsTrue;
+ break;
+
+ case 'Z':
+ RTSflags.GranFlags.DoReScheduleOnFetch=rtsTrue;
+ break;
+
+ case 'z':
+ RTSflags.GranFlags.SimplifiedFetch=rtsTrue;
+ break;
+
+ case 'N':
+ RTSflags.GranFlags.PreferSparksOfLocalNodes=rtsTrue;
+ break;
+
+ case 'b':
+ RTSflags.GranFlags.granSimStats_Binary=rtsTrue;
+ break;
+
+ case 'P':
+ RTSflags.GranFlags.granSimStats=rtsTrue;
break;
- case 'N':
- ++PreferSparksOfLocalNodes;
+ case 's':
+ RTSflags.GranFlags.granSimStats_Sparks=rtsTrue;
break;
- case 'b':
- RTSflags.ParFlags.granSimStats_Binary = rtsTrue;
+ case 'h':
+ RTSflags.GranFlags.granSimStats_Heap=rtsTrue;
break;
- case 'P':
- RTSflags.ParFlags.granSimStats = rtsTrue;
+ case 'U':
+ RTSflags.GranFlags.labelling=rtsTrue;
break;
- case 's':
- ++do_sp_profile;
+ case 'Y': /* syntax: -bY<n>[,<n>] n ... pos int */
+ if (rts_argv[arg][3] != '\0') {
+ char *arg0, *tmp;
+
+ arg0 = rts_argv[arg]+3;
+ if ((tmp = strstr(arg0,","))==NULL) {
+ RTSflags.GranFlags.SparkPriority = decode(arg0);
+ fprintf(stderr,"SparkPriority: %u.\n",RTSflags.GranFlags.SparkPriority);
+ } else {
+ *(tmp++) = '\0';
+ RTSflags.GranFlags.SparkPriority = decode(arg0);
+ RTSflags.GranFlags.SparkPriority2 = decode(tmp);
+ fprintf(stderr,"SparkPriority: %u.\n",
+ RTSflags.GranFlags.SparkPriority);
+ fprintf(stderr,"SparkPriority2:%u.\n",
+ RTSflags.GranFlags.SparkPriority2);
+ if (RTSflags.GranFlags.SparkPriority2 <
+ RTSflags.GranFlags.SparkPriority) {
+ fprintf(stderr,"WARNING: 2nd pri < main pri (%u<%u); 2nd pri has no effect\n",
+ RTSflags.GranFlags.SparkPriority2,
+ RTSflags.GranFlags.SparkPriority);
+ }
+ }
+ } else {
+ /* plain pri spark is now invoked with -bX
+ RTSflags.GranFlags.DoPrioritySparking = 1;
+ fprintf(stderr,"PrioritySparking.\n");
+ */
+ }
break;
- case '-':
+ case 'Q':
+ if (rts_argv[arg][3] != '\0') {
+ RTSflags.GranFlags.ThunksToPack = decode(rts_argv[arg]+3);
+ } else {
+ RTSflags.GranFlags.ThunksToPack = 1;
+ }
+ fprintf(stderr,"Thunks To Pack in one packet: %u.\n",
+ RTSflags.GranFlags.ThunksToPack);
+ break;
+
+ case 'e':
+ RTSflags.GranFlags.RandomSteal = rtsFalse;
+ fprintf(stderr,"Deterministic mode (no random stealing)\n");
+ break;
+
+ /* The following class of options contains eXperimental */
+ /* features in connection with exploiting granularity */
+ /* information. I.e. if -bY is chosen these options */
+ /* tell the RTS what to do with the supplied info --HWL */
+ case 'X':
switch(rts_argv[arg][3]) {
+
+ case '\0':
+ RTSflags.GranFlags.DoPrioritySparking = 1;
+ fprintf(stderr,"Priority Sparking with Normal Priorities.\n");
+ RTSflags.GranFlags.InversePriorities = rtsFalse;
+ RTSflags.GranFlags.RandomPriorities = rtsFalse;
+ RTSflags.GranFlags.IgnorePriorities = rtsFalse;
+ break;
+
+ case 'I':
+ RTSflags.GranFlags.DoPrioritySparking = 1;
+ fprintf(stderr,"Priority Sparking with Inverse Priorities.\n");
+ RTSflags.GranFlags.InversePriorities++;
+ break;
+
+ case 'R':
+ RTSflags.GranFlags.DoPrioritySparking = 1;
+ fprintf(stderr,"Priority Sparking with Random Priorities.\n");
+ RTSflags.GranFlags.RandomPriorities++;
+ break;
+
+ case 'N':
+ RTSflags.GranFlags.DoPrioritySparking = 1;
+ fprintf(stderr,"Priority Sparking with No Priorities.\n");
+ RTSflags.GranFlags.IgnorePriorities++;
+ break;
+
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
+ break;
- case 'C':
- DoAlwaysCreateThreads=0;
- DoThreadMigration=0;
- break;
-
- case 'G':
- DoGUMMFetching=0;
- break;
-
- case 'M':
- DoThreadMigration=0;
- break;
+ case '-':
+ switch(rts_argv[arg][3]) {
+
+ case 'C':
+ RTSflags.GranFlags.DoAlwaysCreateThreads=rtsFalse;
+ RTSflags.GranFlags.DoThreadMigration=rtsFalse;
+ break;
+
+ case 'G':
+ RTSflags.GranFlags.DoGUMMFetching=rtsFalse;
+ break;
+
+ case 'M':
+ RTSflags.GranFlags.DoThreadMigration=rtsFalse;
+ break;
case 'R':
- DoFairSchedule=0;
- break;
-
- case 'T':
- DoStealThreadsFirst=0;
- DoThreadMigration=0;
- break;
-
- case 'Z':
- DoReScheduleOnFetch=0;
- break;
-
- case 'N':
- PreferSparksOfLocalNodes=0;
- break;
-
- case 'P':
- RTSflags.ParFlags.granSimStats = rtsFalse;
- no_gr_profile=1;
- break;
-
- case 's':
- do_sp_profile=0;
- break;
-
- case 'b':
- RTSflags.ParFlags.granSimStats_Binary = rtsFalse;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
+ RTSflags.GranFlags.DoFairSchedule=rtsFalse;
+ break;
+
+ case 'T':
+ RTSflags.GranFlags.DoStealThreadsFirst=rtsFalse;
+ RTSflags.GranFlags.DoThreadMigration=rtsFalse;
+ break;
+
+ case 'Z':
+ RTSflags.GranFlags.DoReScheduleOnFetch=rtsFalse;
+ break;
+
+ case 'N':
+ RTSflags.GranFlags.PreferSparksOfLocalNodes=rtsFalse;
+ break;
+
+ case 'P':
+ RTSflags.GranFlags.granSimStats_suppressed=rtsTrue;
+ break;
+
+ case 's':
+ RTSflags.GranFlags.granSimStats_Sparks=rtsFalse;
+ break;
+
+ case 'h':
+ RTSflags.GranFlags.granSimStats_Heap=rtsFalse;
+ break;
+
+ case 'b':
+ RTSflags.GranFlags.granSimStats_Binary=rtsFalse;
+ break;
+
+ case 'X':
+ RTSflags.GranFlags.DoPrioritySparking = rtsFalse;
+ break;
+
+ case 'Y':
+ RTSflags.GranFlags.DoPrioritySparking = rtsFalse;
+ RTSflags.GranFlags.SparkPriority = rtsFalse;
+ break;
+
+ case 'I':
+ RTSflags.GranFlags.DoPriorityScheduling = rtsFalse;
+ break;
+
+ case 'e':
+ RTSflags.GranFlags.RandomSteal = rtsFalse;
+ break;
+
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
break;
-# if defined(GRAN_CHECK) && defined(GRAN)
- case 'D':
+# if defined(GRAN_CHECK) && defined(GRAN)
+ case 'D':
switch(rts_argv[arg][3]) {
- case 'e': /* event trace */
- fprintf(stderr,"Printing event trace.\n");
- ++event_trace;
- break;
-
- case 'f':
- fprintf(stderr,"Printing forwarding of FETCHNODES.\n");
- debug |= 0x2; /* print fwd messages */
- break;
-
- case 'z':
- fprintf(stderr,"Check for blocked on fetch.\n");
- debug |= 0x4; /* debug non-reschedule-on-fetch */
- break;
-
- case 't':
- fprintf(stderr,"Check for TSO asleep on fetch.\n");
- debug |= 0x10; /* debug TSO asleep for fetch */
- break;
-
- case 'E':
- fprintf(stderr,"Printing event statistics.\n");
- debug |= 0x20; /* print event statistics */
- break;
-
- case 'F':
- fprintf(stderr,"Prohibiting forward.\n");
- NoForward = 1; /* prohibit forwarding */
- break;
-
- case 'm':
- fprintf(stderr,"Printing fetch misses.\n");
- PrintFetchMisses = 1; /* prohibit forwarding */
- break;
-
- case 'd':
- fprintf(stderr,"Debug mode.\n");
- debug |= 0x40;
- break;
-
- case 'D':
- fprintf(stderr,"Severe debug mode.\n");
- debug |= 0x80;
- break;
-
- case '\0':
- debug = 1;
- break;
-
- default:
- bad_option( rts_argv[arg] );
- break;
- }
- break;
-# endif
- default:
- bad_option( rts_argv[arg] );
+ case 'Q': /* Set pack buffer size (same as 'Q' in GUM) */
+ if (rts_argv[arg][4] != '\0') {
+ RTSflags.GranFlags.packBufferSize = decode(rts_argv[arg]+4);
+ fprintf(stderr,"Pack buffer size: %d\n",
+ RTSflags.GranFlags.packBufferSize);
+ } else {
+ fprintf(stderr, "setupRtsFlags: missing size of PackBuffer (for -Q)\n");
+ error = rtsTrue;
+ }
+ break;
+
+ case 'e': /* event trace */
+ fprintf(stderr,"Printing event trace.\n");
+ RTSflags.GranFlags.event_trace=rtsTrue;
+ break;
+
+ case 'f':
+ fprintf(stderr,"Printing forwarding of FETCHNODES.\n");
+ RTSflags.GranFlags.debug |= 0x2; /* print fwd messages */
+ break;
+
+ case 'z':
+ fprintf(stderr,"Check for blocked on fetch.\n");
+ RTSflags.GranFlags.debug |= 0x4; /* debug non-reschedule-on-fetch */
+ break;
+
+ case 't':
+ fprintf(stderr,"Check for TSO asleep on fetch.\n");
+ RTSflags.GranFlags.debug |= 0x10; /* debug TSO asleep for fetch */
+ break;
+
+ case 'E':
+ fprintf(stderr,"Printing event statistics.\n");
+ RTSflags.GranFlags.debug |= 0x20; /* print event statistics */
+ break;
+
+ case 'F':
+ fprintf(stderr,"Prohibiting forward.\n");
+ RTSflags.GranFlags.NoForward = rtsTrue; /* prohibit forwarding */
+ break;
+
+ case 'm':
+ fprintf(stderr,"Printing fetch misses.\n");
+ RTSflags.GranFlags.PrintFetchMisses = rtsTrue; /* prohibit forwarding */
+ break;
+
+ case 'd':
+ fprintf(stderr,"Debug mode.\n");
+ RTSflags.GranFlags.debug |= 0x40;
+ break;
+
+ case 'D':
+ fprintf(stderr,"Severe debug mode.\n");
+ RTSflags.GranFlags.debug |= 0x80;
+ break;
+
+ case 'q':
+ fprintf(stderr,"FULL event trace.\n");
+ RTSflags.GranFlags.event_trace_all =rtsTrue;
+ break;
+
+ case 'G':
+ fprintf(stderr,"Debugging packet fetching.\n");
+ RTSflags.GranFlags.debug |= 0x100;
+ break;
+
+ case 'n':
+ fprintf(stderr,"Ignore events till end of time slice\n");
+ RTSflags.GranFlags.debug |= 0x200;
+ IgnoreEvents = rtsTrue;
+ break;
+
+ case 'S':
+ fprintf(stderr,"Check that spark queues are sorted.\n");
+ RTSflags.GranFlags.debug |= 0x400;
+ break;
+
+ case 'H':
+ fprintf(stderr,"Print heap allocation messages (RBH).\n");
+ RTSflags.GranFlags.debug |= 0x800;
+ break;
+
+ case 'p':
+ fprintf(stderr,"Debug breadth-first pruning.\n");
+ RTSflags.GranFlags.debug |= 0x1000;
+ break;
+
+ case 'r':
+ fprintf(stderr,"Debug random stealing.\n");
+ RTSflags.GranFlags.debug |= 0x2000;
+ break;
+
+ case 'B':
+ fprintf(stderr,"Debug busyness.\n");
+ RTSflags.GranFlags.debug |= 0x4000;
+ break;
+
+ case 's':
+ fprintf(stderr,"Debug spark-queue manipulations.\n");
+ RTSflags.GranFlags.debug |= 0x10000;
+ break;
+
+ case ':':
+ fprintf(stderr,"Debug GrAnSim Light.\n");
+ RTSflags.GranFlags.debug |= 0x20000;
+ break;
+
+ case '\0':
+ RTSflags.GranFlags.debug = 1;
+ break;
+
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
break;
- }
- }
- do_gr_sim++;
- RTSflags.ConcFlags.ctxtSwitchTime = 0;
-}
+# endif /* GRAN_CHECK */
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
+}
#endif /* GRAN */
\end{code}
IMMUTUPLE_RTBL();
STATIC_RTBL();
-#ifndef PAR
-MallocPtr_RTBL();
+#if !defined(PAR) /* && !defined(GRAN) */
+ForeignObj_RTBL();
#endif
BH_RTBL(N);
# ifdef CONCURRENT
DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextSpark,_Dummy_PRReturn_entry);
# endif
+# if defined(GRAN)
+DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextEvent,_Dummy_PRReturn_entry);
+DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextClosureInFetchBuffer,_Dummy_PRReturn_entry);
+# endif
# ifdef PAR
DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextGA,_Dummy_PRReturn_entry);
# else
+# if 1 /* !defined(CONCURRENT) */ /* HWL */
DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextAStack,_Dummy_PRReturn_entry);
DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextBStack,_Dummy_PRReturn_entry);
+# endif
# endif
#endif
# endif
#endif
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
SPEC_RBH_RTBL(2,0);
SPEC_RBH_RTBL(2,1);
SPEC_RBH_RTBL(2,2);
%* *
%************************************************************************
+Handling of select() of read&write on file descriptors or timer expiry.
+
\begin{code}
#ifdef CONCURRENT
#define NULL_REG_MAP
#define NON_POSIX_SOURCE
/* Should there be a POSIX alternative based on poll()? */
-#include "stgdefs.h"
+
+#include "rtsdefs.h"
# if defined(HAVE_SYS_TYPES_H)
# include <sys/types.h>
# include <sys/time.h>
# endif
+/* Counter holding the number of timer ticks seen during GC */
+I_ delayTicks = 0;
+
+/*
+ handleTimerExpiry is used to temporarily delay the handling of
+ timer ticks for threads delayed waiting for timeout. Disable
+ during GC, counting up the ticks , before updating the waiting
+ threads queue when finished GCing.
+
+ */
+
+void
+handleTimerExpiry(enable)
+rtsBool enable;
+{
+ /*
+ If we enable the handling of timer expiry, update the WaitingThreads
+ queue with the number of ticks we have accumulated since the handling
+ was disabled.
+ */
+ if (!enable)
+ delayTicks = 1;
+ else {
+ if (delayTicks > 1) {
+ delayTicks = 0;
+ AwaitEvent((delayTicks-1) * RTSflags.ConcFlags.ctxtSwitchTime);
+ }
+ }
+}
+
void
AwaitEvent(I_ delta)
{
P_ tso, prev, next;
rtsBool ready;
- fd_set rfd;
+ fd_set rfd,wfd;
I_ us;
- I_ min;
+ I_ min, numFound;
I_ maxfd=0;
- struct timeval tv;
+
+ struct timeval tv,tv_before,tv_after;
min = delta == 0 ? 0x7fffffff : 0;
/*
* Collect all of the fd's that we're interested in, and capture
- * the minimum waiting time for the delayed threads.
+ * the minimum waiting time (in microseconds) for the delayed threads.
*
- * (I_)TSO_EVENT(tso) < 0 => thread waiting on fd (-(I_)TSO_EVENT(tso))
+ * (I_)TSO_EVENT(tso) < 0 => thread waiting on read on fd (-(I_)TSO_EVENT(tso))
*
+ * (I_)TSO_EVENT(tso) < -FD_SETSIZE => thread waiting on write on fd
+ * (FD_SETSIZE-(I_)TSO_EVENT(tso))
*/
FD_ZERO(&rfd);
- for(tso = WaitingThreadsHd; tso != Nil_closure; tso = TSO_LINK(tso)) {
+ FD_ZERO(&wfd);
+ for(tso = WaitingThreadsHd; tso != Prelude_Z91Z93_closure; tso = TSO_LINK(tso)) {
us = (I_) TSO_EVENT(tso);
if (us > 0) {
/* Looking at a delay event */
if (us < min)
min = us;
+ } else if ( us <= (-(I_)FD_SETSIZE)) {
+ /* Looking at a waitWrite event */
+ us += (I_)FD_SETSIZE;
+ maxfd = ((1-us)> maxfd) ? (1-us) : maxfd;
+ FD_SET((-us), &wfd);
} else {
- /* Looking at a wait event */
- maxfd = ((-us)> maxfd) ? (-us) : maxfd;
+ /* Looking at a waitRead event */
+ maxfd = ((1-us)> maxfd) ? (1-us) : maxfd;
FD_SET((-us), &rfd);
}
}
tv.tv_sec = min / 1000000;
tv.tv_usec = min % 1000000;
- while (select((maxfd==0 ? 0 : (maxfd+1)), &rfd, NULL, NULL, &tv) < 0) {
+ gettimeofday(&tv_before, (struct timezone *) NULL);
+
+ while ((numFound = select(maxfd, &rfd, &wfd, NULL, &tv)) < 0) {
if (errno != EINTR) {
fflush(stdout);
fprintf(stderr, "AwaitEvent: select failed\n");
EXIT(EXIT_FAILURE);
}
}
-
+
+ if (numFound != 0) {
+ /*
+ File descriptors ready, but we have don't know how much time was spent
+ in the select(). To interpolate, we compare the time before and after the
+ select().
+ */
+
+ gettimeofday(&tv_after, (struct timezone *) NULL);
+ delta = (tv_after.tv_sec - tv_before.tv_sec) * 1000000 +
+ tv_after.tv_usec - tv_before.tv_usec;
+
+ }
+
if (delta == 0)
delta=min;
+ /*
+ Step through the waiting queue, unblocking every thread that now has
+ a file descriptor in a ready state.
+
+ For the delayed threads, decrement the number of microsecs
+ we've been blocked for. Unblock the threads that have thusly expired.
+ */
+
prev = NULL;
- for(tso = WaitingThreadsHd; tso != Nil_closure; tso = next) {
+ for(tso = WaitingThreadsHd; tso != Prelude_Z91Z93_closure; tso = next) {
next = TSO_LINK(tso);
us = (I_) TSO_EVENT(tso);
if (us > 0) {
ready = (us <= 0);
if (!ready)
TSO_EVENT(tso) = (W_) us;
+ } else if ( us <= (-(I_)FD_SETSIZE)) {
+ /* Looking at a waitWrite event */
+ ready = FD_ISSET(((I_)FD_SETSIZE-us), &wfd);
} else {
- /* Looking at a wait event */
+ /* Looking at a waitRead event */
ready = FD_ISSET((-us), &rfd);
}
if (ready) {
#if defined(GRAN)
- if (ThreadQueueTl == Nil_closure)
+ if (ThreadQueueTl == Prelude_Z91Z93_closure)
ThreadQueueHd = tso;
else
TSO_LINK(ThreadQueueTl) = tso;
ThreadQueueTl = tso;
- TSO_LINK(tso) = Nil_closure;
+ TSO_LINK(tso) = Prelude_Z91Z93_closure;
#else
- if (RunnableThreadsTl == Nil_closure)
+ if (RunnableThreadsTl == Prelude_Z91Z93_closure)
RunnableThreadsHd = tso;
else
TSO_LINK(RunnableThreadsTl) = tso;
RunnableThreadsTl = tso;
- TSO_LINK(tso) = Nil_closure;
+ TSO_LINK(tso) = Prelude_Z91Z93_closure;
#endif
} else {
if (prev == NULL)
}
}
if (prev == NULL)
- WaitingThreadsHd = WaitingThreadsTl = Nil_closure;
+ WaitingThreadsHd = WaitingThreadsTl = Prelude_Z91Z93_closure;
else {
- TSO_LINK(prev) = Nil_closure;
+ TSO_LINK(prev) = Prelude_Z91Z93_closure;
WaitingThreadsTl = prev;
}
}
# define NON_POSIX_SOURCE
#endif
+#if defined(freebsd_TARGET_OS)
+# define NON_POSIX_SOURCE
+#endif
+
#if defined(osf1_TARGET_OS)
/* The include files for OSF1 do not normally define SA_SIGINFO */
# define _OSF_SOURCE 1
# include <signal.h>
#endif
+#if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
+ /* to look *inside* sigcontext... */
+# include <asm/signal.h>
+#endif
+
#if defined(HAVE_SIGINFO_H)
/* DEC OSF1 seems to need this explicitly. Maybe others do as well? */
# include <siginfo.h>
Fun, eh?
\begin{code}
-# if defined(sunos4_TARGET_OS)
+# if defined(sunos4_TARGET_OS) || defined(freebsd_TARGET_OS) \
+ || defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
static void
-segv_handler(sig, code, scp, addr)
- int sig;
- int code; /* NB: all except first argument are "implementation defined" */
- struct sigcontext *scp;
- caddr_t addr;
+segv_handler(int sig,
+ /* NB: all except first argument are "implementation defined" */
+# if defined(sunos4_TARGET_OS) || defined(freebsd_TARGET_OS)
+ int code, struct sigcontext *scp, caddr_t addr)
+# else /* linux */
+ struct sigcontext_struct scp)
+# endif /* linux */
{
extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
+# if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
+ caddr_t addr = scp.cr2;
+ /* Magic info from Tommy Thorn! */
+# endif
+
if (addr >= (caddr_t) stks_space
&& addr < (caddr_t) (stks_space + RTSflags.GcFlags.stksSize))
StackOverflow();
int
install_segv_handler(void)
{
+#if freebsd_TARGET_OS
+ /* FreeBSD seems to generate SIGBUS for stack overflows */
+ if (signal(SIGBUS, segv_handler) == SIG_ERR)
+ return -1;
+ return ((int) signal(SIGSEGV, segv_handler));
+#else
return ((int) signal(SIGSEGV, segv_handler) == SIG_ERR);
/* I think the "== SIG_ERR" is saying "there was no
handler for SIGSEGV before this one". WDP 95/12
*/
+#endif
}
-# else /* Not SunOS 4 */
+# else /* Not SunOS 4, FreeBSD, or Linux(a.out) */
# if defined(irix_TARGET_OS)
/* certainly BOGUS (WDP 94/05) -- copied from /usr/include/sys/siginfo.h */
here.
\begin{code}
-#if (defined(PROFILING) || defined(CONCURRENT)) && !defined(GRAN)
+#if defined(PROFILING) || defined(CONCURRENT) /* && !defined(GRAN) */
# ifdef CONCURRENT
+extern I_ delayTicks;
+
# ifdef PAR
extern P_ CurrentTSO;
# endif
}
# endif
- if (WaitingThreadsHd != Nil_closure)
- AwaitEvent(RTSflags.ConcFlags.ctxtSwitchTime);
+ /*
+ Handling a tick for threads blocked waiting for file
+ descriptor I/O or time.
+
+ This requires some care since virtual time alarm ticks
+ can occur when we are in the GC. If that is the case,
+ we just increment a delayed timer tick counter, but do
+ not check to see if any TSOs have been made runnable
+ as a result. (Do a bulk update of their status once
+ the GC has completed).
+
+ If the vtalrm does not occur within GC, we try to promote
+ any of the waiting threads to the runnable list (see awaitEvent)
+
+ 4/96 SOF
+ */
+
+ if (delayTicks != 0) /* delayTicks>0 => don't handle timer expiry (in GC) */
+ delayTicks++;
+ else if (WaitingThreadsHd != Prelude_Z91Z93_closure)
+ AwaitEvent(RTSflags.ConcFlags.ctxtSwitchTime);
# ifdef PAR
if (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL] ||
if (CurrentTSO != NULL ||
# else
- if (RunnableThreadsHd != Nil_closure ||
+ if (RunnableThreadsHd != Prelude_Z91Z93_closure ||
# endif
PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL] ||
PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL]) {
\begin{code}
-#ifdef PAR
+#if defined(PAR) /* || defined(GRAN) */
void
blockUserSignals(void)
/* Urgh. Two queues. Merge them. */
P_ tso = (P_) BQ_ENTRIES(updatee_keep);
- while (TSO_LINK(tso) != Nil_closure)
+ while (TSO_LINK(tso) != Prelude_Z91Z93_closure)
tso = TSO_LINK(tso);
TSO_LINK(tso) = (P_) BQ_ENTRIES(updatee_bypass);
SET_TASK_ACTIVITY(ST_OVERHEAD);
- /*?/
+ /*?
+ if (RTSflags.GcFlags.giveStats) {
fprintf(stderr,"StackOverflow:liveness=%lx,a=%lx,b=%lx\n",
liveness,words_of_a,words_of_b);
- /?*/
+ }
+ ?*/
old_stko = SAVE_StkO;
- /*?/
+ /*?
+ if (RTSflags.GcFlags.giveStats) {
fprintf(stderr, "stko: %lx SpA %lx SuA %lx SpB %lx SuB %lx\n",
old_stko, STKO_SpA(old_stko),
STKO_SuA(old_stko), STKO_SpB(old_stko), STKO_SuB(old_stko));
- /?*/
+ }
+ ?*/
if (RTSflags.GcFlags.squeezeUpdFrames) {
STKO_SuB(old_stko) += BREL(i);
STKO_SpB(old_stko) += BREL(i);
- /*?/ fprintf(stderr, "Just squeezed; now: SpB %lx SuB %lx retval %d\n", STKO_SpB(old_stko), STKO_SuB(old_stko), i); /?*/
+ /*?
+ if (RTSflags.GcFlags.giveStats)
+ fprintf(stderr, "Just squeezed; now: SpB %lx SuB %lx retval %d\n", STKO_SpB(old_stko), STKO_SuB(old_stko), i); ?*/
if ((P_) STKO_SpA(old_stko) - AREL(headroom) > STKO_SpB(old_stko)) {
- /*?/
+ /*?
+ if (RTSflags.GcFlags.giveStats) {
fprintf(stderr, "Squeezed; now: SpA %lx SpB %lx headroom %d\n", STKO_SpA(old_stko),
STKO_SpB(old_stko), headroom);
- /?*/
+ }
+ ?*/
/* We saved enough space to continue on the old StkO */
return 0;
ASSERT(sanityChk_StkO(old_stko));
/* Double the stack chunk size each time we grow the stack */
- /*?/ fprintf(stderr, "Stko %lx: about to double stk-chk size from %d...\n", old_stko, STKO_CLOSURE_CTS_SIZE(old_stko)); /?*/
+ /*?
+ if (RTSflags.GcFlags.giveStats) {
+ fprintf(stderr, "Stko %lx: about to double stk-chk size from %d...\n", old_stko, STKO_CLOSURE_CTS_SIZE(old_stko)); } ?*/
cts_size = STKO_CLOSURE_CTS_SIZE(old_stko) * 2;
if (SAVE_Hp + STKO_HS + cts_size > SAVE_HpLim) {
TSO_PC2(CurrentTSO) = EnterNodeCode;
really_reenter_node = 1;
}
- /*?/ fprintf(stderr, "StkO %lx: stk-chk GC: size %d...\n", old_stko, STKO_HS + cts_size);/?*/
+ /*?
+ if (RTSflags.GcFlags.giveStats) {
+ fprintf(stderr, "StkO %lx: stk-chk GC: size %d...\n",
+ old_stko, STKO_HS + cts_size);
+ } ?*/
ReallyPerformThreadGC(STKO_HS + cts_size, rtsFalse);
/*
now, GC semantics promise to have left SAVE_Hp with
SAVE_Hp += STKO_HS + cts_size;
SET_STKO_HDR(new_stko, StkO_info, CCC);
- /*?/ fprintf(stderr, "New StkO now %lx...\n", new_stko); /?*/
+ /*? if (RTSflags.GcFlags.giveStats) fprintf(stderr, "New StkO now %lx...\n", new_stko); ?*/
/* Initialize the StkO, as in NewThread */
STKO_SIZE(new_stko) = cts_size + STKO_VHS;
STKO_SpA(new_stko) = STKO_SuA(new_stko) = STKO_ASTK_BOT(new_stko) + AREL(1);
STKO_LINK(new_stko) = old_stko;
- /*?/ fprintf(stderr, "New StkO SpA = %lx...\n", STKO_SpA(new_stko) ); /?*/
+ /*? if (RTSflags.GcFlags.giveStats) fprintf(stderr, "New StkO SpA = %lx...\n", STKO_SpA(new_stko) ); ?*/
STKO_RETURN(new_stko) = SAVE_Ret;
now - worth putting them in a file by themselves?? [ADR] */
-#ifndef PAR
+#if !defined(PAR) /* && !defined(GRAN) */
-/* Ditto for Malloc Pointer entry point and info tables. [ADR]
+/* Ditto for Foreign Objectr entry point and info tables. [ADR]
BTW Will, I copied most of this blindly from above - what's with
this TAG stuff? And what kind of description/ type is wanted here?
*/
-STATICFUN(MallocPtr_entry)
+STATICFUN(ForeignObj_entry)
{
FB_
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
- fprintf(stderr, "Compiler bug: Entered a Malloc Pointer---this shouldn't happen!\n");
+ fprintf(stderr, "Compiler bug: Entered a ForeignObj---this shouldn't happen!\n");
abort();
FE_
}
-MallocPtr_ITBL(MallocPtr_info,MallocPtr_entry,UpdErr,0,INFO_OTHER_TAG,,,const,EF_,MallocPtr_K,"MALLOC PTR","MallocPtr");
+ForeignObj_ITBL(ForeignObj_info,ForeignObj_entry,UpdErr,0,INFO_OTHER_TAG,,,const,EF_,ForeignObj_K,"FOREIGN OBJ","ForeignObj");
-/* End of MallocPtr stuff */
+/* End of ForeignObj stuff */
/* Ditto for the unused Stable Pointer info table. [ADR]
*/
/* Question: this is just an amusing hex code isn't it
-- or does it mean something? ADR */
P_ realWorldZh_closure = (P_) 0xbadbadbaL;
+P_ GHCbuiltins_void_closure = (P_) 0xbadbadbaL;
-SET_STATIC_HDR(WorldStateToken_closure,SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
+SET_STATIC_HDR(WorldStateToken_closure,GHCbase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
, (W_) 0xbadbadbaL
};
#else
SuA = stackInfo.botA + AREL(1);
SuB = stackInfo.botB + BREL(1);
+ /* HWL */
+ /*
+ SpB = SuB = STKO_BSTK_BOT(StkOReg) + BREL(1);
+ SuA = STKO_ASTK_BOT(StkOReg) + AREL(1);
+ */
+
#endif
break;
*SpA = (P_) WorldStateToken_closure;
- STKO_LINK(StkOReg) = Nil_closure;
+ STKO_LINK(StkOReg) = Prelude_Z91Z93_closure;
STKO_RETURN(StkOReg) = NULL;
#ifdef TICKY_TICKY
\end{code}
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
STATICFUN(RBH_Save_0_entry)
{
SPEC_N_ITBL(RBH_Save_1_info,RBH_Save_1_entry,UpdErr,0,INFO_OTHER_TAG,2,1,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_1");
SPEC_N_ITBL(RBH_Save_2_info,RBH_Save_2_entry,UpdErr,0,INFO_OTHER_TAG,2,2,,IF_,INTERNAL_KIND,"RBH-SAVE","RBH_Save_2");
-#endif /* PAR */
+#endif /* PAR || GRAN */
\end{code}
};
\end{code}
-\begin{code}
-#ifdef GRAN
-
-STGFUN(Event_Queue_entry) {
- FB_
- /* Don't wrap the calls; we're done with STG land */
- fflush(stdout);
- fprintf(stderr, "Entered from an event queue!\n");
- abort();
- JMP_(0);
- FE_
-}
-
-GEN_N_ITBL(Event_Queue_info,Event_Queue_entry,UpdErr,0,INFO_OTHER_TAG,5,2,const,EF_,INTERNAL_KIND,"EventQ","EventQ");
-
-#endif /* GRAN */
-\end{code}
-
-
-
%/****************************************************************
%* *
%* Some GC info tables *
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
fprintf(stderr,"Entered Forward_Ref_New %lx: Should never occur!\n", (W_) Node);
- abort();
+ EXIT(EXIT_FAILURE); /* abort(); */
FE_
}
FORWARDREF_ITBL(Forward_Ref_New_info,Forward_Ref_New_entry,const/*not static*/,_Evacuate_Old_Forward_Ref);
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
fprintf(stderr,"Entered Forward_Ref_Old %lx: Should never occur!\n", (W_) Node);
- abort();
+ EXIT(EXIT_FAILURE); /* abort(); */
FE_
}
FORWARDREF_ITBL(Forward_Ref_Old_info,Forward_Ref_Old_entry,const/*not static*/,_Evacuate_New_Forward_Ref);
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
fprintf(stderr,"Entered OldRoot_Forward_Ref %lx: Should never occur!\n", (W_) Node);
- abort();
+ EXIT(EXIT_FAILURE); /* abort(); */
FE_
}
FORWARDREF_ITBL(OldRoot_Forward_Ref_info,OldRoot_Forward_Ref_entry,const/*not static*/,_Evacuate_OldRoot_Forward);
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
fprintf(stderr,"Entered Forward_Ref %lx: Should never occur!\n", (W_) Node);
- abort();
+ EXIT(EXIT_FAILURE); /* abort(); */
FE_
}
FORWARDREF_ITBL(Forward_Ref_info,Forward_Ref_entry,const/*not static*/,_Evacuate_Forward_Ref);
FB_
#if defined(GRAN)
- STGCALL0(void,(),GranSimBlock); /* Before overwriting TSO_LINK */
+ /* Before overwriting TSO_LINK */
+ STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);
#endif
TSO_LINK(CurrentTSO) = (P_) BQ_ENTRIES(Node);
}
#endif
#if defined(GRAN)
- ReSchedule(NEW_THREAD);
+ ReSchedule(SAME_THREAD); /* NB: GranSimBlock activated next thread */
#else
ReSchedule(0);
#endif
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
STGFUN(RBH_entry)
{
FB_
-#if defined(GRAN)
- STGCALL0(void, (), GranSimBlock); /* Before overwriting TSO_LINK */
-#endif
+# if defined(GRAN)
+ /* Before overwriting TSO_LINK */
+ STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);
+# endif
switch (INFO_TYPE(InfoPtr)) {
case INFO_SPEC_RBH_TYPE:
QP_Event1("GR", CurrentTSO);
}
+# ifdef PAR
if(RTSflags.ParFlags.granSimStats) {
/* Note that CURRENT_TIME may perform an unsafe call */
TIME now = CURRENT_TIME;
TSO_BLOCKEDAT(CurrentTSO) = now;
DumpGranEvent(GR_BLOCK, CurrentTSO);
}
-
-#if defined(GRAN)
- ReSchedule(NEW_THREAD);
-#else
+# endif
+# if defined(GRAN)
+ ReSchedule(SAME_THREAD); /* NB: GranSimBlock activated next thread */
+# else
ReSchedule(0);
-#endif
+# endif
FE_
}
FB_
ENT_VIA_NODE();
InfoPtr=(D_)(INFO_PTR(Node));
- GRAN_EXEC(5,1,2,0,0);
JMP_(ENTRY_CODE(InfoPtr));
FE_
}
FB_
RetReg = (StgRetAddr) SpB[BREL(0)];
cont = (void *) SpB[BREL(1)];
- SpB += BREL(2);
-/* GRAN_EXEC(1,1,2,0,0); /? ToDo: RE-CHECK (WDP) */
+ /* SpB += BREL(2); */
JMP_(cont);
FE_
}
This code is required by the update interface which sits on top of the
storage manager interface (See \tr{SMupdate.lh}).
-Some of this stuff has been separated (correctly!) into StgThreads.lhc
-for version 0.23. Could someone (Hans?) bring us up to date, please!
-KH.
-
\begin{itemize}
\item Indirection entry code and info table.
\item Black Hole entry code and info table.
#endif
#endif
-EXTDATA(Nil_closure);
+EXTDATA(Prelude_Z91Z93_closure);
#if defined(TICKY_TICKY)
void PrintTickyInfo(STG_NO_ARGS);
FB_
# if 0
- if ( debug & 0x80 )
+ if ( RTSflags.GranFlags.debug & 0x80 )
(void) STGCALL4(int,(),fprintf,stderr,"GRAN_CHECK in BH_UPD_entry: Entered a `black hole' @ 0x%x (CurrentTSO @ 0x%x\n ",Node,CurrentTSO);
-#endif
+# endif
# if defined(GRAN)
- STGCALL0(void,(),GranSimBlock); /* Do this before losing its TSO_LINK */
+ /* Do this before losing its TSO_LINK */
+ STGCALL3(void,(),GranSimBlock,CurrentTSO,CurrentProc,Node);
# endif
- TSO_LINK(CurrentTSO) = Nil_closure;
+ TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
SET_INFO_PTR(Node, BQ_info);
BQ_ENTRIES(Node) = (W_) CurrentTSO;
# endif
# if defined(GRAN)
- /* CurrentTSO = Nil_closure; */
- ReSchedule(NEW_THREAD);
+ /* CurrentTSO = Prelude_Z91Z93_closure; */
+ ReSchedule(SAME_THREAD);
# else
ReSchedule(0);
# endif
InfoPtr=(D_)(INFO_PTR(Node));
-# if defined(GRAN)
- GRAN_EXEC(1,1,2,0,0);
-# endif
JMP_(ENTRY_CODE(InfoPtr));
FE_
}
FB_
-#if defined(COUNT)
+#if defined(GRAN_COUNT)
++nPAPs;
#endif
* Don't count this entry for ticky-ticky profiling.
*/
-#if defined(GRAN)
+#if 0 /* defined(GRAN) */
GRAN_EXEC(16,4,7,4,0);
#endif
InfoPtr=(D_)(INFO_PTR(Node));
\begin{code}
-#if defined(CONCURRENT)
+#if defined(CONCURRENT) /* the whole module! */
# define NON_POSIX_SOURCE /* so says Solaris */
@RTSflags.ConcFlags.stkChunkSize@ words.
\begin{code}
-P_ AvailableStack = Nil_closure;
-P_ AvailableTSO = Nil_closure;
+P_ AvailableStack = Prelude_Z91Z93_closure;
+P_ AvailableTSO = Prelude_Z91Z93_closure;
\end{code}
Macros for dealing with the new and improved GA field for simulating
parallel execution. Based on @CONCURRENT@ package. The GA field now
contains a mask, where the n-th bit stands for the n-th processor,
-where this data can be found. In case of multiple copies, several bits
+on which this data can be found. In case of multiple copies, several bits
are set. The total number of processors is bounded by @MAX_PROC@,
which should be <= the length of a word in bits. -- HWL
-\begin{code}
-/* mattson thinks this is obsolete */
-
-# if 0 && defined(GRAN)
-
-typedef unsigned long TIME;
-typedef unsigned char PROC;
-typedef unsigned char EVTTYPE;
-
-
-# undef max
-# define max(a,b) (a>b?a:b)
-
-static PROC
-ga_to_proc(W_ ga)
-{ PROC i;
-
- for (i=0; i<MAX_PROC && !IS_LOCAL_TO(ga,i); i++) ;
-
- return (i);
-}
-
-/* NB: This takes a *node* rather than just a ga as input */
-static PROC
-where_is(P_ node)
-{ return (ga_to_proc(PROCS(node))); } /* Access the GA field of the node */
-
-static PROC
-no_of_copies(P_ node) /* DaH lo'lu'Qo'; currently unused */
-{ PROC i, n;
-
- for (i=0, n=0; i<MAX_PROC; i++)
- if (IS_LOCAL_TO(PROCS(node),i))
- n++;;
-
- return (n);
-}
-
-# endif /* GRAN ; HWL */
-\end{code}
+{{GranSim.lc}Daq ngoq' roQlu'ta'}
+(Code has been moved to GranSim.lc).
%****************************************************************
%* *
This is the heart of the thread scheduling code.
-\begin{code}
-# if defined(GRAN_CHECK) && defined(GRAN)
-W_ debug = 0;
-# endif
+Most of the changes for GranSim are in this part of the RTS.
+Especially the @ReSchedule@ routine has been blown up quite a lot
+It now contains the top-level event-handling loop.
-W_ event_trace = 0;
-W_ event_trace_all = 0;
+Parts of the code that are not necessary for GranSim, but convenient to
+have when developing it are marked with a @GRAN_CHECK@ variable.
+\begin{code}
STGRegisterTable *CurrentRegTable = NULL;
P_ CurrentTSO = NULL;
-# if defined(GRAN) /* HWL */
-
-unsigned CurrentProc = 0;
-W_ IdleProcs = ~0L, Idlers = MAX_PROC;
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
-# define FETCH_MASK_TSO 0x08000000 /* only bits 0, 1, 2 should be used */
- /* normally */
-# endif
-
-I_ DoFairSchedule = 0;
-I_ DoReScheduleOnFetch = 0;
-I_ DoStealThreadsFirst = 0;
-I_ SimplifiedFetch = 0;
-I_ DoAlwaysCreateThreads = 0;
-I_ DoGUMMFetching = 0;
-I_ DoThreadMigration = 0;
-I_ FetchStrategy = 4;
-I_ PreferSparksOfLocalNodes = 0;
-
-# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
-I_ NoForward = 0;
-I_ PrintFetchMisses = 0, fetch_misses = 0;
-# endif
-
-# if defined(COUNT)
-I_ nUPDs = 0, nUPDs_old = 0, nUPDs_new = 0, nUPDs_BQ = 0, nPAPs = 0,
- BQ_lens = 0;
-# endif
+#if defined(GRAN)
-I_ no_gr_profile = 0; /* Don't create any .gr file at all? */
-I_ do_sp_profile = 0;
-I_ do_gr_migration = 0;
+/* Only needed for GranSim Light; costs of operations during rescheduling
+ are associated to the virtual processor on which ActiveTSO is living */
+P_ ActiveTSO = NULL;
+rtsBool __resched = rtsFalse; /* debugging only !!*/
+/* Pointers to the head and tail of the runnable queues for each PE */
+/* In GranSim Light only the thread/spark-queues of proc 0 are used */
P_ RunnableThreadsHd[MAX_PROC];
P_ RunnableThreadsTl[MAX_PROC];
sparkq PendingSparksHd[MAX_PROC][SPARK_POOLS];
sparkq PendingSparksTl[MAX_PROC][SPARK_POOLS];
-W_ CurrentTime[MAX_PROC]; /* Per PE clock */
+/* One clock for each PE */
+W_ CurrentTime[MAX_PROC];
-# if defined(GRAN_CHECK) && defined(GRAN)
-P_ BlockedOnFetch[MAX_PROC]; /* HWL-CHECK */
-# endif
+/* Useful to restrict communication; cf fishing model in GUM */
+I_ OutstandingFetches[MAX_PROC], OutstandingFishes[MAX_PROC];
+
+/* Status of each PE (new since but independent of GranSim Light) */
+enum proc_status procStatus[MAX_PROC];
-I_ OutstandingFetches[MAX_PROC];
+#if defined(GRAN) && defined(GRAN_CHECK)
+/* To check if the RTS ever tries to run a thread that should be blocked
+ because of fetching remote data */
+P_ BlockedOnFetch[MAX_PROC];
+#endif
W_ SparksAvail = 0; /* How many sparks are available */
W_ SurplusThreads = 0; /* How many excess threads are there */
-StgBool NeedToReSchedule = StgFalse; /* Do we need to reschedule following a fetch? */
-
-/* Communication Cost Variables -- set in main program */
-
-W_ gran_latency = LATENCY, gran_additional_latency = ADDITIONAL_LATENCY,
- gran_fetchtime = FETCHTIME,
- gran_lunblocktime = LOCALUNBLOCKTIME, gran_gunblocktime = GLOBALUNBLOCKTIME,
- gran_mpacktime = MSGPACKTIME, gran_munpacktime = MSGUNPACKTIME,
- gran_mtidytime = 0;
-
-W_ gran_threadcreatetime = THREADCREATETIME,
- gran_threadqueuetime = THREADQUEUETIME,
- gran_threaddescheduletime = THREADDESCHEDULETIME,
- gran_threadscheduletime = THREADSCHEDULETIME,
- gran_threadcontextswitchtime = THREADCONTEXTSWITCHTIME;
-
-/* Instruction Cost Variables -- set in main program */
-
-W_ gran_arith_cost = ARITH_COST, gran_branch_cost = BRANCH_COST,
- gran_load_cost = LOAD_COST, gran_store_cost = STORE_COST,
- gran_float_cost = FLOAT_COST, gran_heapalloc_cost = 0;
-
-W_ max_proc = MAX_PROC;
-
-/* Granularity event types' names for output */
-
-char *event_names[] =
- { "STARTTHREAD", "CONTINUETHREAD", "RESUMETHREAD",
- "MOVESPARK", "MOVETHREAD", "FINDWORK",
- "FETCHNODE", "FETCHREPLY"
- };
-
-# if defined(GRAN)
-/* Prototypes of GrAnSim debugging functions */
-void DEBUG_PRINT_NODE PROTO((P_));
-void DEBUG_TREE PROTO((P_));
-void DEBUG_INFO_TABLE PROTO((P_));
-void DEBUG_CURR_THREADQ PROTO((I_));
-void DEBUG_THREADQ PROTO((P_, I_));
-void DEBUG_TSO PROTO((P_, I_));
-void DEBUG_EVENT PROTO((eventq, I_));
-void DEBUG_SPARK PROTO((sparkq, I_));
-void DEBUG_SPARKQ PROTO((sparkq, I_));
-void DEBUG_CURR_SPARKQ PROTO((I_));
-void DEBUG_PROC PROTO((I_, I_));
-void DCT(STG_NO_ARGS);
-void DCP(STG_NO_ARGS);
-void DEQ(STG_NO_ARGS);
-void DSQ(STG_NO_ARGS);
-
-void HandleFetchRequest PROTO((P_, PROC, P_));
-# endif /* GRAN ; HWL */
-
-#if defined(GRAN_CHECK) && defined(GRAN)
-static eventq DelayedEventHd = NULL, DelayedEventTl = NULL;
-
-static I_ noOfEvents = 0;
-static I_ event_counts[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
-#endif
-
TIME SparkStealTime();
-/* Fcts for manipulating event queues have been deleted -- HWL */
-/* ---------------------------------- */
-
-static void
-print_spark(spark)
- sparkq spark;
-{
-
- if (spark==NULL)
- fprintf(stderr,"Spark: NIL\n");
- else
- fprintf(stderr,"Spark: Node 0x%lx, Name 0x%lx, Exported %s, Prev 0x%x, Next 0x%x\n",
- (W_) SPARK_NODE(spark), SPARK_NAME(spark),
- ((SPARK_EXPORTED(spark))?"True":"False"),
- SPARK_PREV(spark), SPARK_NEXT(spark) );
-}
-
-static print_sparkq(hd)
-sparkq hd;
-{
- sparkq x;
-
- fprintf(stderr,"Spark Queue with root at %x:\n",hd);
- for (x=hd; x!=NULL; x=SPARK_NEXT(x)) {
- print_spark(x);
- }
-}
-
-static print_event(event)
-eventq event;
-{
-
- if (event==NULL)
- fprintf(stderr,"Evt: NIL\n");
- else
- fprintf(stderr,"Evt: %s (%u), PE %u [%u], Time %lu, TSO 0x%lx, node 0x%lx\n",
- event_names[EVENT_TYPE(event)],EVENT_TYPE(event),
- EVENT_PROC(event), EVENT_CREATOR(event),
- EVENT_TIME(event), EVENT_TSO(event), EVENT_NODE(event) /*,
- EVENT_SPARK(event), EVENT_NEXT(event)*/ );
-
-}
-
-static print_eventq(hd)
-eventq hd;
-{
- eventq x;
-
- fprintf(stderr,"Event Queue with root at %x:\n",hd);
- for (x=hd; x!=NULL; x=EVENT_NEXT(x)) {
- print_event(x);
- }
-}
-
-/* ---------------------------------- */
-
-#if 0 /* moved */
-static eventq getnextevent()
-{
- static eventq entry = NULL;
-
- if(EventHd == NULL)
- {
- fprintf(stderr,"No next event\n");
- exit(EXIT_FAILURE); /* ToDo: abort()? EXIT? */
- }
-
- if(entry != NULL)
- free((char *)entry);
-
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (debug & 0x20) { /* count events */
- noOfEvents++;
- event_counts[EVENT_TYPE(EventHd)]++;
- }
-#endif
-
- entry = EventHd;
- EventHd = EVENT_NEXT(EventHd);
- return(entry);
-}
-
-/* ToDo: replace malloc/free with a free list */
-
-static insert_event(newentry)
-eventq newentry;
-{
- EVTTYPE evttype = EVENT_TYPE(newentry);
- eventq event, *prev;
-
- /* Search the queue and insert at the right point:
- FINDWORK before everything, CONTINUETHREAD after everything.
-
- This ensures that we find any available work after all threads have
- executed the current cycle. This level of detail would normally be
- irrelevant, but matters for ridiculously low latencies...
- */
-
- if(EventHd == NULL)
- EventHd = newentry;
- else
- {
- for (event = EventHd, prev=&EventHd; event != NULL;
- prev = &(EVENT_NEXT(event)), event = EVENT_NEXT(event))
- {
- if(evttype == FINDWORK ? (EVENT_TIME(event) >= EVENT_TIME(newentry)) :
- evttype == CONTINUETHREAD ? (EVENT_TIME(event) > EVENT_TIME(newentry)) :
- (EVENT_TIME(event) > EVENT_TIME(newentry) ||
- (EVENT_TIME(event) == EVENT_TIME(newentry) &&
- EVENT_TYPE(event) != FINDWORK )))
- {
- *prev = newentry;
- EVENT_NEXT(newentry) = event;
- break;
- }
- }
- if (event == NULL)
- *prev = newentry;
- }
-}
-
-static newevent(proc,creator,time,evttype,tso,node,spark)
-PROC proc, creator;
-TIME time;
-EVTTYPE evttype;
-P_ tso, node;
-sparkq spark;
-{
- eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "newevent");
-
- EVENT_PROC(newentry) = proc;
- EVENT_CREATOR(newentry) = creator;
- EVENT_TIME(newentry) = time;
- EVENT_TYPE(newentry) = evttype;
- EVENT_TSO(newentry) = tso;
- EVENT_NODE(newentry) = node;
- EVENT_SPARK(newentry) = spark;
- EVENT_NEXT(newentry) = NULL;
-
- insert_event(newentry);
-}
-#endif /* 0 moved */
-
# else /* !GRAN */
-P_ RunnableThreadsHd = Nil_closure;
-P_ RunnableThreadsTl = Nil_closure;
+P_ RunnableThreadsHd = Prelude_Z91Z93_closure;
+P_ RunnableThreadsTl = Prelude_Z91Z93_closure;
-P_ WaitingThreadsHd = Nil_closure;
-P_ WaitingThreadsTl = Nil_closure;
+P_ WaitingThreadsHd = Prelude_Z91Z93_closure;
+P_ WaitingThreadsTl = Prelude_Z91Z93_closure;
-PP_ PendingSparksBase[SPARK_POOLS];
-PP_ PendingSparksLim[SPARK_POOLS];
+TYPE_OF_SPARK PendingSparksBase[SPARK_POOLS];
+TYPE_OF_SPARK PendingSparksLim[SPARK_POOLS];
-PP_ PendingSparksHd[SPARK_POOLS];
-PP_ PendingSparksTl[SPARK_POOLS];
+TYPE_OF_SPARK PendingSparksHd[SPARK_POOLS];
+TYPE_OF_SPARK PendingSparksTl[SPARK_POOLS];
-# endif /* GRAN ; HWL */
+#endif /* GRAN ; HWL */
static jmp_buf scheduler_loop;
EXTFUN(resumeThread);
+/* Misc prototypes */
+#if defined(GRAN)
+P_ NewThread PROTO((P_, W_, I_));
+I_ blockFetch PROTO((P_, PROC, P_));
+I_ HandleFetchRequest PROTO((P_, PROC, P_));
+rtsBool InsertThread PROTO((P_ tso));
+sparkq delete_from_spark_queue PROTO((sparkq, sparkq));
+sparkq prev, spark;
+#else
P_ NewThread PROTO((P_, W_));
+#endif
I_ context_switch = 0;
+I_ contextSwitchTime = 10000;
+
+I_ threadId = 0;
+/* NB: GRAN and GUM use different representations of spark pools.
+ GRAN sparks are more flexible (containing e.g. granularity info)
+ but slower than GUM sparks. There is no fixed upper bound on the
+ number of GRAN sparks either. -- HWL
+*/
#if !defined(GRAN)
-I_ threadId = 0;
I_ sparksIgnored =0;
I_ SparkLimit[SPARK_POOLS];
rtsBool
initThreadPools(STG_NO_ARGS)
{
- I_ size = RTSflags.ConcFlags.maxLocalSparks;
+ I_ i, size = RTSflags.ConcFlags.maxLocalSparks;
SparkLimit[ADVISORY_POOL] = SparkLimit[REQUIRED_POOL] = size;
- if ((PendingSparksBase[ADVISORY_POOL] = (PP_) malloc(size * sizeof(P_))) == NULL)
+ if ((PendingSparksBase[ADVISORY_POOL] = (TYPE_OF_SPARK) malloc(size * SIZE_OF_SPARK)) == NULL)
return rtsFalse;
- if ((PendingSparksBase[REQUIRED_POOL] = (PP_) malloc(size * sizeof(P_))) == NULL)
+ if ((PendingSparksBase[REQUIRED_POOL] = (TYPE_OF_SPARK) malloc(size * SIZE_OF_SPARK)) == NULL)
return rtsFalse;
-
PendingSparksLim[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL] + size;
PendingSparksLim[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL] + size;
return rtsTrue;
+
}
-#endif
+#endif /* !GRAN */
#ifdef PAR
rtsBool sameThread;
} else
context_switch = 0 /* 1 HWL */;
-#if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
- if ( debug & 0x40 ) {
- fprintf(stderr,"D> Doing init in ScheduleThreads now ...\n");
+# if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
+ if ( RTSflags.GranFlags.Light && RTSflags.GranFlags.proc!=1 ) {
+ fprintf(stderr,"Qagh: In GrAnSim Light setup .proc must be 1\n");
+ EXIT(EXIT_FAILURE);
}
-#endif
-#if defined(GRAN) /* KH */
- for (i=0; i<max_proc; i++)
- {
- RunnableThreadsHd[i] = RunnableThreadsTl[i] = Nil_closure;
- WaitThreadsHd[i] = WaitThreadsTl[i] = Nil_closure;
- PendingSparksHd[i][REQUIRED_POOL] = PendingSparksHd[i][ADVISORY_POOL] =
- PendingSparksTl[i][REQUIRED_POOL] = PendingSparksTl[i][ADVISORY_POOL] =
- NULL;
+ if ( RTSflags.GranFlags.debug & 0x40 ) {
+ fprintf(stderr,"Doing init in ScheduleThreads now ...\n");
+ }
+# endif
-# if defined(GRAN_CHECK)
- if (debug & 0x04)
- BlockedOnFetch[i] = 0; /*- StgFalse; -*/ /* HWL-CHECK */
+#if defined(GRAN) /* KH */
+ /* Init thread and spark queues on all processors */
+ for (i=0; i<RTSflags.GranFlags.proc; i++)
+ {
+ /* Init of RunnableThreads{Hd,Tl} etc now in main */
+ OutstandingFetches[i] = OutstandingFishes[i] = 0;
+ procStatus[i] = Idle;
+# if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
+ BlockedOnFetch[i] = NULL;
# endif
- OutstandingFetches[i] = 0;
}
CurrentProc = MainProc;
+#if 0
+ Idlers = RTSflags.GranFlags.proc;
+ IdleProcs = ~0l;
+#endif
#endif /* GRAN */
if (DO_QP_PROF)
init_qp_profiling();
-
/*
* We perform GC so that a signal handler can install a new
* TopClosure and start a new main thread.
#ifdef PAR
if (IAmMainThread) {
#endif
+#if defined(GRAN)
+ if ((tso = NewThread(topClosure, T_MAIN, MAIN_PRI)) == NULL) {
+#else
if ((tso = NewThread(topClosure, T_MAIN)) == NULL) {
+#endif
/* kludge to save the top closure as a root */
CurrentTSO = topClosure;
ReallyPerformThreadGC(0, rtsTrue);
topClosure = CurrentTSO;
+#if defined(GRAN)
+ if ((tso = NewThread(topClosure, T_MAIN, MAIN_PRI)) == NULL) {
+#else
if ((tso = NewThread(topClosure, T_MAIN)) == NULL) {
+#endif
fflush(stdout);
fprintf(stderr, "Not enough heap for main thread\n");
EXIT(EXIT_FAILURE);
}
}
-#ifndef GRAN
+#if !defined(GRAN)
RunnableThreadsHd = RunnableThreadsTl = tso;
#else
/* NB: CurrentProc must have been set to MainProc before that! -- HWL */
ThreadQueueHd = ThreadQueueTl = tso;
# if defined(GRAN_CHECK)
- if ( debug & 0x40 ) {
- fprintf(stderr,"D> MainTSO has been initialized (0x%x)\n", tso);
+ if ( RTSflags.GranFlags.debug & 0x40 ) {
+ fprintf(stderr,"MainTSO has been initialized (0x%x)\n", tso);
}
# endif
-#endif
+#endif /* GRAN */
#ifdef PAR
if (RTSflags.ParFlags.granSimStats) {
DumpGranEvent(GR_START, tso);
sameThread = rtsTrue;
}
+#elif defined(GRAN)
+ if (RTSflags.GranFlags.granSimStats && !RTSflags.GranFlags.labelling)
+ DumpRawGranEvent(CurrentProc,(PROC)0,GR_START,
+ tso,topClosure,0);
#endif
#if defined(GRAN)
MAKE_BUSY(MainProc); /* Everything except the main PE is idle */
+ if (RTSflags.GranFlags.Light)
+ ActiveTSO = tso;
#endif
required_thread_count = 1;
return;
#if defined(GRAN) && defined(GRAN_CHECK)
- if ( debug & 0x80 ) {
- fprintf(stderr,"D> MAIN Schedule Loop; ThreadQueueHd is ");
- DEBUG_TSO(ThreadQueueHd,1);
+ if ( RTSflags.GranFlags.debug & 0x80 ) {
+ fprintf(stderr,"MAIN Schedule Loop; ThreadQueueHd is ");
+ G_TSO(ThreadQueueHd,1);
/* if (ThreadQueueHd == MainTSO) {
fprintf(stderr,"D> Event Queue is now:\n");
- DEQ();
+ GEQ();
} */
}
#endif
#ifdef PAR
- if (PendingFetches != Nil_closure) {
+ if (PendingFetches != Prelude_Z91Z93_closure) {
processFetches();
}
#elif defined(GRAN)
- if (ThreadQueueHd == Nil_closure) {
- fprintf(stderr, "No runnable threads!\n");
+ if (ThreadQueueHd == Prelude_Z91Z93_closure) {
+ fprintf(stderr, "Qu'vatlh! No runnable threads!\n");
EXIT(EXIT_FAILURE);
}
if (DO_QP_PROF > 1 && CurrentTSO != ThreadQueueHd) {
QP_Event1("AG", ThreadQueueHd);
}
-#endif
-
-#ifndef PAR
- while (RunnableThreadsHd == Nil_closure) {
+#else
+ while (RunnableThreadsHd == Prelude_Z91Z93_closure) {
/* If we've no work */
- if (WaitingThreadsHd == Nil_closure) {
+ if (WaitingThreadsHd == Prelude_Z91Z93_closure) {
fflush(stdout);
fprintf(stderr, "No runnable threads!\n");
EXIT(EXIT_FAILURE);
}
- AwaitEvent(RTSflags.ConcFlags.ctxtSwitchTime);
+ /* Block indef. waiting for I/O and timer expire */
+ AwaitEvent(0);
}
-#else
- if (RunnableThreadsHd == Nil_closure) {
+#endif
+
+#ifdef PAR
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
if (advisory_thread_count < RTSflags.ConcFlags.maxThreads &&
(PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL] ||
PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL])) {
}
#endif /* PAR */
+#if !defined(GRAN)
if (DO_QP_PROF > 1 && CurrentTSO != RunnableThreadsHd) {
- QP_Event1("AG", RunnableThreadsHd);
- }
+ QP_Event1("AG", RunnableThreadsHd);
+}
+#endif
#ifdef PAR
if (RTSflags.ParFlags.granSimStats && !sameThread)
DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
#endif
-#if !GRAN /* ROUND_ROBIN */
+#if defined(GRAN)
+ TimeOfNextEvent = get_time_of_next_event();
+ CurrentTSO = ThreadQueueHd;
+ if (RTSflags.GranFlags.Light) {
+ /* Save time of `virt. proc' which was active since last getevent and
+ restore time of `virt. proc' where CurrentTSO is living on. */
+ if(RTSflags.GranFlags.DoFairSchedule)
+ {
+ if (RTSflags.GranFlags.granSimStats &&
+ RTSflags.GranFlags.debug & 0x20000)
+ DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
+ }
+ TSO_CLOCK(ActiveTSO) = CurrentTime[CurrentProc];
+ ActiveTSO = NULL;
+ CurrentTime[CurrentProc] = TSO_CLOCK(CurrentTSO);
+ if(RTSflags.GranFlags.DoFairSchedule && __resched )
+ {
+ __resched = rtsFalse;
+ if (RTSflags.GranFlags.granSimStats &&
+ RTSflags.GranFlags.debug & 0x20000)
+ DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
+ }
+ /*
+ if (TSO_LINK(ThreadQueueHd)!=Prelude_Z91Z93_closure &&
+ (TimeOfNextEvent == 0 ||
+ TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000<TimeOfNextEvent)) {
+ new_event(CurrentProc,CurrentProc,TSO_CLOCK(TSO_LINK(ThreadQueueHd))+1000,
+ CONTINUETHREAD,TSO_LINK(ThreadQueueHd),Prelude_Z91Z93_closure,NULL);
+ TimeOfNextEvent = get_time_of_next_event();
+ }
+ */
+ }
+ EndOfTimeSlice = CurrentTime[CurrentProc]+RTSflags.GranFlags.time_slice;
+#else /* !GRAN */
CurrentTSO = RunnableThreadsHd;
RunnableThreadsHd = TSO_LINK(RunnableThreadsHd);
- TSO_LINK(CurrentTSO) = Nil_closure;
+ TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
- if (RunnableThreadsHd == Nil_closure)
- RunnableThreadsTl = Nil_closure;
-
-#else /* GRAN */
- /* This used to be Round Robin. KH.
- I think we can ignore that, and move it down to ReSchedule instead.
- */
- CurrentTSO = ThreadQueueHd;
- /* TSO_LINK(CurrentTSO) = Nil_closure; humbug */
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure)
+ RunnableThreadsTl = Prelude_Z91Z93_closure;
#endif
/* If we're not running a timer, just leave the flag on */
context_switch = 0;
#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (CurrentTSO == Nil_closure) {
- fprintf(stderr,"Error: Trying to execute Nil_closure on proc %d (@ %d)\n",
+ if (CurrentTSO == Prelude_Z91Z93_closure) {
+ fprintf(stderr,"Qagh: Trying to execute Prelude_Z91Z93_closure on proc %d (@ %d)\n",
CurrentProc,CurrentTime[CurrentProc]);
- exit(99);
+ EXIT(EXIT_FAILURE);
}
- if (debug & 0x04) {
+ if (RTSflags.GranFlags.debug & 0x04) {
if (BlockedOnFetch[CurrentProc]) {
- fprintf(stderr,"Error: Trying to execute TSO 0x%x on proc %d (@ %d) which is blocked-on-fetch by TSO 0x%x\n",
+ fprintf(stderr,"Qagh: Trying to execute TSO 0x%x on proc %d (@ %d) which is blocked-on-fetch by TSO 0x%x\n",
CurrentTSO,CurrentProc,CurrentTime[CurrentProc],BlockedOnFetch[CurrentProc]);
- exit(99);
+ EXIT(EXIT_FAILURE);
}
}
- if ( (debug & 0x10) &&
+ if ( (RTSflags.GranFlags.debug & 0x10) &&
(TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) ) {
- fprintf(stderr,"Error: Trying to execute TSO 0x%x on proc %d (@ %d) which should be asleep!\n",
+ fprintf(stderr,"Qagh: Trying to execute TSO 0x%x on proc %d (@ %d) which should be asleep!\n",
CurrentTSO,CurrentProc,CurrentTime[CurrentProc]);
- exit(99);
+ EXIT(EXIT_FAILURE);
}
#endif
+#if 0 && defined(CONCURRENT)
+ fprintf(stderr, "ScheduleThreads: About to resume thread:%#x\n",
+ CurrentTSO);
+#endif
miniInterpret((StgFunPtr)resumeThread);
}
\end{code}
% Some remarks on GrAnSim -- HWL
-The ReSchedule fct is the heart of GrAnSim. Based on its par it issues a
-CONTINUETRHEAD to carry on executing the current thread in due course or it
-watches out for new work (e.g. called from EndThread).
+The ReSchedule fct is the heart of GrAnSim. Based on its parameter it issues
+a CONTINUETRHEAD to carry on executing the current thread in due course or it watches out for new work (e.g. called from EndThread).
-Then it picks the next event (getnextevent) and handles it appropriately
+Then it picks the next event (get_next_event) and handles it appropriately
(see switch construct). Note that a continue in the switch causes the next
event to be handled and a break causes a jmp to the scheduler_loop where
the TSO at the head of the current processor's runnable queue is executed.
itself called via the GRAN_RESCHEDULE macro in the compiler generated code.
\begin{code}
+/*
+ GrAnSim rules here! Others stay out or you will be crashed.
+ Concurrent and parallel guys: please use the next door (a few pages down;
+ turn left at the !GRAN sign).
+*/
+
#if defined(GRAN)
+/* Prototypes of event handling functions. Only needed in ReSchedule */
+void do_the_globalblock PROTO((eventq event));
+void do_the_unblock PROTO((eventq event));
+void do_the_fetchnode PROTO((eventq event));
+void do_the_fetchreply PROTO((eventq event));
+void do_the_movethread PROTO((eventq event));
+void do_the_movespark PROTO((eventq event));
+void gimme_spark PROTO((rtsBool *found_res, sparkq *prev_res, sparkq *spark_res));
+void munch_spark PROTO((rtsBool found, sparkq prev, sparkq spark));
+
void
ReSchedule(what_next)
int what_next; /* Run the current thread again? */
{
sparkq spark, nextspark;
P_ tso;
- P_ node;
+ P_ node, closure;
eventq event;
+ int rc;
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x80 ) {
- fprintf(stderr,"D> Entering ReSchedule with mode %u; tso is\n",what_next);
- DEBUG_TSO(ThreadQueueHd,1);
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x80 ) {
+ fprintf(stderr,"Entering ReSchedule with mode %u; tso is\n",what_next);
+ G_TSO(ThreadQueueHd,1);
}
-#endif
+# endif
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( (debug & 0x80) || (debug & 0x40 ) )
- if (what_next<FIND_THREAD || what_next>CHANGE_THREAD)
- fprintf(stderr,"ReSchedule: illegal parameter %u for what_next\n",
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( (RTSflags.GranFlags.debug & 0x80) || (RTSflags.GranFlags.debug & 0x40 ) )
+ if (what_next<FIND_THREAD || what_next>END_OF_WORLD)
+ fprintf(stderr,"Qagh {ReSchedule}Daq: illegal parameter %u for what_next\n",
what_next);
-#endif
+# endif
+
+ if (RTSflags.GranFlags.Light) {
+ /* Save current time; GranSim Light only */
+ TSO_CLOCK(CurrentTSO) = CurrentTime[CurrentProc];
+ }
/* Run the current thread again (if there is one) */
- if(what_next==SAME_THREAD && ThreadQueueHd != Nil_closure)
+ if(what_next==SAME_THREAD && ThreadQueueHd != Prelude_Z91Z93_closure)
{
/* A bit of a hassle if the event queue is empty, but ... */
CurrentTSO = ThreadQueueHd;
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,CurrentTSO,Nil_closure,NULL);
+ __resched = rtsFalse;
+ if (RTSflags.GranFlags.Light &&
+ TSO_LINK(ThreadQueueHd)!=Prelude_Z91Z93_closure &&
+ TSO_CLOCK(ThreadQueueHd)>TSO_CLOCK(TSO_LINK(ThreadQueueHd))) {
+ if(RTSflags.GranFlags.granSimStats &&
+ RTSflags.GranFlags.debug & 0x20000 )
+ DumpGranEvent(GR_DESCHEDULE,ThreadQueueHd);
+ __resched = rtsTrue;
+ ThreadQueueHd = TSO_LINK(CurrentTSO);
+ if (ThreadQueueHd==Prelude_Z91Z93_closure)
+ ThreadQueueTl=Prelude_Z91Z93_closure;
+ TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
+ InsertThread(CurrentTSO);
+ }
/* This code does round-Robin, if preferred. */
- if(DoFairSchedule && TSO_LINK(CurrentTSO) != Nil_closure)
+ if(!RTSflags.GranFlags.Light &&
+ RTSflags.GranFlags.DoFairSchedule &&
+ TSO_LINK(CurrentTSO) != Prelude_Z91Z93_closure &&
+ CurrentTime[CurrentProc]>=EndOfTimeSlice)
{
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEvent(GR_DESCHEDULE,ThreadQueueHd);
ThreadQueueHd = TSO_LINK(CurrentTSO);
TSO_LINK(ThreadQueueTl) = CurrentTSO;
ThreadQueueTl = CurrentTSO;
- TSO_LINK(CurrentTSO) = Nil_closure;
- if (RTSflags.ParFlags.granSimStats)
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
- CurrentTime[CurrentProc] += gran_threadcontextswitchtime;
+ TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
+ if ( RTSflags.GranFlags.granSimStats )
+ DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
+ CurrentTSO = ThreadQueueHd;
}
+
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,CurrentTSO,Prelude_Z91Z93_closure,NULL);
}
/* Schedule `next thread' which is at ThreadQueueHd now i.e. thread queue */
/* has been updated before that already. */
- else if(what_next==NEW_THREAD && ThreadQueueHd != Nil_closure)
+ else if(what_next==NEW_THREAD && ThreadQueueHd != Prelude_Z91Z93_closure)
{
-#if defined(GRAN_CHECK) && defined(GRAN)
- if(DoReScheduleOnFetch)
- {
- fprintf(stderr,"ReSchedule(NEW_THREAD) shouldn't be used!!\n");
- exit(99);
- }
-#endif
+# if defined(GRAN_CHECK) && defined(GRAN)
+ fprintf(stderr,"Qagh: ReSchedule(NEW_THREAD) shouldn't be used with DoReScheduleOnFetch!!\n");
+ EXIT(EXIT_FAILURE);
- if(RTSflags.ParFlags.granSimStats)
+# endif
+
+ if(RTSflags.GranFlags.granSimStats &&
+ (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
CurrentTSO = ThreadQueueHd;
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,Nil_closure,Nil_closure,NULL);
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,CurrentTSO,Prelude_Z91Z93_closure,NULL);
- CurrentTime[CurrentProc] += gran_threadcontextswitchtime;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
}
/* We go in here if the current thread is blocked on fetch => don'd CONT */
/* We go in here if we have no runnable threads or what_next==0 */
else
{
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,Nil_closure,Nil_closure,NULL);
- CurrentTSO = Nil_closure;
+ procStatus[CurrentProc] = Idle;
+ /* That's now done in HandleIdlePEs!
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
+ */
+ CurrentTSO = Prelude_Z91Z93_closure;
}
/* ----------------------------------------------------------------- */
do {
/* Choose the processor with the next event */
- event = getnextevent();
+ event = get_next_event();
CurrentProc = EVENT_PROC(event);
- if(EVENT_TIME(event) > CurrentTime[CurrentProc])
- CurrentTime[CurrentProc] = EVENT_TIME(event);
+ CurrentTSO = EVENT_TSO(event);
+ if (RTSflags.GranFlags.Light) {
+ P_ tso;
+ W_ tmp;
+ /* Restore local clock of the virtual processor attached to CurrentTSO.
+ All costs will be associated to the `virt. proc' on which the tso
+ is living. */
+ if (ActiveTSO != NULL) { /* already in system area */
+ TSO_CLOCK(ActiveTSO) = CurrentTime[CurrentProc];
+ if (RTSflags.GranFlags.DoFairSchedule)
+ {
+ if (RTSflags.GranFlags.granSimStats &&
+ RTSflags.GranFlags.debug & 0x20000)
+ DumpGranEvent(GR_SYSTEM_END,ActiveTSO);
+ }
+ }
+ switch (EVENT_TYPE(event))
+ {
+ case CONTINUETHREAD:
+ case FINDWORK: /* inaccurate this way */
+ ActiveTSO = ThreadQueueHd;
+ break;
+ case RESUMETHREAD:
+ case STARTTHREAD:
+ case MOVESPARK: /* has tso of virt proc in tso field of event */
+ ActiveTSO = EVENT_TSO(event);
+ break;
+ default: fprintf(stderr,"Illegal event type %s (%d) in GrAnSim Light setup\n",
+ event_names[EVENT_TYPE(event)],EVENT_TYPE(event));
+ EXIT(EXIT_FAILURE);
+ }
+ CurrentTime[CurrentProc] = TSO_CLOCK(ActiveTSO);
+ if(RTSflags.GranFlags.DoFairSchedule)
+ {
+ if (RTSflags.GranFlags.granSimStats &&
+ RTSflags.GranFlags.debug & 0x20000)
+ DumpGranEvent(GR_SYSTEM_START,ActiveTSO);
+ }
+ }
- MAKE_BUSY(CurrentProc);
+ if(EVENT_TIME(event) > CurrentTime[CurrentProc] &&
+ EVENT_TYPE(event)!=CONTINUETHREAD)
+ CurrentTime[CurrentProc] = EVENT_TIME(event);
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (debug & 0x80)
- fprintf(stderr,"D> After getnextevent, before HandleIdlePEs\n");
-#endif
+# if defined(GRAN_CHECK) && defined(GRAN) /* HWL */
+ if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
+ fprintf(stderr,"Qagh {ReSchedule}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ /* MAKE_BUSY(CurrentProc); don't think that's right in all cases now */
+ /* -- HWL */
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GranFlags.debug & 0x80)
+ fprintf(stderr,"After get_next_event, before HandleIdlePEs\n");
+# endif
/* Deal with the idlers */
- HandleIdlePEs();
+ if ( !RTSflags.GranFlags.Light )
+ HandleIdlePEs();
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (event_trace &&
- (event_trace_all || EVENT_TYPE(event) != CONTINUETHREAD ||
- (debug & 0x80) ))
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.event_trace_all ||
+ ( RTSflags.GranFlags.event_trace && EVENT_TYPE(event) != CONTINUETHREAD) ||
+ (RTSflags.GranFlags.debug & 0x80) )
print_event(event);
-#endif
+# endif
switch (EVENT_TYPE(event))
{
/* Should just be continuing execution */
case CONTINUETHREAD:
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( (debug & 0x04) && BlockedOnFetch[CurrentProc]) {
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( (RTSflags.GranFlags.debug & 0x100) &&
+ (EVENT_TSO(event)!=RunnableThreadsHd[EVENT_PROC(event)]) ) {
+ fprintf(stderr,"Warning: Wrong TSO in CONTINUETHREAD: %#lx (%x) (PE: %d Hd: 0x%lx)\n",
+ EVENT_TSO(event), TSO_ID(EVENT_TSO(event)),
+ EVENT_PROC(event),
+ RunnableThreadsHd[EVENT_PROC(event)]);
+ }
+ if ( (RTSflags.GranFlags.debug & 0x04) &&
+ BlockedOnFetch[CurrentProc]) {
fprintf(stderr,"Warning: Discarding CONTINUETHREAD on blocked proc %u @ %u\n",
CurrentProc,CurrentTime[CurrentProc]);
print_event(event);
continue;
}
-#endif
- if(ThreadQueueHd==Nil_closure)
+# endif
+ if(ThreadQueueHd==Prelude_Z91Z93_closure)
{
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,Nil_closure,Nil_closure,NULL);
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
continue; /* Catches superfluous CONTINUEs -- should be unnecessary */
}
else
break; /* fall into scheduler loop */
case FETCHNODE:
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (SimplifiedFetch) {
- fprintf(stderr,"Error: FETCHNODE events not valid with simplified fetch\n");
- exit (99);
- }
-#endif
-
- CurrentTime[CurrentProc] += gran_munpacktime;
- HandleFetchRequest(EVENT_NODE(event),
- EVENT_CREATOR(event),
- EVENT_TSO(event));
- continue;
+ do_the_fetchnode(event);
+ continue; /* handle next event in event queue */
+
+ case GLOBALBLOCK:
+ do_the_globalblock(event);
+ continue; /* handle next event in event queue */
case FETCHREPLY:
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (SimplifiedFetch) {
- fprintf(stderr,"Error: FETCHREPLY events not valid with simplified fetch\n");
- exit (99);
- }
-
- if (debug & 0x10) {
- if (TSO_TYPE(EVENT_TSO(event)) & FETCH_MASK_TSO) {
- TSO_TYPE(EVENT_TSO(event)) &= ~FETCH_MASK_TSO;
- } else {
- fprintf(stderr,"Error: FETCHREPLY: TSO 0x%x has fetch mask not set @ %d\n",
- CurrentTSO,CurrentTime[CurrentProc]);
- exit(99);
- }
- }
-
- if (debug & 0x04) {
- if (BlockedOnFetch[CurrentProc]!=ThreadQueueHd) {
- fprintf(stderr,"Error: FETCHREPLY: Proc %d (with TSO 0x%x) not blocked-on-fetch by TSO 0x%x\n",
- CurrentProc,CurrentTSO,BlockedOnFetch[CurrentProc]);
- exit(99);
- } else {
- BlockedOnFetch[CurrentProc] = 0; /*- StgFalse; -*/
- }
- }
-#endif
+ do_the_fetchreply(event);
+ continue; /* handle next event in event queue */
- /* Copy or move node to CurrentProc */
- if (FetchNode(EVENT_NODE(event),
- EVENT_CREATOR(event),
- EVENT_PROC(event)) ) {
- /* Fetch has failed i.e. node has been grabbed by another PE */
- P_ node = EVENT_NODE(event), tso = EVENT_TSO(event);
- PROC p = where_is(node);
- TIME fetchtime;
-
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (PrintFetchMisses) {
- fprintf(stderr,"Fetch miss @ %lu: node 0x%x is at proc %u (rather than proc %u)\n",
- CurrentTime[CurrentProc],node,p,EVENT_CREATOR(event));
- fetch_misses++;
- }
-#endif /* GRAN_CHECK */
-
- CurrentTime[CurrentProc] += gran_mpacktime;
-
- /* Count fetch again !? */
- ++TSO_FETCHCOUNT(tso);
- TSO_FETCHTIME(tso) += gran_fetchtime;
-
- fetchtime = max(CurrentTime[CurrentProc],CurrentTime[p]) +
- gran_latency;
-
- /* Chase the grabbed node */
- newevent(p,CurrentProc,fetchtime,FETCHNODE,tso,node,NULL);
-
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (debug & 0x04)
- BlockedOnFetch[CurrentProc] = tso; /*-StgTrue;-*/
-
- if (debug & 0x10)
- TSO_TYPE(tso) |= FETCH_MASK_TSO;
-#endif
-
- CurrentTime[CurrentProc] += gran_mtidytime;
-
- continue; /* NB: no REPLy has been processed; tso still sleeping */
- }
-
- /* -- Qapla'! Fetch has been successful; node is here, now */
- ++TSO_FETCHCOUNT(EVENT_TSO(event));
- TSO_FETCHTIME(EVENT_TSO(event)) += gran_fetchtime;
-
- if (RTSflags.ParFlags.granSimStats)
- DumpGranEventAndNode(GR_REPLY,EVENT_TSO(event),
- EVENT_NODE(event),EVENT_CREATOR(event));
-
- --OutstandingFetches[CurrentProc];
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (OutstandingFetches[CurrentProc] < 0) {
- fprintf(stderr,"OutstandingFetches of proc %u has become negative\n",CurrentProc);
- exit (99);
- }
-#endif
-
- if (!DoReScheduleOnFetch) {
- CurrentTSO = EVENT_TSO(event); /* awaken blocked thread */
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,Nil_closure,Nil_closure,NULL);
- TSO_BLOCKTIME(EVENT_TSO(event)) += CurrentTime[CurrentProc] -
- TSO_BLOCKEDAT(EVENT_TSO(event));
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEvent(GR_RESUME,EVENT_TSO(event));
- continue;
- } else {
- /* fall through to RESUMETHREAD */
- }
+ case UNBLOCKTHREAD: /* Move from the blocked queue to the tail of */
+ do_the_unblock(event);
+ continue; /* handle next event in event queue */
case RESUMETHREAD: /* Move from the blocked queue to the tail of */
/* the runnable queue ( i.e. Qu' SImqa'lu') */
continue;
case STARTTHREAD:
- StartThread(event,GR_START);
+ StartThread(event,GR_START);
continue;
case MOVETHREAD:
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (!DoThreadMigration) {
- fprintf(stderr,"MOVETHREAD events should never occur without -bM\n");
- exit (99);
- }
-#endif
- CurrentTime[CurrentProc] += gran_munpacktime;
- StartThread(event,GR_STOLEN);
- continue; /* to the next event */
+ do_the_movethread(event);
+ continue; /* handle next event in event queue */
case MOVESPARK:
- CurrentTime[CurrentProc] += gran_munpacktime;
- spark = EVENT_SPARK(event);
-
- ADD_TO_SPARK_QUEUE(spark); /* NB: this macro side-effects its arg.
- so the assignment above is needed. */
-
- if(do_sp_profile)
- DumpSparkGranEvent(SP_ACQUIRED,spark);
-
- ++SparksAvail; /* Probably Temporarily */
- /* Drop into FINDWORK */
-
- if (!DoReScheduleOnFetch &&
- (ThreadQueueHd != Nil_closure) ) { /* If we block on fetch then go */
- continue; /* to next event (i.e. leave */
- } /* spark in sparkq for now) */
+ do_the_movespark(event);
+ continue; /* handle next event in event queue */
case FINDWORK:
- if((ThreadQueueHd == Nil_closure || DoAlwaysCreateThreads)
- && (FetchStrategy >= 2 || OutstandingFetches[CurrentProc] == 0))
- {
- W_ found = 0;
- sparkq spark_of_non_local_node = NULL;
-
- /* Choose a spark from the local spark queue */
- spark = SparkQueueHd;
-
- while (spark != NULL && !found)
- {
- node = SPARK_NODE(spark);
- if (!SHOULD_SPARK(node))
- {
- if(do_sp_profile)
- DumpSparkGranEvent(SP_PRUNED,spark);
-
- ASSERT(spark != NULL);
-
- SparkQueueHd = SPARK_NEXT(spark);
- if(SparkQueueHd == NULL)
- SparkQueueTl = NULL;
-
- DisposeSpark(spark);
-
- spark = SparkQueueHd;
- }
- /* -- node should eventually be sparked */
- else if (PreferSparksOfLocalNodes &&
- !IS_LOCAL_TO(PROCS(node),CurrentProc))
- {
- /* We have seen this spark before => no local sparks */
- if (spark==spark_of_non_local_node) {
- found = 1;
- break;
- }
-
- /* Remember first non-local node */
- if (spark_of_non_local_node==NULL)
- spark_of_non_local_node = spark;
-
- /* Special case: 1 elem sparkq with non-local spark */
- if (spark==SparkQueueTl) {
- found = 1;
- break;
- }
-
- /* Put spark (non-local!) at the end of the sparkq */
- SPARK_NEXT(SparkQueueTl) = spark;
- SparkQueueHd = SPARK_NEXT(spark);
- SPARK_NEXT(spark) = NULL;
- SparkQueueTl = spark;
+ if( RTSflags.GranFlags.DoAlwaysCreateThreads ||
+ (ThreadQueueHd == Prelude_Z91Z93_closure &&
+ (RTSflags.GranFlags.FetchStrategy >= 2 ||
+ OutstandingFetches[CurrentProc] == 0)) )
+ {
+ rtsBool found;
+ sparkq prev, spark;
+
+ /* ToDo: check */
+ ASSERT(procStatus[CurrentProc]==Sparking ||
+ RTSflags.GranFlags.DoAlwaysCreateThreads);
+
+ /* SImmoHwI' yInej! Search spark queue! */
+ gimme_spark (&found, &prev, &spark);
- spark = SparkQueueHd;
- }
- else
- {
- found = 1;
- }
- }
-
- /* We've found a node; now, create thread (DaH Qu' yIchen) */
- if (found)
- {
- CurrentTime[CurrentProc] += gran_threadcreatetime;
-
- node = SPARK_NODE(spark);
- if((tso = NewThread(node, T_REQUIRED))==NULL)
- {
- /* Some kind of backoff needed here in case there's too little heap */
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc]+1,
- FINDWORK,Nil_closure,Nil_closure,NULL);
- ReallyPerformThreadGC(TSO_HS+TSO_CTS_SIZE,StgTrue);
- spark = NULL;
- continue; /* to the next event, eventually */
- }
-
- TSO_EXPORTED(tso) = SPARK_EXPORTED(spark);
- TSO_LOCKED(tso) = !SPARK_GLOBAL(spark);
- TSO_SPARKNAME(tso) = SPARK_NAME(spark);
-
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- STARTTHREAD,tso,Nil_closure,NULL);
-
- ASSERT(spark != NULL);
-
- SparkQueueHd = SPARK_NEXT(spark);
- if(SparkQueueHd == NULL)
- SparkQueueTl = NULL;
-
- DisposeSpark(spark);
- }
- else
- /* Make the PE idle if nothing sparked and we have no threads. */
- {
- if(ThreadQueueHd == Nil_closure)
-#if defined(GRAN_CHECK) && defined(GRAN)
- {
- MAKE_IDLE(CurrentProc);
- if ( (debug & 0x40) || (debug & 0x80) ) {
- fprintf(stderr,"Warning in FINDWORK handling: No work found for PROC %u\n",CurrentProc);
- }
- }
-#else
- MAKE_IDLE(CurrentProc);
-#endif /* GRAN_CHECK */
- else
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- CONTINUETHREAD,Nil_closure,Nil_closure,NULL);
- }
+ /* DaH chu' Qu' yIchen! Now create new work! */
+ munch_spark (found, prev, spark);
- continue; /* to the next event */
- }
- else
- {
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if ( (debug & 0x04) &&
- (!DoReScheduleOnFetch && ThreadQueueHd != Nil_closure)
- ) {
- fprintf(stderr,"Waning in FINDWORK handling:\n");
- fprintf(stderr,"ThreadQueueHd!=Nil_closure should never happen with !DoReScheduleOnFetch");
- }
-#endif
- if (FetchStrategy < 2 && OutstandingFetches[CurrentProc] != 0)
- continue; /* to next event */
- else
- break; /* run ThreadQueueHd */
+ /* ToDo: check */
+ ASSERT(procStatus[CurrentProc]==Starting ||
+ procStatus[CurrentProc]==Idle ||
+ RTSflags.GranFlags.DoAlwaysCreateThreads);
}
- /* never reached */
+ continue; /* to the next event */
default:
fprintf(stderr,"Illegal event type %u\n",EVENT_TYPE(event));
continue;
- }
- _longjmp(scheduler_loop, 1);
+ } /* switch */
+ longjmp(scheduler_loop, 1);
} while(1);
+}
+
+/* ----------------------------------------------------------------- */
+/* The main event handling functions; called from ReSchedule (switch) */
+/* ----------------------------------------------------------------- */
+
+void
+do_the_globalblock(eventq event)
+{
+ PROC proc = EVENT_PROC(event); /* proc that requested node */
+ P_ tso = EVENT_TSO(event), /* tso that requested node */
+ node = EVENT_NODE(event); /* requested, remote node */
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh: There should be no GLOBALBLOCKs in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
}
-\end{code}
-Here follows the non-GRAN @ReSchedule@.
+ if (!RTSflags.GranFlags.DoGUMMFetching) {
+ fprintf(stderr,"Qagh: GLOBALBLOCK events only valid with GUMM fetching\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ if ( (RTSflags.GranFlags.debug & 0x100) &&
+ IS_LOCAL_TO(PROCS(node),proc) ) {
+ fprintf(stderr,"Qagh: GLOBALBLOCK: Blocking on LOCAL node 0x %x (PE %d).\n",
+ node,proc);
+ }
+# endif
+ /* CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime; */
+ if ( blockFetch(tso,proc,node) != 0 )
+ return; /* node has become local by now */
+
+ if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* head of queue is next thread */
+ P_ tso = RunnableThreadsHd[proc]; /* awaken next thread */
+ if(tso != Prelude_Z91Z93_closure) {
+ new_event(proc,proc,CurrentTime[proc],
+ CONTINUETHREAD,tso,Prelude_Z91Z93_closure,NULL);
+ CurrentTime[proc] += RTSflags.GranFlags.gran_threadcontextswitchtime;
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(proc,CurrentProc,GR_SCHEDULE,tso,
+ Prelude_Z91Z93_closure,0);
+ MAKE_BUSY(proc); /* might have been fetching */
+ } else {
+ MAKE_IDLE(proc); /* no work on proc now */
+ }
+ } else { /* RTSflags.GranFlags.DoReScheduleOnFetch i.e. block-on-fetch */
+ /* other thread is already running */
+ /* 'oH 'utbe' 'e' vIHar ; I think that's not needed -- HWL
+ new_event(proc,proc,CurrentTime[proc],
+ CONTINUETHREAD,EVENT_TSO(event),
+ (RTSflags.GranFlags.DoGUMMFetching ? closure :
+ EVENT_NODE(event)),NULL);
+ */
+ }
+}
+
+void
+do_the_unblock(eventq event)
+{
+ PROC proc = EVENT_PROC(event), /* proc that requested node */
+ creator = EVENT_CREATOR(event); /* proc that requested node */
+ P_ tso = EVENT_TSO(event), /* tso that requested node */
+ node = EVENT_NODE(event); /* requested, remote node */
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh: There should be no UNBLOCKs in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
+ if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* block-on-fetch */
+ /* We count block-on-fetch as normal block time */
+ TSO_BLOCKTIME(tso) += CurrentTime[proc] - TSO_BLOCKEDAT(tso);
+ /* No costs for contextswitch or thread queueing in this case */
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(proc,CurrentProc,GR_RESUME,tso, Prelude_Z91Z93_closure,0);
+ new_event(proc,proc,CurrentTime[proc],CONTINUETHREAD,tso,node,NULL);
+ } else {
+ /* Reschedule on fetch causes additional costs here: */
+ /* Bring the TSO from the blocked queue into the threadq */
+ new_event(proc,proc,CurrentTime[proc]+RTSflags.GranFlags.gran_threadqueuetime,
+ RESUMETHREAD,tso,node,NULL);
+ }
+}
+
+void
+do_the_fetchnode(eventq event)
+{
+ I_ rc;
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh: There should be no FETCHNODEs in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ if (RTSflags.GranFlags.SimplifiedFetch) {
+ fprintf(stderr,"Qagh: FETCHNODE events not valid with simplified fetch\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
+ do {
+ rc = HandleFetchRequest(EVENT_NODE(event),
+ EVENT_CREATOR(event),
+ EVENT_TSO(event));
+ if (rc == 4) { /* trigger GC */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GcFlags.giveStats)
+ fprintf(RTSflags.GcFlags.statsFile,"***** veQ boSwI' PackNearbyGraph(node %#lx, tso %#lx (%x))\n",
+ EVENT_NODE(event), EVENT_TSO(event), TSO_ID(EVENT_TSO(event)));
+# endif
+ prepend_event(event);
+ ReallyPerformThreadGC(PACK_HEAP_REQUIRED, rtsFalse);
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GcFlags.giveStats) {
+ fprintf(RTSflags.GcFlags.statsFile,"***** SAVE_Hp=%#lx, SAVE_HpLim=%#lx, PACK_HEAP_REQUIRED=%#lx\n",
+ SAVE_Hp, SAVE_HpLim, PACK_HEAP_REQUIRED);
+ fprintf(stderr,"***** No. of packets so far: %d (total size: %d)\n",
+ tot_packets,tot_packet_size);
+ }
+# endif
+ event = grab_event();
+ SAVE_Hp -= PACK_HEAP_REQUIRED-1;
+
+ /* GC knows that events are special beats and follows the pointer i.e. */
+ /* events are valid even if they moved. Hopefully, an EXIT is triggered */
+ /* if there is not enough heap after GC. */
+ }
+ } while (rc == 4);
+}
+
+void
+do_the_fetchreply(eventq event)
+{
+ P_ tso, closure;
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh: There should be no FETCHREPLYs in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ if (RTSflags.GranFlags.SimplifiedFetch) {
+ fprintf(stderr,"Qagh: FETCHREPLY events not valid with simplified fetch\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ if (RTSflags.GranFlags.debug & 0x10) {
+ if (TSO_TYPE(EVENT_TSO(event)) & FETCH_MASK_TSO) {
+ TSO_TYPE(EVENT_TSO(event)) &= ~FETCH_MASK_TSO;
+ } else {
+ fprintf(stderr,"Qagh: FETCHREPLY: TSO %#x (%x) has fetch mask not set @ %d\n",
+ CurrentTSO,TSO_ID(CurrentTSO),CurrentTime[CurrentProc]);
+ EXIT(EXIT_FAILURE);
+ }
+ }
+
+ if (RTSflags.GranFlags.debug & 0x04) {
+ if (BlockedOnFetch[CurrentProc]!=ThreadQueueHd) {
+ fprintf(stderr,"Qagh: FETCHREPLY: Proc %d (with TSO %#x (%x)) not blocked-on-fetch by TSO %#lx (%x)\n",
+ CurrentProc,CurrentTSO,TSO_ID(CurrentTSO),
+ BlockedOnFetch[CurrentProc], TSO_ID(BlockedOnFetch[CurrentProc]));
+ EXIT(EXIT_FAILURE);
+ } else {
+ BlockedOnFetch[CurrentProc] = 0; /*- rtsFalse; -*/
+ }
+ }
+# endif
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
+
+ if (RTSflags.GranFlags.DoGUMMFetching) { /* bulk (packet) fetching */
+ P_ buffer = EVENT_NODE(event);
+ PROC p = EVENT_PROC(event);
+ I_ size = buffer[PACK_SIZE_LOCN];
+
+ tso = EVENT_TSO(event);
+
+ /* NB: Fetch misses can't occur with GUMM fetching, as */
+ /* updatable closure are turned into RBHs and therefore locked */
+ /* for other processors that try to grab them. */
+
+ closure = UnpackGraph(buffer);
+ CurrentTime[CurrentProc] += size * RTSflags.GranFlags.gran_munpacktime;
+ } else
+ /* Copy or move node to CurrentProc */
+ if (FetchNode(EVENT_NODE(event),
+ EVENT_CREATOR(event),
+ EVENT_PROC(event)) ) {
+ /* Fetch has failed i.e. node has been grabbed by another PE */
+ P_ node = EVENT_NODE(event), tso = EVENT_TSO(event);
+ PROC p = where_is(node);
+ TIME fetchtime;
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GranFlags.PrintFetchMisses) {
+ fprintf(stderr,"Fetch miss @ %lu: node %#lx is at proc %u (rather than proc %u)\n",
+ CurrentTime[CurrentProc],node,p,EVENT_CREATOR(event));
+ fetch_misses++;
+ }
+# endif /* GRAN_CHECK */
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+
+ /* Count fetch again !? */
+ ++TSO_FETCHCOUNT(tso);
+ TSO_FETCHTIME(tso) += RTSflags.GranFlags.gran_fetchtime;
+
+ fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p]) +
+ RTSflags.GranFlags.gran_latency;
+
+ /* Chase the grabbed node */
+ new_event(p,CurrentProc,fetchtime,FETCHNODE,tso,node,NULL);
+
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if (RTSflags.GranFlags.debug & 0x04)
+ BlockedOnFetch[CurrentProc] = tso; /*-rtsTrue;-*/
+
+ if (RTSflags.GranFlags.debug & 0x10)
+ TSO_TYPE(tso) |= FETCH_MASK_TSO;
+# endif
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+
+ return; /* NB: no REPLy has been processed; tso still sleeping */
+ }
+
+ /* -- Qapla'! Fetch has been successful; node is here, now */
+ ++TSO_FETCHCOUNT(EVENT_TSO(event));
+ TSO_FETCHTIME(EVENT_TSO(event)) += RTSflags.GranFlags.gran_fetchtime;
+
+ if (RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(CurrentProc,EVENT_CREATOR(event),GR_REPLY,
+ EVENT_TSO(event),
+ (RTSflags.GranFlags.DoGUMMFetching ?
+ closure :
+ EVENT_NODE(event)),
+ 0);
+
+ --OutstandingFetches[CurrentProc];
+ ASSERT(OutstandingFetches[CurrentProc] >= 0);
+# if 0 && defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if (OutstandingFetches[CurrentProc] < 0) {
+ fprintf(stderr,"Qagh: OutstandingFetches of proc %u has become negative\n",CurrentProc);
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ UNBLOCKTHREAD,EVENT_TSO(event),
+ (RTSflags.GranFlags.DoGUMMFetching ?
+ closure :
+ EVENT_NODE(event)),
+ NULL);
+}
+
+void
+do_the_movethread(eventq event) {
+ P_ tso = EVENT_TSO(event);
+# if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
+ if ( RTSflags.GranFlags.Light && CurrentProc!=1 ) {
+ fprintf(stderr,"Qagh: There should be no MOVETHREADs in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+ if (!RTSflags.GranFlags.DoThreadMigration) {
+ fprintf(stderr,"Qagh: MOVETHREAD events should never occur without -bM\n");
+ EXIT(EXIT_FAILURE);
+ }
+ if (PROCS(tso)!=0) {
+ fprintf(stderr,"Qagh: Moved thread has a bitmask of 0%o (proc %d); should be 0\n",
+ PROCS(tso), where_is(tso));
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ --OutstandingFishes[CurrentProc];
+ ASSERT(OutstandingFishes[CurrentProc]>=0);
+ SET_PROCS(tso,ThisPE);
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
+ StartThread(event,GR_STOLEN);
+}
+
+void
+do_the_movespark(eventq event){
+ sparkq spark = EVENT_SPARK(event);
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_munpacktime;
+
+ if (RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,(PROC)0,SP_ACQUIRED,Prelude_Z91Z93_closure,
+ SPARK_NODE(spark),
+ spark_queue_len(CurrentProc,ADVISORY_POOL));
+
+#if defined(GRAN) && defined(GRAN_CHECK)
+ if (!SHOULD_SPARK(SPARK_NODE(spark)))
+ withered_sparks++;
+ /* Not adding the spark to the spark queue would be the right */
+ /* thing here, but it also would be cheating, as this info can't be */
+ /* available in a real system. -- HWL */
+#endif
+ --OutstandingFishes[CurrentProc];
+ ASSERT(OutstandingFishes[CurrentProc]>=0);
+
+ add_to_spark_queue(spark);
+
+ if (procStatus[CurrentProc]==Fishing)
+ procStatus[CurrentProc] = Idle;
+
+ /* add_to_spark_queue will increase the time of the current proc. */
+ /* Just falling into FINDWORK is wrong as we might have other */
+ /* events that are happening before that. Therefore, just create */
+ /* a FINDWORK event and go back to main event handling loop. */
+
+ /* Should we treat stolen sparks specially? Currently, we don't. */
+#if 0
+ /* Now FINDWORK is created in HandleIdlePEs */
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
+ sparking[CurrentProc]=rtsTrue;
+#endif
+}
+
+/* Search the spark queue of the CurrentProc for a spark that's worth
+ turning into a thread */
+void
+gimme_spark (rtsBool *found_res, sparkq *prev_res, sparkq *spark_res)
+{
+ P_ node;
+ rtsBool found;
+ sparkq spark_of_non_local_node = NULL, spark_of_non_local_node_prev = NULL,
+ low_priority_spark = NULL, low_priority_spark_prev = NULL,
+ spark = NULL, prev = NULL, tmp = NULL;
+
+ /* Choose a spark from the local spark queue */
+ spark = SparkQueueHd;
+ found = rtsFalse;
+
+ while (spark != NULL && !found)
+ {
+ node = SPARK_NODE(spark);
+ if (!SHOULD_SPARK(node))
+ {
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,(PROC)0,SP_PRUNED,Prelude_Z91Z93_closure,
+ SPARK_NODE(spark),
+ spark_queue_len(CurrentProc,ADVISORY_POOL));
+
+ ASSERT(spark != NULL);
+
+ --SparksAvail;
+ spark = delete_from_spark_queue (prev,spark);
+ }
+ /* -- node should eventually be sparked */
+ else if (RTSflags.GranFlags.PreferSparksOfLocalNodes &&
+ !IS_LOCAL_TO(PROCS(node),CurrentProc))
+ {
+ /* Remember first low priority spark */
+ if (spark_of_non_local_node==NULL) {
+ spark_of_non_local_node_prev = prev;
+ spark_of_non_local_node = spark;
+ }
+
+ if (SPARK_NEXT(spark)==NULL) {
+ ASSERT(spark==SparkQueueTl); /* just for testing */
+ prev = spark_of_non_local_node_prev;
+ spark = spark_of_non_local_node;
+ found = rtsTrue;
+ break;
+ }
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ /* Should never happen; just for testing */
+ if (spark==SparkQueueTl) {
+ fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ prev = spark;
+ spark = SPARK_NEXT(spark);
+ --SparksAvail;
+ }
+ else if ( RTSflags.GranFlags.DoPrioritySparking ||
+ (SPARK_GRAN_INFO(spark)>=RTSflags.GranFlags.SparkPriority2) )
+ {
+ found = rtsTrue;
+ }
+ else /* only used if SparkPriority2 is defined */
+ {
+ /* Remember first low priority spark */
+ if (low_priority_spark==NULL) {
+ low_priority_spark_prev = prev;
+ low_priority_spark = spark;
+ }
+
+ if (SPARK_NEXT(spark)==NULL) {
+ ASSERT(spark==SparkQueueTl); /* just for testing */
+ prev = low_priority_spark_prev;
+ spark = low_priority_spark;
+ found = rtsTrue; /* take low pri spark => rc is 2 */
+ break;
+ }
+
+ /* Should never happen; just for testing */
+ if (spark==SparkQueueTl) {
+ fprintf(stderr,"ReSchedule: Last spark != SparkQueueTl\n");
+ EXIT(EXIT_FAILURE);
+ break;
+ }
+ prev = spark;
+ spark = SPARK_NEXT(spark);
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x40 ) {
+ fprintf(stderr,"Ignoring spark of priority %u (SparkPriority=%u); node=0x%lx; name=%u\n",
+ SPARK_GRAN_INFO(spark), RTSflags.GranFlags.SparkPriority,
+ SPARK_NODE(spark), SPARK_NAME(spark));
+ }
+# endif /* GRAN_CHECK */
+ }
+ } /* while (spark!=NULL && !found) */
+
+ *spark_res = spark;
+ *prev_res = prev;
+ *found_res = found;
+}
+
+void
+munch_spark (rtsBool found, sparkq prev, sparkq spark)
+{
+ P_ tso, node;
+
+ /* We've found a node; now, create thread (DaH Qu' yIchen) */
+ if (found)
+ {
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( SPARK_GRAN_INFO(spark) < RTSflags.GranFlags.SparkPriority2 ) {
+ tot_low_pri_sparks++;
+ if ( RTSflags.GranFlags.debug & 0x40 ) {
+ fprintf(stderr,"GRAN_TNG: No high priority spark available; low priority (%u) spark chosen: node=0x%lx; name=%u\n",
+ SPARK_GRAN_INFO(spark),
+ SPARK_NODE(spark), SPARK_NAME(spark));
+ }
+ }
+# endif
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadcreatetime;
+
+ node = SPARK_NODE(spark);
+ if((tso = NewThread(node, T_REQUIRED, SPARK_GRAN_INFO(spark)))==NULL)
+ {
+ /* Some kind of backoff needed here in case there's too little heap */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (RTSflags.GcFlags.giveStats)
+ fprintf(RTSflags.GcFlags.statsFile,"***** vIS Qu' chen veQ boSwI'; spark=%#x, node=%#x; name=%u\n",
+ /* (found==2 ? "no hi pri spark" : "hi pri spark"), */
+ spark, node,SPARK_NAME(spark));
+# endif
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc]+1,
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
+ ReallyPerformThreadGC(TSO_HS+TSO_CTS_SIZE,rtsTrue);
+ spark = NULL;
+ return; /* was: continue; */ /* to the next event, eventually */
+ }
+
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(CurrentProc,(PROC)0,SP_USED,Prelude_Z91Z93_closure,
+ SPARK_NODE(spark),
+ spark_queue_len(CurrentProc,ADVISORY_POOL));
+
+ TSO_EXPORTED(tso) = SPARK_EXPORTED(spark);
+ TSO_LOCKED(tso) = !SPARK_GLOBAL(spark);
+ TSO_SPARKNAME(tso) = (0x1 >> 16) | (NEW_SPARKNAME_MASK & SPARK_NAME(spark)) ;
+
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ STARTTHREAD,tso,node,NULL);
+
+ procStatus[CurrentProc] = Starting;
+
+ ASSERT(spark != NULL);
+ /* ASSERT(SPARK_PREV(spark)==prev); */
+
+ spark = delete_from_spark_queue (prev, spark);
+ }
+ else /* !found */
+ /* Make the PE idle if nothing sparked and we have no threads. */
+ {
+ if(ThreadQueueHd == Prelude_Z91Z93_closure)
+ {
+ MAKE_IDLE(CurrentProc);
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( (RTSflags.GranFlags.debug & 0x80) )
+ fprintf(stderr,"Warning in FINDWORK handling: No work found for PROC %u\n",CurrentProc);
+# endif /* GRAN_CHECK */
+ }
+#if 0
+ else
+ /* ut'lu'Qo' ; Don't think that's necessary any more -- HWL
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,ThreadQueueHd,Prelude_Z91Z93_closure,NULL);
+ */
+#endif
+ }
+
+}
+\end{code}
+
+Here follows the non-GRAN @ReSchedule@.
+
\begin{code}
#else /* !GRAN */
+/* If you are concurrent and maybe even parallel please use this door. */
+
void
ReSchedule(again)
int again; /* Run the current thread again? */
sameThread = again;
if (again) {
- if (RunnableThreadsHd == Nil_closure)
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure)
RunnableThreadsTl = CurrentTSO;
TSO_LINK(CurrentTSO) = RunnableThreadsHd;
RunnableThreadsHd = CurrentTSO;
*/
if (again) {
- if(RunnableThreadsHd == Nil_closure) {
+ if(RunnableThreadsHd == Prelude_Z91Z93_closure) {
RunnableThreadsHd = CurrentTSO;
} else {
TSO_LINK(RunnableThreadsTl) = CurrentTSO;
* in all the time. This makes sure that we don't access saved registers,
* etc. in threads which are supposed to be sleeping.
*/
- CurrentTSO = Nil_closure;
+ CurrentTSO = Prelude_Z91Z93_closure;
CurrentRegTable = NULL;
#endif
if (SHOULD_SPARK(spark)) {
if ((tso = NewThread(spark, T_REQUIRED)) == NULL)
break;
- if (RunnableThreadsHd == Nil_closure) {
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
RunnableThreadsHd = tso;
#ifdef PAR
if (RTSflags.ParFlags.granSimStats) {
}
RunnableThreadsTl = tso;
} else {
- if (DO_QP_PROF)
+ if (DO_QP_PROF)
QP_Event0(threadId++, spark);
-#ifdef PAR
- if(do_sp_profile)
- DumpSparkGranEvent(SP_PRUNED, threadId++);
+#if 0
+ /* ToDo: Fix log entries for pruned sparks in GUM -- HWL */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpGranEvent(SP_PRUNED,threadId++);
+ ^^^^^^^^ should be a TSO
#endif
}
}
/* In the parallel world, don't create advisory threads if we are
* about to rerun the same thread, or already have runnable threads,
* or the main thread has terminated */
- (RunnableThreadsHd != Nil_closure ||
+ (RunnableThreadsHd != Prelude_Z91Z93_closure ||
(required_thread_count == 0 && IAmMainThread)) ||
#endif
advisory_thread_count == RTSflags.ConcFlags.maxThreads ||
(tso = NewThread(spark, T_ADVISORY)) == NULL)
break;
advisory_thread_count++;
- if (RunnableThreadsHd == Nil_closure) {
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
RunnableThreadsHd = tso;
#ifdef PAR
if (RTSflags.ParFlags.granSimStats) {
} else {
if (DO_QP_PROF)
QP_Event0(threadId++, spark);
-#ifdef PAR
- if(do_sp_profile)
- DumpSparkGranEvent(SP_PRUNED, threadId++);
+#if 0
+ /* ToDo: Fix log entries for pruned sparks in GUM -- HWL */
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpGranEvent(SP_PRUNED,threadId++);
+ ^^^^^^^^ should be a TSO
#endif
}
}
\begin{code}
#if defined(GRAN)
+/* ngoqvam che' {GrAnSim}! */
+
+# if defined(GRAN_CHECK)
+/* This routine is only used for keeping a statistics of thread queue
+ lengths to evaluate the impact of priority scheduling. -- HWL
+ {spark_queue_len}vo' jInIHta'
+*/
+I_
+thread_queue_len(PROC proc)
+{
+ P_ prev, next;
+ I_ len;
+
+ for (len = 0, prev = Prelude_Z91Z93_closure, next = RunnableThreadsHd[proc];
+ next != Prelude_Z91Z93_closure;
+ len++, prev = next, next = TSO_LINK(prev))
+ {}
+
+ return (len);
+}
+# endif /* GRAN_CHECK */
+\end{code}
+
+A large portion of @StartThread@ deals with maintaining a sorted thread
+queue, which is needed for the Priority Sparking option. Without that
+complication the code boils down to FIFO handling.
+
+\begin{code}
StartThread(event,event_type)
eventq event;
enum gran_event_types event_type;
{
- if(ThreadQueueHd==Nil_closure)
+ P_ tso = EVENT_TSO(event),
+ node = EVENT_NODE(event);
+ PROC proc = EVENT_PROC(event),
+ creator = EVENT_CREATOR(event);
+ P_ prev, next;
+ I_ count = 0;
+ rtsBool found = rtsFalse;
+
+ ASSERT(CurrentProc==proc);
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
+ fprintf(stderr,"Qagh {StartThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ /* A wee bit of statistics gathering */
+ ++tot_add_threads;
+ tot_tq_len += thread_queue_len(CurrentProc);
+# endif
+
+ ASSERT(TSO_LINK(CurrentTSO)==Prelude_Z91Z93_closure); /* TMP-CHG HWL */
+
+ /* Idle proc; same for pri spark and basic version */
+ if(ThreadQueueHd==Prelude_Z91Z93_closure)
{
- CurrentTSO = ThreadQueueHd = ThreadQueueTl = EVENT_TSO(event);
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc]+gran_threadqueuetime,
- CONTINUETHREAD,Nil_closure,Nil_closure,NULL);
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEvent(event_type,EVENT_TSO(event));
+ CurrentTSO = ThreadQueueHd = ThreadQueueTl = tso;
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadqueuetime;
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,tso,Prelude_Z91Z93_closure,NULL);
+
+ if(RTSflags.GranFlags.granSimStats &&
+ !( (event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
+ DumpRawGranEvent(CurrentProc,creator,event_type,
+ tso,node,
+ TSO_SPARKNAME(tso));
+ /* ^^^ SN (spark name) as optional info */
+ /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
+ /* ^^^ spark length as optional info */
+
+ ASSERT(IS_IDLE(CurrentProc) || event_type==GR_RESUME ||
+ (procStatus[CurrentProc]==Fishing && event_type==GR_STOLEN) ||
+ procStatus[CurrentProc]==Starting);
+ MAKE_BUSY(CurrentProc);
+ return;
}
- else
+
+ /* In GrAnSim-Light we always have an idle `virtual' proc.
+ The semantics of the one-and-only thread queue is different here:
+ all threads in the queue are running (each on its own virtual processor);
+ the queue is only needed internally in the simulator to interleave the
+ reductions of the different processors.
+ The one-and-only thread queue is sorted by the local clocks of the TSOs.
+ */
+ if(RTSflags.GranFlags.Light)
{
- TSO_LINK(ThreadQueueTl) = EVENT_TSO(event);
- ThreadQueueTl = EVENT_TSO(event);
+ ASSERT(ThreadQueueHd!=Prelude_Z91Z93_closure);
+ ASSERT(TSO_LINK(tso)==Prelude_Z91Z93_closure); /* TMP-CHG HWL */
+
+ /* If only one thread in queue so far we emit DESCHEDULE in debug mode */
+ if(RTSflags.GranFlags.granSimStats &&
+ (RTSflags.GranFlags.debug & 0x20000) &&
+ TSO_LINK(ThreadQueueHd)==Prelude_Z91Z93_closure) {
+ DumpRawGranEvent(CurrentProc,CurrentProc,GR_DESCHEDULE,
+ ThreadQueueHd,Prelude_Z91Z93_closure,0);
+ __resched = rtsTrue;
+ }
+
+ if ( InsertThread(tso) ) { /* new head of queue */
+ new_event(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
+ CONTINUETHREAD,tso,Prelude_Z91Z93_closure,NULL);
+
+ }
+ if(RTSflags.GranFlags.granSimStats &&
+ !(( event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
+ DumpRawGranEvent(CurrentProc,creator,event_type,
+ tso,node,
+ TSO_SPARKNAME(tso));
+ /* ^^^ SN (spark name) as optional info */
+ /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
+ /* ^^^ spark length as optional info */
+
+ /* MAKE_BUSY(CurrentProc); */
+ return;
+ }
+
+ /* Only for Pri Sparking */
+ if (RTSflags.GranFlags.DoPriorityScheduling && TSO_PRI(tso)!=0)
+ /* {add_to_spark_queue}vo' jInIHta'; Qu' wa'DIch yIleghQo' */
+ for (prev = ThreadQueueHd, next = TSO_LINK(ThreadQueueHd), count=0;
+ (next != Prelude_Z91Z93_closure) &&
+ !(found = (TSO_PRI(tso) >= TSO_PRI(next)));
+ prev = next, next = TSO_LINK(next), count++)
+ {}
+
+
+ ASSERT(!IS_IDLE(CurrentProc));
+
+ /* found can only be rtsTrue if pri sparking enabled */
+ if (found) {
+# if defined(GRAN_CHECK)
+ ++non_end_add_threads;
+# endif
+ /* Add tso to ThreadQueue between prev and next */
+ TSO_LINK(tso) = next;
+ if ( next == Prelude_Z91Z93_closure ) {
+ ThreadQueueTl = tso;
+ } else {
+ /* no back link for TSO chain */
+ }
+
+ if ( prev == Prelude_Z91Z93_closure ) {
+ /* Never add TSO as first elem of thread queue; the first */
+ /* element should be the one that is currently running -- HWL */
+# if defined(GRAN_CHECK)
+ fprintf(stderr,"Qagh: NewThread (w/ PriorityScheduling): Trying to add TSO %#lx (PRI=%d) as first elem of threadQ (%#lx) on proc %u (@ %u)\n",
+ tso, TSO_PRI(tso), ThreadQueueHd, CurrentProc,
+ CurrentTime[CurrentProc]);
+# endif
+ } else {
+ TSO_LINK(prev) = tso;
+ }
+ } else { /* !found */ /* or not pri sparking! */
+ /* Add TSO to the end of the thread queue on that processor */
+ TSO_LINK(ThreadQueueTl) = EVENT_TSO(event);
+ ThreadQueueTl = EVENT_TSO(event);
+ }
+ CurrentTime[CurrentProc] += count *
+ RTSflags.GranFlags.gran_pri_sched_overhead +
+ RTSflags.GranFlags.gran_threadqueuetime;
+
+ if(RTSflags.GranFlags.DoThreadMigration)
+ ++SurplusThreads;
+
+ if(RTSflags.GranFlags.granSimStats &&
+ !(( event_type == GR_START || event_type == GR_STARTQ) && RTSflags.GranFlags.labelling) )
+ DumpRawGranEvent(CurrentProc,creator,event_type+1,
+ tso,node,
+ TSO_SPARKNAME(tso));
+ /* ^^^ SN (spark name) as optional info */
+ /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
+ /* ^^^ spark length as optional info */
+
+# if defined(GRAN_CHECK)
+ /* Check if thread queue is sorted. Only for testing, really! HWL */
+ if ( RTSflags.GranFlags.DoPriorityScheduling && (RTSflags.GranFlags.debug & 0x400) ) {
+ rtsBool sorted = rtsTrue;
+ P_ prev, next;
+
+ if (ThreadQueueHd==Prelude_Z91Z93_closure || TSO_LINK(ThreadQueueHd)==Prelude_Z91Z93_closure) {
+ /* just 1 elem => ok */
+ } else {
+ /* Qu' wa'DIch yIleghQo' (ignore first elem)! */
+ for (prev = TSO_LINK(ThreadQueueHd), next = TSO_LINK(prev);
+ (next != Prelude_Z91Z93_closure) ;
+ prev = next, next = TSO_LINK(prev)) {
+ sorted = sorted &&
+ (TSO_PRI(prev) >= TSO_PRI(next));
+ }
+ }
+ if (!sorted) {
+ fprintf(stderr,"Qagh: THREADQ on PE %d is not sorted:\n",
+ CurrentProc);
+ G_THREADQ(ThreadQueueHd,0x1);
+ }
+ }
+# endif
- if(DoThreadMigration)
- ++SurplusThreads;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadqueuetime;
+}
+\end{code}
+
+@InsertThread@, which is only used for GranSim Light, is similar to
+@StartThread@ in that it adds a TSO to a thread queue. However, it assumes
+that the thread queue is sorted by local clocks and it inserts the TSO at the
+right place in the queue. Don't create any event, just insert.
+
+\begin{code}
+rtsBool
+InsertThread(tso)
+P_ tso;
+{
+ P_ prev, next;
+ I_ count = 0;
+ rtsBool found = rtsFalse;
+
+# if defined(GRAN_CHECK)
+ if ( !RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh {InsertThread}Daq: InsertThread should only be used in a GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEvent(event_type+1,EVENT_TSO(event));
+ if ( RTSflags.GranFlags.Light && CurrentProc!=0 ) {
+ fprintf(stderr,"Qagh {StartThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ /* Idle proc; same for pri spark and basic version */
+ if(ThreadQueueHd==Prelude_Z91Z93_closure)
+ {
+ ThreadQueueHd = ThreadQueueTl = tso;
+ /* MAKE_BUSY(CurrentProc); */
+ return (rtsTrue);
}
- CurrentTime[CurrentProc] += gran_threadqueuetime;
+
+ for (prev = ThreadQueueHd, next = TSO_LINK(ThreadQueueHd), count=0;
+ (next != Prelude_Z91Z93_closure) &&
+ !(found = (TSO_CLOCK(tso) < TSO_CLOCK(next)));
+ prev = next, next = TSO_LINK(next), count++)
+ {}
+
+ /* found can only be rtsTrue if pri sparking enabled */
+ if (found) {
+ /* Add tso to ThreadQueue between prev and next */
+ TSO_LINK(tso) = next;
+ if ( next == Prelude_Z91Z93_closure ) {
+ ThreadQueueTl = tso;
+ } else {
+ /* no back link for TSO chain */
+ }
+
+ if ( prev == Prelude_Z91Z93_closure ) {
+ ThreadQueueHd = tso;
+ } else {
+ TSO_LINK(prev) = tso;
+ }
+ } else { /* !found */ /* or not pri sparking! */
+ /* Add TSO to the end of the thread queue on that processor */
+ TSO_LINK(ThreadQueueTl) = tso;
+ ThreadQueueTl = tso;
+ }
+ return (prev == Prelude_Z91Z93_closure);
}
+
\end{code}
-Export work to idle PEs.
+Export work to idle PEs. This function is called from @ReSchedule@ before
+ dispatching on the current event. @HandleIdlePEs@ iterates over all PEs,
+trying to get work for idle PEs. Note, that this is a simplification
+compared to GUM's fishing model. We try to compensate for that by making
+the cost for stealing work dependent on the number of idle processors and
+thereby on the probability with which a randomly sent fish would find work.
\begin{code}
HandleIdlePEs()
{
PROC proc;
- if(ANY_IDLE && (SparksAvail > 0l || SurplusThreads > 0l))
- for(proc = 0; proc < max_proc; proc++)
- if(IS_IDLE(proc))
- {
- if(DoStealThreadsFirst &&
- (FetchStrategy >= 4 || OutstandingFetches[proc] == 0))
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh {HandleIdlePEs}Daq: Should never be entered in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
+ if(ANY_IDLE)
+ for(proc = 0; proc < RTSflags.GranFlags.proc; proc++)
+ if(IS_IDLE(proc)) /* && IS_SPARKING(proc) && IS_STARTING(proc) */
+ /* First look for local work! */
+ if (PendingSparksHd[proc][ADVISORY_POOL]!=NULL)
+ {
+ new_event(proc,proc,CurrentTime[proc],
+ FINDWORK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,NULL);
+ MAKE_SPARKING(proc);
+ }
+ /* Then try to get remote work! */
+ else if ((RTSflags.GranFlags.max_fishes==0 ||
+ OutstandingFishes[proc]<RTSflags.GranFlags.max_fishes) )
+
+ {
+ if(RTSflags.GranFlags.DoStealThreadsFirst &&
+ (RTSflags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[proc] == 0))
{
if (SurplusThreads > 0l) /* Steal a thread */
StealThread(proc);
}
if(SparksAvail > 0l &&
- (FetchStrategy >= 3 || OutstandingFetches[proc] == 0)) /* Steal a spark */
+ (RTSflags.GranFlags.FetchStrategy >= 3 || OutstandingFetches[proc] == 0)) /* Steal a spark */
StealSpark(proc);
- if (IS_IDLE(proc) && SurplusThreads > 0l &&
- (FetchStrategy >= 4 || OutstandingFetches[proc] == 0)) /* Steal a thread */
+ if (SurplusThreads > 0l &&
+ (RTSflags.GranFlags.FetchStrategy >= 4 || OutstandingFetches[proc] == 0)) /* Steal a thread */
StealThread(proc);
}
}
the @ADVISORY_POOL@ never from the @REQUIRED_POOL@. Eventually, this should
be changed to first steal from the former then from the latter.
+We model a sort of fishing mechanism by counting the number of sparks and
+threads we are currently stealing.
+
\begin{code}
StealSpark(proc)
PROC proc;
{
PROC p;
sparkq spark, prev, next;
- int stolen = 0;
+ rtsBool stolen = rtsFalse;
TIME times[MAX_PROC], stealtime;
unsigned ntimes=0, i, j;
+ int first_later, upb, r;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh {StealSpark}Daq: Should never be entered in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
/* times shall contain processors from which we may steal sparks */
- for(p=0; p < max_proc; ++p)
+ for(p=0; p < RTSflags.GranFlags.proc; ++p)
if(proc != p &&
PendingSparksHd[p][ADVISORY_POOL] != NULL &&
CurrentTime[p] <= CurrentTime[CurrentProc])
times[j] = temp;
}
- for(i=0; i < ntimes && !stolen; ++i)
- {
- p = times[i];
-
+ /* Choose random processor to steal spark from; first look at processors */
+ /* that are earlier than the current one (i.e. proc) */
+
+ for(first_later=0;
+ (first_later < ntimes) && (CurrentTime[times[first_later]] < CurrentTime[proc]);
+ ++first_later)
+ /* nothing */ ;
+
+ while (!stolen && (ntimes>0)) {
+ long unsigned int r, q=0;
+
+ upb = (first_later==0) ? ntimes : first_later;
+
+ if (RTSflags.GranFlags.RandomSteal) {
+ r = lrand48(); /* [0, RAND_MAX] */
+ } else {
+ r = 0;
+ }
+ /* -- ASSERT(r<=RAND_MAX); */
+ i = (unsigned int) (r % upb); /* [0, upb) */
+ /* -- ASSERT((i>=0) && (i<=upb)); */
+ p = times[i];
+ /* -- ASSERT((p>=0) && (p<MAX_PROC)); */
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x2000 )
+ fprintf(stderr,"RANDOM_STEAL: [index %u of %u] from %u (@ %lu) to %u (@ %lu) (q=%d) [rand value: %lu]\n",
+ i, ntimes, p, CurrentTime[p], proc, CurrentTime[proc], q, r);
+# endif
+
+ /* Now go through sparkq and steal the first one that should be sparked*/
for(prev=NULL, spark = PendingSparksHd[p][ADVISORY_POOL];
spark != NULL && !stolen;
spark=next)
{
next = SPARK_NEXT(spark);
- if(SHOULD_SPARK(SPARK_NODE(spark)))
+ if ((IS_IDLE(p) || procStatus[p]==Sparking || procStatus[p]==Fishing) &&
+ SPARK_NEXT(spark)==NULL)
+ {
+ /* Be social! Don't steal the only spark of an idle processor */
+ break;
+ }
+ else if(SHOULD_SPARK(SPARK_NODE(spark)))
{
/* Don't Steal local sparks */
if(!SPARK_GLOBAL(spark))
continue;
}
- SPARK_NEXT(spark) = NULL;
- CurrentTime[p] += gran_mpacktime;
+ /* Prepare message for sending spark */
+ CurrentTime[p] += RTSflags.GranFlags.gran_mpacktime;
- stealtime = (CurrentTime[p] > CurrentTime[proc]? CurrentTime[p]: CurrentTime[proc])
- + SparkStealTime();
-
- newevent(proc,p /* CurrentProc */,stealtime,
- MOVESPARK,Nil_closure,Nil_closure,spark);
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(p,(PROC)0,SP_EXPORTED,Prelude_Z91Z93_closure,
+ SPARK_NODE(spark),
+ spark_queue_len(p,ADVISORY_POOL));
- MAKE_BUSY(proc);
- stolen = 1;
- ++SPARK_GLOBAL(spark);
+ SPARK_NEXT(spark) = NULL;
+
+ stealtime = (CurrentTime[p] > CurrentTime[proc] ?
+ CurrentTime[p] :
+ CurrentTime[proc])
+ + SparkStealTime();
- if(do_sp_profile)
- DumpSparkGranEvent(SP_EXPORTED,spark);
- CurrentTime[p] += gran_mtidytime;
+ new_event(proc,p /* CurrentProc */,stealtime,
+ MOVESPARK,Prelude_Z91Z93_closure,Prelude_Z91Z93_closure,spark);
+ /* MAKE_BUSY(proc); not yet; busy when TSO in threadq */
+ stolen = rtsTrue;
+ ++OutstandingFishes[proc];
+ if (IS_IDLE(proc))
+ MAKE_FISHING(proc);
+ ++SPARK_GLOBAL(spark);
--SparksAvail;
+
+ CurrentTime[p] += RTSflags.GranFlags.gran_mtidytime;
}
- else
+ else /* !(SHOULD_SPARK(SPARK_NODE(spark))) */
{
- if(do_sp_profile)
- DumpSparkGranEvent(SP_PRUNED,spark);
+ if(RTSflags.GranFlags.granSimStats_Sparks)
+ DumpRawGranEvent(p,(PROC)0,SP_PRUNED,Prelude_Z91Z93_closure,
+ SPARK_NODE(spark),
+ spark_queue_len(p,ADVISORY_POOL));
+ --SparksAvail;
DisposeSpark(spark);
}
if(prev!=NULL)
SPARK_NEXT(prev) = next;
- }
+ } /* for (spark=... iterating over sparkq */
if(PendingSparksHd[p][ADVISORY_POOL] == NULL)
PendingSparksTl[p][ADVISORY_POOL] = NULL;
+
+ if (!stolen && (ntimes>0)) { /* nothing stealable from proc p :( */
+ ASSERT(times[i]==p);
+
+ /* remove p from the list (at pos i) */
+ for (j=i; j+1<ntimes; j++)
+ times[j] = times[j+1];
+ ntimes--;
+
+ /* update index to first proc which is later (or equal) than proc */
+ for ( ;
+ (first_later>0) &&
+ (CurrentTime[times[first_later-1]]>CurrentTime[proc]);
+ first_later--)
+ /* nothing */ ;
+ }
+ } /* while */
+# if defined(GRAN_CHECK)
+ if (stolen && (i!=0)) { /* only for statistics */
+ rs_sp_count++;
+ ntimes_total += ntimes;
+ fl_total += first_later;
+ no_of_steals++;
}
+# endif
}
\end{code}
PROC proc;
{
PROC p;
+ rtsBool found;
P_ thread, prev;
TIME times[MAX_PROC], stealtime;
unsigned ntimes=0, i, j;
+ int first_later, upb, r;
/* Hunt for a thread */
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh {StealThread}: Should never be entered in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
/* times shall contain processors from which we may steal threads */
- for(p=0; p < max_proc; ++p)
- if(proc != p && RunnableThreadsHd[p] != Nil_closure &&
+ for(p=0; p < RTSflags.GranFlags.proc; ++p)
+ if(proc != p && RunnableThreadsHd[p] != Prelude_Z91Z93_closure &&
CurrentTime[p] <= CurrentTime[CurrentProc])
times[ntimes++] = p;
times[j] = temp;
}
- for(i=0; i < ntimes; ++i)
- {
- p = times[i];
-
+ /* Choose random processor to steal spark from; first look at processors */
+ /* that are earlier than the current one (i.e. proc) */
+
+ for(first_later=0;
+ (first_later < ntimes) && (CurrentTime[times[first_later]] < CurrentTime[proc]);
+ ++first_later)
+ /* nothing */ ;
+
+ while (!found && (ntimes>0)) {
+ long unsigned int r, q=0;
+
+ upb = (first_later==0) ? ntimes : first_later;
+
+ if (RTSflags.GranFlags.RandomSteal) {
+ r = lrand48(); /* [0, RAND_MAX] */
+ } else {
+ r = 0;
+ }
+ /* -- ASSERT(r<=RAND_MAX); */
+ if ( RTSflags.GranFlags.debug & 0x2000 )
+ fprintf(stderr,"rand value: %d " , r);
+ i = (unsigned int) (r % upb); /* [0, upb] */
+ /* -- ASSERT((i>=0) && (i<=upb)); */
+ p = times[i];
+ /* -- ASSERT((p>=0) && (p<MAX_PROC)); */
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x2000 )
+ fprintf(stderr,"RANDOM_STEAL; [index %u] from %u (@ %lu) to %u (@ %lu) (q=%d)\n",
+ i, p, CurrentTime[p], proc, CurrentTime[proc], q);
+# endif
+
/* Steal the first exportable thread in the runnable queue after the */
/* first one */
- if(RunnableThreadsHd[p] != Nil_closure)
+ if(RunnableThreadsHd[p] != Prelude_Z91Z93_closure)
{
for(prev = RunnableThreadsHd[p], thread = TSO_LINK(RunnableThreadsHd[p]);
- thread != Nil_closure && TSO_LOCKED(thread);
+ thread != Prelude_Z91Z93_closure && TSO_LOCKED(thread);
prev = thread, thread = TSO_LINK(thread))
/* SKIP */;
- if(thread != Nil_closure) /* Take thread out of runnable queue */
+ if(thread != Prelude_Z91Z93_closure) /* Take thread out of runnable queue */
{
TSO_LINK(prev) = TSO_LINK(thread);
- TSO_LINK(thread) = Nil_closure;
+ TSO_LINK(thread) = Prelude_Z91Z93_closure;
if(RunnableThreadsTl[p] == thread)
RunnableThreadsTl[p] = prev;
/* Turn magic constants into params !? -- HWL */
- CurrentTime[p] += 5l * gran_mpacktime;
+ CurrentTime[p] += 5l * RTSflags.GranFlags.gran_mpacktime;
- stealtime = (CurrentTime[p] > CurrentTime[proc]? CurrentTime[p]: CurrentTime[proc])
- + SparkStealTime() + 4l * gran_additional_latency
- + 5l * gran_munpacktime;
+ stealtime = (CurrentTime[p] > CurrentTime[proc] ?
+ CurrentTime[p] :
+ CurrentTime[proc])
+ + SparkStealTime()
+ + 4l * RTSflags.GranFlags.gran_additional_latency
+ + 5l * RTSflags.GranFlags.gran_munpacktime;
- /* Move the thread */
- SET_PROCS(thread,PE_NUMBER(proc));
+ /* Move the thread; set bitmask to 0 while TSO is `on-the-fly' */
+ SET_PROCS(thread,Nowhere /* PE_NUMBER(proc) */);
/* Move from one queue to another */
- newevent(proc,p,stealtime,MOVETHREAD,thread,Nil_closure,NULL);
- MAKE_BUSY(proc);
+ new_event(proc,p,stealtime,MOVETHREAD,thread,Prelude_Z91Z93_closure,NULL);
+ /* MAKE_BUSY(proc); not yet; only when thread is in threadq */
+ ++OutstandingFishes[proc];
+ if (IS_IDLE(proc))
+ MAKE_FISHING(proc);
--SurplusThreads;
- if(RTSflags.ParFlags.granSimStats)
- DumpRawGranEvent(p,GR_STEALING,TSO_ID(thread));
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(p,proc,GR_STEALING,thread,
+ Prelude_Z91Z93_closure,0);
- CurrentTime[p] += 5l * gran_mtidytime;
+ CurrentTime[p] += 5l * RTSflags.GranFlags.gran_mtidytime;
/* Found one */
- break;
+ found = rtsTrue;
+ /* break; */
}
}
+
+ if (!found && (ntimes>0)) { /* nothing stealable from proc p */
+ ASSERT(times[i]==p);
+
+ /* remove p from the list (at pos i) */
+ for (j=i; j+1<ntimes; j++)
+ times[j] = times[j+1];
+ ntimes--;
+ }
+ } /* while */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if (found && (i!=0)) { /* only for statistics */
+ rs_t_count++;
}
+# endif
}
TIME SparkStealTime()
{
double fishdelay, sparkdelay, latencydelay;
- fishdelay = (double)max_proc/2;
- sparkdelay = fishdelay - ((fishdelay-1)/(double)(max_proc-1))*(double)Idlers;
- latencydelay = sparkdelay*((double)gran_latency);
+ fishdelay = (double)RTSflags.GranFlags.proc/2;
+ sparkdelay = fishdelay -
+ ((fishdelay-1)/(double)(RTSflags.GranFlags.proc-1))*(double)idlers();
+ latencydelay = sparkdelay*((double)RTSflags.GranFlags.gran_latency);
/*
fprintf(stderr,"fish delay = %g, spark delay = %g, latency delay = %g, Idlers = %u\n",
\end{code}
+
%****************************************************************************
%
\subsection[thread-execution]{Executing Threads}
%
%****************************************************************************
+First a set of functions for handling sparks and spark-queues that are
+attached to the processors. Currently, there are two spark-queues per
+processor:
+
+\begin{itemize}
+\item A queue of @REQUIRED@ sparks i.e. these sparks will be definitely
+ turned into threads ({\em non-discardable\/}). They are mainly used in concurrent
+ Haskell. We don't use them in GrAnSim.
+\item A queue of @ADVISORY@ sparks i.e. they may be turned into threads if
+ the RTS thinks that it is a good idea. However, these sparks are {\em
+ discardable}. They will be discarded if the associated closure is
+ generally not worth creating a new thread (indicated by a tag in the
+ closure) or they may be pruned during GC if there are too many sparks
+ around already.
+\end{itemize}
+
\begin{code}
EXTDATA_RO(StkO_info);
EXTDATA_RO(TSO_info);
UNVEC(EXTFUN(stopThreadDirectReturn);,EXTDATA(vtbl_stopStgWorld);)
#if defined(GRAN)
+/* ngoqvam che' {GrAnSim} */
/* Slow but relatively reliable method uses stgMallocBytes */
/* Eventually change that to heap allocated sparks. */
+/* -------------------------------------------------------------------------
+ This is the main point where handling granularity information comes into
+ play.
+ ------------------------------------------------------------------------- */
+
+#define MAX_RAND_PRI 100
+
+/*
+ Granularity info transformers.
+ Applied to the GRAN_INFO field of a spark.
+*/
+static I_ ID(I_ x) { return(x); };
+static I_ INV(I_ x) { return(-x); };
+static I_ IGNORE(I_ x) { return (0); };
+static I_ RAND(I_ x) { return ((lrand48() % MAX_RAND_PRI) + 1); }
+
+/* NB: size_info and par_info are currently unused (what a shame!) -- HWL */
+
sparkq
-NewSpark(node,name,local)
+NewSpark(node,name,gran_info,size_info,par_info,local)
P_ node;
-I_ name, local;
+I_ name, gran_info, size_info, par_info, local;
{
- sparkq newspark = (sparkq) stgMallocBytes(sizeof(struct spark), "NewSpark");
+ I_ pri;
+ sparkq newspark;
+
+ pri = RTSflags.GranFlags.RandomPriorities ? RAND(gran_info) :
+ RTSflags.GranFlags.InversePriorities ? INV(gran_info) :
+ RTSflags.GranFlags.IgnorePriorities ? IGNORE(gran_info) :
+ gran_info;
+
+ if ( RTSflags.GranFlags.SparkPriority!=0 && pri<RTSflags.GranFlags.SparkPriority ) {
+ if ( RTSflags.GranFlags.debug & 0x40 ) {
+ fprintf(stderr,"NewSpark: Ignoring spark of priority %u (SparkPriority=%u); node=0x%lx; name=%u\n",
+ pri, RTSflags.GranFlags.SparkPriority, node, name);
+ }
+ return ((sparkq)NULL);
+ }
+ newspark = (sparkq) stgMallocBytes(sizeof(struct spark), "NewSpark");
SPARK_PREV(newspark) = SPARK_NEXT(newspark) = NULL;
SPARK_NODE(newspark) = node;
- SPARK_NAME(newspark) = name;
- SPARK_GLOBAL(newspark) = !local;
+ SPARK_NAME(newspark) = (name==1) ? TSO_SPARKNAME(CurrentTSO) : name;
+ SPARK_GRAN_INFO(newspark) = pri;
+ SPARK_GLOBAL(newspark) = !local; /* Check that with parAt, parAtAbs !!*/
return(newspark);
}
-void
-DisposeSpark(spark)
-sparkq spark;
-{
- if(spark!=NULL)
- free(spark);
+/* To make casm more convenient use this function to label strategies */
+int
+set_sparkname(P_ tso, int name) {
+ if (TSO_SPARKNAME(tso) & OLD_SPARKNAME_MASK == 1) {
+ TSO_SPARKNAME(tso) &= NEW_SPARKNAME_MASK;
+ TSO_SPARKNAME(tso) = TSO_SPARKNAME(tso) >> 16;
+ TSO_SPARKNAME(tso) |= name;
+ } else {
+ TSO_SPARKNAME(tso) = (TSO_SPARKNAME(tso) & OLD_SPARKNAME_MASK) | name ;
+ }
+ if(0 && RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(CurrentProc,99,GR_START,
+ tso,Nil_closure,
+ TSO_SPARKNAME(tso));
+ /* ^^^ SN (spark name) as optional info */
+ /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
+ /* ^^^ spark length as optional info */
- --SparksAvail;
+ return(0); }
-/* Heap-allocated disposal.
+int
+reset_sparkname(P_ tso) {
+ TSO_SPARKNAME(tso) = (TSO_SPARKNAME(tso) & OLD_SPARKNAME_MASK) << 16;
+ return (0);
+}
- FREEZE_MUT_HDR(spark, ImMutArrayOfPtrs);
- SPARK_PREV(spark) = SPARK_NEXT(spark) = SPARK_NODE(spark) = Nil_closure;
+/*
+ With PrioritySparking add_to_spark_queue performs an insert sort to keep
+ the spark queue sorted. Otherwise the spark is just added to the end of
+ the queue.
*/
-}
-DisposeSparkQ(spark)
+void
+add_to_spark_queue(spark)
sparkq spark;
{
- if (spark==NULL)
+ sparkq prev, next;
+ I_ count = 0;
+ rtsBool found = rtsFalse;
+
+ if ( spark == (sparkq)NULL ) {
return;
+ }
- DisposeSparkQ(SPARK_NEXT(spark));
+ if (RTSflags.GranFlags.DoPrioritySparking && (SPARK_GRAN_INFO(spark)!=0) ) {
-#ifdef GRAN_CHECK
- if (SparksAvail < 0)
- fprintf(stderr,"DisposeSparkQ: SparksAvail<0 after disposing sparkq @ 0x%lx\n", spark);
-#endif
+ for (prev = NULL, next = PendingSparksHd[CurrentProc][ADVISORY_POOL], count=0;
+ (next != NULL) &&
+ !(found = (SPARK_GRAN_INFO(spark) >= SPARK_GRAN_INFO(next)));
+ prev = next, next = SPARK_NEXT(next), count++)
+ {}
- free(spark);
-}
+ } else { /* 'utQo' */
+
+ found = rtsFalse; /* to add it at the end */
-#endif
+ }
-/* Create a new TSO, with the specified closure to enter and thread type */
+ if (found) {
+ SPARK_NEXT(spark) = next;
+ if ( next == NULL ) {
+ PendingSparksTl[CurrentProc][ADVISORY_POOL] = spark;
+ } else {
+ SPARK_PREV(next) = spark;
+ }
+ SPARK_PREV(spark) = prev;
+ if ( prev == NULL ) {
+ PendingSparksHd[CurrentProc][ADVISORY_POOL] = spark;
+ } else {
+ SPARK_NEXT(prev) = spark;
+ }
+ } else { /* (RTSflags.GranFlags.DoPrioritySparking && !found) || !DoPrioritySparking */
+ SPARK_NEXT(spark) = NULL;
+ SPARK_PREV(spark) = PendingSparksTl[CurrentProc][ADVISORY_POOL];
+ if (PendingSparksHd[CurrentProc][ADVISORY_POOL] == NULL)
+ PendingSparksHd[CurrentProc][ADVISORY_POOL] = spark;
+ else
+ SPARK_NEXT(PendingSparksTl[CurrentProc][ADVISORY_POOL]) = spark;
+ PendingSparksTl[CurrentProc][ADVISORY_POOL] = spark;
+ }
+ ++SparksAvail;
-P_
-NewThread(topClosure, type)
-P_ topClosure;
-W_ type;
-{
- P_ stko, tso;
+ if (RTSflags.GranFlags.DoPrioritySparking) {
+ CurrentTime[CurrentProc] += count * RTSflags.GranFlags.gran_pri_spark_overhead;
+ }
- if (AvailableTSO != Nil_closure) {
- tso = AvailableTSO;
-#if defined(GRAN)
- SET_PROCS(tso,ThisPE); /* Allocate it locally! */
-#endif
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x1000 ) {
+ for (prev = NULL, next = PendingSparksHd[CurrentProc][ADVISORY_POOL];
+ (next != NULL);
+ prev = next, next = SPARK_NEXT(next))
+ {}
+ if ( (prev!=NULL) && (prev!=PendingSparksTl[CurrentProc][ADVISORY_POOL]) )
+ fprintf(stderr,"SparkQ inconsistency after adding spark %#lx: (PE %u, pool %u) PendingSparksTl (%#lx) not end of queue (%#lx)\n",
+ spark,CurrentProc,ADVISORY_POOL,
+ PendingSparksTl[CurrentProc][ADVISORY_POOL], prev);
+ }
+# endif
+
+# if defined(GRAN_CHECK)
+ /* Check if the sparkq is still sorted. Just for testing, really! */
+ if ( RTSflags.GranFlags.debug & 0x400 ) {
+ rtsBool sorted = rtsTrue;
+ sparkq prev, next;
+
+ if (PendingSparksHd[CurrentProc][ADVISORY_POOL] == NULL ||
+ SPARK_NEXT(PendingSparksHd[CurrentProc][ADVISORY_POOL]) == NULL ) {
+ /* just 1 elem => ok */
+ } else {
+ for (prev = PendingSparksHd[CurrentProc][ADVISORY_POOL],
+ next = SPARK_NEXT(PendingSparksHd[CurrentProc][ADVISORY_POOL]);
+ (next != NULL) ;
+ prev = next, next = SPARK_NEXT(next)) {
+ sorted = sorted &&
+ (SPARK_GRAN_INFO(prev) >= SPARK_GRAN_INFO(next));
+ }
+ }
+ if (!sorted) {
+ fprintf(stderr,"Warning: SPARKQ on PE %d is not sorted:\n",
+ CurrentProc);
+ G_SPARKQ(PendingSparksHd[CurrentProc][ADVISORY_POOL],1);
+ }
+ }
+# endif
+}
+
+void
+DisposeSpark(spark)
+sparkq spark;
+{
+ /* A SP_PRUNED line should be dumped when this is called from pruning or */
+ /* discarding a spark! */
+
+ if(spark!=NULL)
+ free(spark);
+
+ --SparksAvail;
+}
+
+void
+DisposeSparkQ(spark)
+sparkq spark;
+{
+ if (spark==NULL)
+ return;
+
+ DisposeSparkQ(SPARK_NEXT(spark));
+
+# ifdef GRAN_CHECK
+ if (SparksAvail < 0)
+ fprintf(stderr,"DisposeSparkQ: SparksAvail<0 after disposing sparkq @ 0x%lx\n", spark);
+# endif
+
+ free(spark);
+}
+
+#endif /* GRAN */
+\end{code}
+
+% {GrAnSim}vaD (Notes on GrAnSim) -- HWL:
+% Qu'vaD ngoq
+% NB: mayQo' wIvwI'
+
+\paragraph{Notes on GrAnSim:}
+The following routines are for handling threads. Currently, we use an
+unfair scheduling policy in GrAnSim. Thus there are no explicit functions for
+scheduling here. If other scheduling policies are added to the system that
+code should go in here.
+
+\begin{code}
+/* Create a new TSO, with the specified closure to enter and thread type */
+
+#if defined(GRAN)
+P_
+NewThread(topClosure, type, pri)
+P_ topClosure;
+W_ type;
+I_ pri;
+#else
+P_
+NewThread(topClosure, type)
+P_ topClosure;
+W_ type;
+#endif /* GRAN */
+{
+ P_ stko, tso;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light && CurrentProc!=0) {
+ fprintf(stderr,"Qagh {NewThread}Daq: CurrentProc must be 0 in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+ if (AvailableTSO != Prelude_Z91Z93_closure) {
+ tso = AvailableTSO;
+#if defined(GRAN)
+ SET_PROCS(tso,ThisPE); /* Allocate it locally! */
+#endif
AvailableTSO = TSO_LINK(tso);
} else if (SAVE_Hp + TSO_HS + TSO_CTS_SIZE > SAVE_HpLim) {
return(NULL);
SET_TSO_HDR(tso, TSO_info, CCC);
}
- TSO_LINK(tso) = Nil_closure;
+ TSO_LINK(tso) = Prelude_Z91Z93_closure;
+#if defined(GRAN)
+ TSO_PRI(tso) = pri; /* Priority of that TSO -- HWL */
+#endif
#ifdef PAR
TSO_CCC(tso) = (CostCentre)STATIC_CC_REF(CC_MAIN);
#endif
TSO_ID(tso) = threadId++;
TSO_TYPE(tso) = type;
TSO_PC1(tso) = TSO_PC2(tso) = EnterNodeCode;
- TSO_ARG1(tso) = TSO_EVENT(tso) = 0;
+ TSO_ARG1(tso) = /* TSO_ARG2(tso) = */ 0; /* FIX THIS -- HWL */
TSO_SWITCH(tso) = NULL;
#ifdef TICKY_TICKY
#if defined(GRAN) || defined(PAR)
TSO_SPARKNAME(tso) = 0;
-#if defined(GRAN)
+# if defined(GRAN)
TSO_STARTEDAT(tso) = CurrentTime[CurrentProc];
-#else
+# else
TSO_STARTEDAT(tso) = CURRENT_TIME;
-#endif
+# endif
TSO_EXPORTED(tso) = 0;
TSO_BASICBLOCKS(tso) = 0;
TSO_ALLOCS(tso) = 0;
TSO_BLOCKEDAT(tso) = 0;
TSO_GLOBALSPARKS(tso) = 0;
TSO_LOCALSPARKS(tso) = 0;
-#endif
+# if defined(GRAN)
+ if (RTSflags.GranFlags.Light)
+ TSO_CLOCK(tso) = TSO_STARTEDAT(tso); /* local clock */
+ else
+# endif
+ TSO_CLOCK(tso) = 0;
+#endif
/*
* set pc, Node (R1), liveness
*/
# ifndef PAR
if (type == T_MAIN) {
- stko = MainStkO;
+ stko = MainStkO;
} else {
# endif
- if (AvailableStack != Nil_closure) {
+ if (AvailableStack != Prelude_Z91Z93_closure) {
stko = AvailableStack;
#if defined(GRAN)
SET_PROCS(stko,ThisPE);
#endif
- AvailableStack = STKO_LINK(AvailableStack);
+ AvailableStack = STKO_LINK(AvailableStack);
} else if (SAVE_Hp + STKO_HS + RTSflags.ConcFlags.stkChunkSize > SAVE_HpLim) {
return(NULL);
} else {
+ /* ALLOC_STK(STKO_HS,STKO_CHUNK_SIZE,0); use RTSflag now*/
ALLOC_STK(STKO_HS,RTSflags.ConcFlags.stkChunkSize,0);
stko = SAVE_Hp + 1;
SAVE_Hp += STKO_HS + RTSflags.ConcFlags.stkChunkSize;
STKO_SIZE(stko) = RTSflags.ConcFlags.stkChunkSize + STKO_VHS;
STKO_SpB(stko) = STKO_SuB(stko) = STKO_BSTK_BOT(stko) + BREL(1);
STKO_SpA(stko) = STKO_SuA(stko) = STKO_ASTK_BOT(stko) + AREL(1);
- STKO_LINK(stko) = Nil_closure;
+ STKO_LINK(stko) = Prelude_Z91Z93_closure;
STKO_RETURN(stko) = NULL;
# ifndef PAR
}
SAVE_Ret = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
SAVE_StkO = stko;
- ASSERT(sanityChk_StkO(stko));
-
if (DO_QP_PROF) {
QP_Event1(do_qp_prof > 1 ? "*A" : "*G", tso);
}
+#if defined(GRAN_CHECK)
+ tot_sq_len += spark_queue_len(CurrentProc,ADVISORY_POOL);
+ tot_sq_probes++;
+#endif
return tso;
}
+
\end{code}
+In GrAnSim the @EndThread@ function is the place where statistics about the
+simulation are printed. I guess, that could be moved into @main.lc@.
+
\begin{code}
void
EndThread(STG_NO_ARGS)
{
-#ifdef PAR
+ P_ stko;
+#if defined(PAR)
TIME now = CURRENT_TIME;
#endif
+
#ifdef TICKY_TICKY
if (RTSflags.TickyFlags.showTickyStats) {
fprintf(RTSflags.TickyFlags.tickyFile,
#if defined(GRAN)
ASSERT(CurrentTSO == ThreadQueueHd);
- ThreadQueueHd = TSO_LINK(CurrentTSO);
- if(ThreadQueueHd == Nil_closure)
- ThreadQueueTl = Nil_closure;
-
- else if (DoThreadMigration)
+ if (RTSflags.GranFlags.DoThreadMigration)
--SurplusThreads;
- if (do_gr_sim)
- {
- if(TSO_TYPE(CurrentTSO)==T_MAIN)
- {
- int i;
- for(i=0; i < max_proc; ++i) {
- StgBool is_first = StgTrue;
- while(RunnableThreadsHd[i] != Nil_closure)
- {
- /* We schedule runnable threads before killing them to */
- /* make the job of bookkeeping the running, runnable, */
- /* blocked threads easier for scripts like gr2ps -- HWL */
-
- if (RTSflags.ParFlags.granSimStats && !is_first)
- DumpRawGranEvent(i,GR_SCHEDULE,
- TSO_ID(RunnableThreadsHd[i]));
- if (!no_gr_profile)
- DumpGranInfo(i,RunnableThreadsHd[i],StgTrue);
- RunnableThreadsHd[i] = TSO_LINK(RunnableThreadsHd[i]);
- is_first = StgFalse;
- }
- }
-
- ThreadQueueHd = Nil_closure;
-
-#if defined(GRAN_CHECK) && defined(GRAN)
- /* Print event stats */
- if (debug & 0x20) {
- int i;
-
- fprintf(stderr,"Statistics of events (total=%d):\n",
- noOfEvents);
- for (i=0; i<=7; i++) {
- fprintf(stderr,"> %s (%d): \t%ld \t%f%%\n",
- event_names[i],i,event_counts[i],
- (float)(100*event_counts[i])/(float)(noOfEvents) );
+ if(TSO_TYPE(CurrentTSO)==T_MAIN)
+ {
+ int i;
+ rtsBool is_first;
+ for(i=0; i < RTSflags.GranFlags.proc; ++i) {
+ is_first = rtsTrue;
+ while(RunnableThreadsHd[i] != Prelude_Z91Z93_closure)
+ {
+ /* We schedule runnable threads before killing them to */
+ /* make the job of bookkeeping the running, runnable, */
+ /* blocked threads easier for scripts like gr2ps -- HWL */
+
+ if (RTSflags.GranFlags.granSimStats && !is_first &&
+ (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
+ DumpRawGranEvent(i,(PROC)0,GR_SCHEDULE,
+ RunnableThreadsHd[i],
+ Prelude_Z91Z93_closure,0);
+ if (!RTSflags.GranFlags.granSimStats_suppressed &&
+ TSO_TYPE(RunnableThreadsHd[i])!=T_MAIN)
+ DumpGranInfo(i,RunnableThreadsHd[i],rtsTrue);
+ RunnableThreadsHd[i] = TSO_LINK(RunnableThreadsHd[i]);
+ is_first = rtsFalse;
}
- }
-#endif
-
- }
-
- if (!no_gr_profile)
- DumpGranInfo(CurrentProc,CurrentTSO,
- TSO_TYPE(CurrentTSO) != T_ADVISORY);
-
- /* Note ThreadQueueHd is Nil when the main thread terminates */
- if(ThreadQueueHd != Nil_closure)
- {
- if (RTSflags.ParFlags.granSimStats && !no_gr_profile)
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
- CurrentTime[CurrentProc] += gran_threadscheduletime;
}
-
- else if (RTSflags.ParFlags.granSimStats_Binary && TSO_TYPE(CurrentTSO)==T_MAIN &&
- !no_gr_profile)
- grterminate(CurrentTime[CurrentProc]);
- }
+
+ ThreadQueueHd = Prelude_Z91Z93_closure;
+ /* Printing of statistics has been moved into end_gr_simulation */
+ } /* ... T_MAIN */
+
+ if (RTSflags.GranFlags.labelling && RTSflags.GranFlags.granSimStats &&
+ !RTSflags.GranFlags.granSimStats_suppressed)
+ DumpStartEventAt(TSO_STARTEDAT(CurrentTSO),where_is(CurrentTSO),0,GR_START,
+ CurrentTSO,Nil_closure,
+ TSO_SPARKNAME(CurrentTSO));
+ /* ^^^ SN (spark name) as optional info */
+ /* spark_queue_len(CurrentProc,ADVISORY_POOL)); */
+ /* ^^^ spark length as optional info */
+
+ if (RTSflags.GranFlags.granSimStats &&
+ !RTSflags.GranFlags.granSimStats_suppressed)
+ DumpGranInfo(CurrentProc,CurrentTSO,
+ TSO_TYPE(CurrentTSO) != T_ADVISORY);
+
+ if (RTSflags.GranFlags.granSimStats_Binary &&
+ TSO_TYPE(CurrentTSO)==T_MAIN &&
+ !RTSflags.GranFlags.granSimStats_suppressed)
+ grterminate(CurrentTime[CurrentProc]);
+
+ if (TSO_TYPE(CurrentTSO)!=T_MAIN)
+ ActivateNextThread(CurrentProc);
+
+ /* Note ThreadQueueHd is Nil when the main thread terminates
+ if(ThreadQueueHd != Prelude_Z91Z93_closure)
+ {
+ if (RTSflags.GranFlags.granSimStats && !RTSflags.GranFlags.granSimStats_suppressed &&
+ (!RTSflags.GranFlags.Light || RTSflags.GranFlags.debug & 0x20000) )
+ DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_threadscheduletime;
+ }
+ */
+
#endif /* GRAN */
#ifdef PAR
switch (TSO_TYPE(CurrentTSO)) {
case T_MAIN:
required_thread_count--;
+
#ifdef PAR
- if (RTSflags.ParFlags.granSimStats_Binary)
+ if (GRANSIMSTATS_BINARY)
grterminate(now);
#endif
-
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( (debug & 0x80) || (debug & 0x40) )
- fprintf(stderr,"\nGRAN: I hereby terminate the main thread!\n");
-
- /* I've stolen that from the end of ReSchedule (!GRAN). HWL */
- longjmp(scheduler_loop, required_thread_count > 0 ? 1 : -1);
+#ifdef GRAN
+ longjmp(scheduler_loop, -1); /* i.e. the world comes to an end NOW */
#else
- ReSchedule(0);
-#endif /* GRAN */
+ ReSchedule(0); /* i.e. the world will eventually come to an end */
+#endif
case T_REQUIRED:
required_thread_count--;
default:
fflush(stdout);
- fprintf(stderr, "EndThread: %lx unknown\n", (W_) TSO_TYPE(CurrentTSO));
+ fprintf(stderr, "EndThread: %x unknown\n", TSO_TYPE(CurrentTSO));
EXIT(EXIT_FAILURE);
}
/* Reuse stack object space */
- ASSERT(STKO_LINK(SAVE_StkO) == Nil_closure);
+ ASSERT(STKO_LINK(SAVE_StkO) == Prelude_Z91Z93_closure);
STKO_LINK(SAVE_StkO) = AvailableStack;
AvailableStack = SAVE_StkO;
/* Reuse TSO */
TSO_LINK(CurrentTSO) = AvailableTSO;
AvailableTSO = CurrentTSO;
- CurrentTSO = Nil_closure;
+ CurrentTSO = Prelude_Z91Z93_closure;
CurrentRegTable = NULL;
#if defined(GRAN)
- /* NB: Now ThreadQueueHd is either the next runnable thread on this */
- /* proc or it's Nil_closure. In the latter case, a FINDWORK will be */
- /* issued by ReSchedule. */
- ReSchedule(SAME_THREAD); /* back for more! */
+ /* NB: Now ThreadQueueHd is either the next runnable thread on this */
+ /* proc or it's Prelude_Z91Z93_closure. In the latter case, a FINDWORK will be */
+ /* issued by ReSchedule. */
+ ReSchedule(SAME_THREAD); /* back for more! */
#else
- ReSchedule(0); /* back for more! */
+ ReSchedule(0); /* back for more! */
#endif
}
+
\end{code}
%****************************************************************************
\begin{code}
-#if defined(COUNT)
+#if defined(GRAN_COUNT)
+/* Some non-essential maybe-useful statistics-gathering */
void CountnUPDs() { ++nUPDs; }
void CountnUPDs_old() { ++nUPDs_old; }
void CountnUPDs_new() { ++nUPDs_new; }
* AwakenBlockingQueue awakens a list of TSOs and FBQs.
*/
-P_ PendingFetches = Nil_closure;
+P_ PendingFetches = Prelude_Z91Z93_closure;
void
AwakenBlockingQueue(bqe)
# endif
# ifndef PAR
- while (bqe != Nil_closure) {
+ while (bqe != Prelude_Z91Z93_closure) {
# else
while (IS_MUTABLE(INFO_PTR(bqe))) {
switch (INFO_TYPE(INFO_PTR(bqe))) {
}
# endif
if (last_tso == NULL) {
- if (RunnableThreadsHd == Nil_closure) {
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure) {
RunnableThreadsHd = bqe;
} else {
TSO_LINK(RunnableThreadsTl) = bqe;
EXIT(EXIT_FAILURE);
}
}
-#else
+# else
}
# endif
if (last_tso != NULL) {
RunnableThreadsTl = last_tso;
# ifdef PAR
- TSO_LINK(last_tso) = Nil_closure;
+ TSO_LINK(last_tso) = Prelude_Z91Z93_closure;
# endif
}
}
#ifdef GRAN
-/* NB: GRAN version only ToDo
- *
- * AwakenBlockingQueue returns True if we are on the oldmutables list,
- * so that the update code knows what to do next.
- */
+# if defined(GRAN_CHECK)
-I_
-AwakenBlockingQueue(node)
- P_ node;
+/* First some useful test functions */
+
+EXTFUN(RBH_Save_0_info);
+EXTFUN(RBH_Save_1_info);
+EXTFUN(RBH_Save_2_info);
+
+void
+PRINT_BQ(bqe)
+P_ bqe;
{
- P_ tso = (P_) BQ_ENTRIES(node);
- P_ prev;
+ W_ it;
+ P_ last = NULL;
+ char str[80], str0[80];
+
+ fprintf(stderr,"\n[PE %d] @ %lu BQ: ",
+ CurrentProc,CurrentTime[CurrentProc]);
+ if ( bqe == Prelude_Z91Z93_closure ) {
+ fprintf(stderr," NIL.\n");
+ return;
+ }
+ if ( bqe == NULL ) {
+ fprintf(stderr," NULL\n");
+ return;
+ }
+ while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
+ W_ proc; /* RBH_Save_? closures! */
+
+ /* Find where the tso lives */
+ proc = where_is(bqe);
+ it = INFO_TYPE(INFO_PTR(bqe));
- if(do_gr_sim)
+ switch (it) {
+ case INFO_TSO_TYPE:
+ strcpy(str0,"TSO");
+ break;
+ case INFO_BQ_TYPE:
+ strcpy(str0,"BQ");
+ break;
+ default:
+ strcpy(str0,"???");
+ break;
+ }
+
+ if(proc == CurrentProc)
+ fprintf(stderr," %#lx (%x) L %s,", bqe, TSO_ID(bqe), str0);
+ else
+ fprintf(stderr," %#lx (%x) G (PE %d) %s,", bqe, TSO_ID(bqe), proc, str0);
+
+ last = bqe;
+ switch (it) {
+ case INFO_TSO_TYPE:
+ bqe = TSO_LINK(bqe);
+ break;
+ case INFO_BQ_TYPE:
+ bqe = TSO_LINK(bqe);
+ break;
+ default:
+ bqe = Prelude_Z91Z93_closure;
+ break;
+ }
+ /* TSO_LINK(last_tso) = Prelude_Z91Z93_closure; */
+ }
+ if ( bqe == Prelude_Z91Z93_closure )
+ fprintf(stderr," NIL.\n");
+ else if (
+ (INFO_PTR(bqe) == (P_) RBH_Save_0_info) ||
+ (INFO_PTR(bqe) == (P_) RBH_Save_1_info) ||
+ (INFO_PTR(bqe) == (P_) RBH_Save_2_info) )
+ fprintf(stderr," RBH.\n");
+ /* fprintf(stderr,"\n%s\n",str); */
+ }
+
+rtsBool
+CHECK_BQ(node, tso, proc)
+P_ node, tso;
+PROC proc;
+{
+ P_ bqe;
+ W_ it;
+ P_ last = NULL;
+ PROC p = where_is(tso);
+ rtsBool ok = rtsTrue;
+
+ if ( p != proc) {
+ fprintf(stderr,"ERROR in CHECK_BQ: CurrentTSO %#lx (%x) on proc %d but CurrentProc = %d\n",
+ tso, TSO_ID(tso), proc);
+ ok = rtsFalse;
+ }
+
+ switch (INFO_TYPE(INFO_PTR(node))) {
+ case INFO_BH_TYPE:
+ case INFO_BH_U_TYPE:
+ bqe = (P_) BQ_ENTRIES(node);
+ return (rtsTrue); /* BHs don't have BQs */
+ break;
+ case INFO_BQ_TYPE:
+ bqe = (P_) BQ_ENTRIES(node);
+ break;
+ case INFO_FMBQ_TYPE:
+ fprintf(stderr,"CHECK_BQ: ERROR: FMBQ closure (%#lx) found in GrAnSim (TSO=%#lx (%x))\n",
+ node, tso, TSO_ID(tso));
+ EXIT(EXIT_FAILURE);
+ break;
+ case INFO_SPEC_RBH_TYPE:
+ bqe = (P_) SPEC_RBH_BQ(node);
+ break;
+ case INFO_GEN_RBH_TYPE:
+ bqe = (P_) GEN_RBH_BQ(node);
+ break;
+ default:
{
- W_ notifytime;
+ P_ info_ptr;
+ I_ size, ptrs, nonptrs, vhs;
+ char info_hdr_ty[80];
+
+ fprintf(stderr, "CHECK_BQ: thought %#lx was a black hole (IP %#lx)",
+ node, INFO_PTR(node));
+ info_ptr = get_closure_info(node,
+ &size, &ptrs, &nonptrs, &vhs,
+ info_hdr_ty);
+ fprintf(stderr, " %s\n",info_hdr_ty);
+ /* G_PRINT_NODE(node); */
+ return (rtsFalse);
+ /* EXIT(EXIT_FAILURE); */
+ }
+ }
-# if defined(COUNT)
+ while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
+ W_ proc; /* RBH_Save_? closures! */
+
+ /* Find where the tso lives */
+ proc = where_is(bqe);
+ it = INFO_TYPE(INFO_PTR(bqe));
+
+ if ( bqe == tso ) {
+ fprintf(stderr,"ERROR in CHECK_BQ [Node = 0x%lx, PE %d]: TSO %#lx (%x) already in BQ: ",
+ node, proc, tso, TSO_ID(tso));
+ PRINT_BQ(BQ_ENTRIES(node));
+ ok = rtsFalse;
+ }
+
+ bqe = TSO_LINK(bqe);
+ }
+ return (ok);
+}
+/* End of test functions */
+# endif /* GRAN_CHECK */
+
+/* This version of AwakenBlockingQueue has been originally taken from the
+ GUM code. It is now assimilated into GrAnSim */
+
+/* Note: This version assumes a pointer to a blocking queue rather than a
+ node with an attached blocking queue as input */
+
+P_
+AwakenBlockingQueue(bqe)
+P_ bqe;
+{
+ /* P_ tso = (P_) BQ_ENTRIES(node); */
+ P_ last = NULL;
+ /* P_ prev; */
+ W_ notifytime;
+
+# if 0
+ if(do_gr_sim)
+# endif
+
+ /* Compatibility mode with old libaries! 'oH jIvoQmoH */
+ if (IS_BQ_CLOSURE(bqe))
+ bqe = (P_)BQ_ENTRIES(bqe);
+ else if ( INFO_TYPE(INFO_PTR(bqe)) == INFO_SPEC_RBH_TYPE )
+ bqe = (P_)SPEC_RBH_BQ(bqe);
+ else if ( INFO_TYPE(INFO_PTR(bqe)) == INFO_GEN_RBH_TYPE )
+ bqe = (P_)GEN_RBH_BQ(bqe);
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ PRINT_BQ(bqe);
+ }
+# endif
+
+# if defined(GRAN_COUNT)
++nUPDs;
- if (tso != Nil_closure)
+ if (tso != Prelude_Z91Z93_closure)
++nUPDs_BQ;
-# endif
+# endif
- while(tso != Nil_closure) {
- W_ proc;
- ASSERT(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x100)
+ fprintf(stderr,"----- AwBQ: ");
+# endif
-# if defined(COUNT)
+ while (IS_MUTABLE(INFO_PTR(bqe))) { /* This distinguishes TSOs from */
+ W_ proc; /* RBH_Save_? closures! */
+ ASSERT(INFO_TYPE(INFO_PTR(bqe)) == INFO_TSO_TYPE);
+
+ if (DO_QP_PROF) {
+ QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
+ }
+# if defined(GRAN_COUNT)
++BQ_lens;
-# endif
+# endif
- /* Find where the tso lives */
- proc = where_is(tso);
+ /* Find where the tso lives */
+ proc = where_is(bqe);
- if(proc == CurrentProc)
- notifytime = CurrentTime[CurrentProc] + gran_lunblocktime;
- else
- {
- CurrentTime[CurrentProc] += gran_mpacktime;
- notifytime = CurrentTime[CurrentProc] + gran_gunblocktime;
- CurrentTime[CurrentProc] += gran_mtidytime;
- }
+ if(proc == CurrentProc) {
+ notifytime = CurrentTime[CurrentProc] + RTSflags.GranFlags.gran_lunblocktime;
+ } else {
+ /* A better way of handling this would be to introduce a
+ GLOBALUNBLOCK event which is created here. -- HWL */
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+ notifytime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[proc]) +
+ RTSflags.GranFlags.gran_gunblocktime;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+ /* new_event(proc, CurrentProc, notifytime,
+ GLOBALUNBLOCK,bqe,Prelude_Z91Z93_closure,NULL); */
+ }
+ /* cost the walk over the queue */
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_lunblocktime;
+ /* GrAnSim Light: make blocked TSO aware of the time that passed */
+ if (RTSflags.GranFlags.Light)
+ TSO_CLOCK(bqe) = notifytime;
+ /* and create a resume message */
+ new_event(proc, CurrentProc, notifytime,
+ RESUMETHREAD,bqe,Prelude_Z91Z93_closure,NULL);
+
+ if (notifytime<TimeOfNextEvent)
+ TimeOfNextEvent = notifytime;
+
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x100) {
+ fprintf(stderr," TSO %x (PE %d) %s,",
+ TSO_ID(bqe), proc, ( (proc==CurrentProc) ? "L" : "G") );
+ }
+# endif
- /* and create a resume message */
- newevent(proc, CurrentProc, notifytime,
- RESUMETHREAD,tso,Nil_closure,NULL);
+ last = bqe;
+ bqe = TSO_LINK(bqe);
+ TSO_LINK(last) = Prelude_Z91Z93_closure;
+ } /* while */
- prev = tso;
- tso = TSO_LINK(tso);
- TSO_LINK(prev) = Nil_closure;
- }
- }
- else
+# if 0
+ /* This was once used in a !do_gr_sim setup. Now only GrAnSim setup is */
+ /* supported. */
+ else /* Check if this is still valid for non-GrAnSim code -- HWL */
{
- if (ThreadQueueHd == Nil_closure)
- ThreadQueueHd = tso;
+ if (ThreadQueueHd == Prelude_Z91Z93_closure)
+ ThreadQueueHd = bqe;
else
- TSO_LINK(ThreadQueueTl) = tso;
+ TSO_LINK(ThreadQueueTl) = bqe;
- while(TSO_LINK(tso) != Nil_closure) {
- ASSERT(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
+ if (RunnableThreadsHd == Prelude_Z91Z93_closure)
+ RunnableThreadsHd = tso;
+ else
+ TSO_LINK(RunnableThreadsTl) = tso;
+
+
+ while(TSO_LINK(bqe) != Prelude_Z91Z93_closure) {
+ assert(TSO_INTERNAL_PTR(bqe)->rR[0].p == node);
+# if 0
if (DO_QP_PROF) {
- QP_Event2(do_qp_prof > 1 ? "RA" : "RG", tso, CurrentTSO);
+ QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
}
- tso = TSO_LINK(tso);
+# endif
+ bqe = TSO_LINK(bqe);
}
- ASSERT(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
+ assert(TSO_INTERNAL_PTR(bqe)->rR[0].p == node);
+# if 0
if (DO_QP_PROF) {
- QP_Event2(do_qp_prof > 1 ? "RA" : "RG", tso, CurrentTSO);
+ QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
}
-
- ThreadQueueTl = tso;
- }
+# endif
+ }
+# endif /* 0 */
+
+ if (RTSflags.GranFlags.debug & 0x100)
+ fprintf(stderr,".\n");
- return MUT_LINK(node) != MUT_NOT_LINKED;
+ return (bqe);
+ /* ngo' {GrAnSim}Qo' ngoq: RunnableThreadsTl = tso; */
}
-
-#endif /* GRAN only */
+#endif /* GRAN */
EXTFUN(Continue);
+
+#if defined(GRAN)
+
+/* Different interface for GRAN */
+void
+Yield(liveness)
+W_ liveness;
+{
+ SAVE_Liveness = liveness;
+ TSO_PC1(CurrentTSO) = Continue;
+ if (DO_QP_PROF) {
+ QP_Event1("GR", CurrentTSO);
+ }
+ ReSchedule(SAME_THREAD);
+}
+
+#else /* !GRAN */
+
void
Yield(args)
W_ args;
ReSchedule(args & 1);
}
+#endif /* GRAN */
\end{code}
+
%****************************************************************************
%
\subsection[gr-fetch]{Fetching Nodes (GrAnSim only)}
(from A) and its arrival at B. In that case the @FETCH@ has to be forwarded
to C.
-Currently, we only support GRIP-like single closure fetching. We plan to
-incorporate GUM-like packet fetching in the near future.
\begin{code}
#if defined(GRAN)
+/* ngoqvam che' {GrAnSim}! */
/* Fetch node "node" to processor "p" */
P_ node;
PROC from, to;
{
+ /* In case of RTSflags.GranFlags.DoGUMMFetching this fct should never be
+ entered! Instead, UnpackGraph is used in ReSchedule */
+ P_ closure;
+
ASSERT(to==CurrentProc);
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.Light ) {
+ fprintf(stderr,"Qagh {FetchNode}Daq: Should never be entered in GrAnSim Light setup\n");
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
+ if ( RTSflags.GranFlags.DoGUMMFetching ) {
+ fprintf(stderr,"Qagh: FetchNode should never be entered with DoGUMMFetching\n");
+ EXIT(EXIT_FAILURE);
+ }
+
+ /* Now fetch the children */
if (!IS_LOCAL_TO(PROCS(node),from) &&
!IS_LOCAL_TO(PROCS(node),to) )
return 1;
-
+
if(IS_NF(INFO_PTR(node))) /* Old: || IS_BQ(node) */
PROCS(node) |= PE_NUMBER(to); /* Copy node */
else
PROCS(node) = PE_NUMBER(to); /* Move node */
- /* Now fetch the children */
- if(DoGUMMFetching)
- {
- fprintf(stderr,"Sorry, GUMM fetching not yet implemented.\n");
- }
-
return 0;
}
[Should also account for multiple packets].
-------------------------------------------------- */
-void
+/* Return codes:
+ 0 ... ok (FETCHREPLY event with a buffer containing addresses of the
+ nearby graph has been scheduled)
+ 1 ... node is already local (fetched by somebody else; no event is
+ scheduled in here)
+ 2 ... fetch request has been forwrded to the PE that now contains the
+ node
+ 3 ... node is a black hole (BH, BQ or RBH); no event is scheduled, and
+ the current TSO is put into the blocking queue of that node
+ 4 ... out of heap in PackNearbyGraph; GC should be triggered in calling
+ function to guarantee that the tso and node inputs are valid
+ (they may be moved during GC).
+
+ ToDo: Symbolic return codes; clean up code (separate GUMMFetching from
+ single node fetching.
+*/
+
+I_
HandleFetchRequest(node,p,tso)
P_ node, tso;
PROC p;
{
+ ASSERT(!RTSflags.GranFlags.Light);
+
if (IS_LOCAL_TO(PROCS(node),p) ) /* Somebody else moved node already => */
- { /* start tso */
- newevent(p,CurrentProc,
- CurrentTime[CurrentProc] /* +gran_latency */,
- FETCHREPLY,tso,node,NULL); /* node needed ? */
- CurrentTime[CurrentProc] += gran_mtidytime;
+ { /* start tso */
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x100 ) {
+ P_ info_ptr;
+ I_ size, ptrs, nonptrs, vhs;
+ char info_hdr_ty[80];
+
+ info_ptr = get_closure_info(node,
+ &size, &ptrs, &nonptrs, &vhs,
+ info_hdr_ty);
+ fprintf(stderr,"Warning: HandleFetchRequest entered with local node %#lx (%s) (PE %d)\n",
+ node,info_hdr_ty,p);
+ }
+# endif
+ if (RTSflags.GranFlags.DoGUMMFetching) {
+ W_ size;
+ P_ graph;
+
+ /* Create a 1-node-buffer and schedule a FETCHREPLY now */
+ graph = PackOneNode(node, tso, &size);
+ new_event(p,CurrentProc,CurrentTime[CurrentProc],
+ FETCHREPLY,tso,graph,NULL);
+ } else {
+ new_event(p,CurrentProc,CurrentTime[CurrentProc],
+ FETCHREPLY,tso,node,NULL);
+ }
+ return (1);
}
else if (IS_LOCAL_TO(PROCS(node),CurrentProc) ) /* Is node still here? */
{
- /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
- /* Send a reply to the originator */
- CurrentTime[CurrentProc] += gran_mpacktime;
+ if(RTSflags.GranFlags.DoGUMMFetching) { /* {GUM}vo' ngoqvam vInIHta' (code from GUM) */
+ W_ size;
+ P_ graph;
+
+ if (IS_BLACK_HOLE(INFO_PTR(node))) { /* block on BH or RBH */
+ new_event(p,CurrentProc,CurrentTime[p],
+ GLOBALBLOCK,tso,node,NULL);
+ /* Note: blockFetch is done when handling GLOBALBLOCK event */
+ /* When this thread is reawoken it does the usual: it tries to
+ enter the updated node and issues a fetch if it's remote.
+ It has forgotten that it has sent a fetch already (i.e. a
+ FETCHNODE is swallowed by a BH, leaving the thread in a BQ */
+ --OutstandingFetches[p];
+ return (3);
+ }
+
+# if defined(GRAN_CHECK)
+ if (!RTSflags.GranFlags.DoReScheduleOnFetch && (tso != RunnableThreadsHd[p])) {
+ fprintf(stderr,"Qagh {HandleFetchRequest}Daq: tso 0x%lx (%x) not at head of proc %d (0x%lx)\n",
+ tso, TSO_ID(tso), p, RunnableThreadsHd[p]);
+ EXIT(EXIT_FAILURE);
+ }
+# endif
- newevent(p,CurrentProc,
- CurrentTime[CurrentProc]+gran_latency,
- FETCHREPLY,tso,node,NULL); /* node needed ? */
+ if ((graph = PackNearbyGraph(node, tso, &size)) == NULL)
+ return (4); /* out of heap */
+
+ /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
+ /* Send a reply to the originator */
+ /* ToDo: Replace that by software costs for doing graph packing! */
+ CurrentTime[CurrentProc] += size * RTSflags.GranFlags.gran_mpacktime;
+
+ new_event(p,CurrentProc,CurrentTime[CurrentProc]+RTSflags.GranFlags.gran_latency,
+ FETCHREPLY,tso,graph,NULL);
- CurrentTime[CurrentProc] += gran_mtidytime;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+ return (0);
+ } else { /* incremental (single closure) fetching */
+ /* Actual moving/copying of node is done on arrival; see FETCHREPLY */
+ /* Send a reply to the originator */
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
+
+ new_event(p,CurrentProc,CurrentTime[CurrentProc]+RTSflags.GranFlags.gran_latency,
+ FETCHREPLY,tso,node,NULL);
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
+ return (0);
+ }
}
- else
- { /* Qu'vatlh! node has been grabbed by another proc => forward */
+ else /* Qu'vatlh! node has been grabbed by another proc => forward */
+ {
PROC p_new = where_is(node);
TIME fetchtime;
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (NoForward) {
- newevent(p,p_new,
- max(CurrentTime[p_new],CurrentTime[CurrentProc])+gran_latency,
- FETCHREPLY,tso,node,NULL); /* node needed ? */
- CurrentTime[CurrentProc] += gran_mtidytime;
- return;
- }
-#endif
-
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (debug & 0x2) /* 0x2 should be somehting like DBG_PRINT_FWD */
- fprintf(stderr,"Qu'vatlh! node 0x%x has been grabbed by %d (current=%d; demander=%d) @ %d\n",
+# if defined(GRAN_CHECK)
+ if (RTSflags.GranFlags.debug & 0x2)
+ fprintf(stderr,"Qu'vatlh! node %#lx has been grabbed by PE %d (current=%d; demander=%d) @ %d\n",
node,p_new,CurrentProc,p,CurrentTime[CurrentProc]);
-#endif
+# endif
/* Prepare FORWARD message to proc p_new */
- CurrentTime[CurrentProc] += gran_mpacktime;
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mpacktime;
- fetchtime = max(CurrentTime[CurrentProc],CurrentTime[p_new]) +
- gran_latency;
+ fetchtime = STG_MAX(CurrentTime[CurrentProc],CurrentTime[p_new]) +
+ RTSflags.GranFlags.gran_latency;
- newevent(p_new,p,fetchtime,FETCHNODE,tso,node,NULL);
+ new_event(p_new,p,fetchtime,FETCHNODE,tso,node,NULL);
+
+ CurrentTime[CurrentProc] += RTSflags.GranFlags.gran_mtidytime;
- CurrentTime[CurrentProc] += gran_mtidytime;
+ return (2);
}
}
#endif
\end{code}
-%****************************************************************************
-%
-\subsection[gr-simulation]{Granularity Simulation}
-%
-%****************************************************************************
+@blockFetch@ blocks a @BlockedFetch@ node on some kind of black hole.
+
+Taken from gum/HLComms.lc. [find a better place for that ?] -- HWL
+
+{\bf Note:} In GranSim we don't have @FETCHME@ nodes and therefore don't
+create @FMBQ@'s (FetchMe blocking queues) to cope with global
+blocking. Instead, non-local TSO are put into the BQ in the same way as
+local TSOs. However, we have to check if a TSO is local or global in order
+to account for the latencies involved and for keeping track of the number
+of fetches that are really going on.
\begin{code}
-#if 0 /* moved to GranSim.lc */
#if defined(GRAN)
-I_ do_gr_sim = 0;
-FILE *gr_file = NULL;
-char gr_filename[STATS_FILENAME_MAXLEN];
-init_gr_simulation(rts_argc,rts_argv,prog_argc,prog_argv)
-char *prog_argv[], *rts_argv[];
-int prog_argc, rts_argc;
+/* Return codes:
+ 0 ... ok; tso is now at beginning of BQ attached to the bh closure
+ 1 ... the bh closure is no BH any more; tso is immediately unblocked
+*/
+
+I_
+blockFetch(tso, proc, bh)
+P_ tso; /* TSO which gets blocked */
+PROC proc; /* PE where that tso was running */
+P_ bh; /* closure to block on (BH, RBH, BQ) */
{
- I_ i;
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ P_ info_ptr;
+ I_ size, ptrs, nonptrs, vhs;
+ char info_hdr_ty[80];
+
+ info_ptr = get_closure_info(bh,
+ &size, &ptrs, &nonptrs, &vhs,
+ info_hdr_ty);
+ fprintf(stderr,"Blocking TSO %#lx (%x)(PE %d) on node %#lx (%s) (PE %d). No graph is packed!\n",
+ tso, TSO_ID(tso), proc, bh, info_hdr_ty, where_is(bh));
+ }
- if(do_gr_sim)
- {
- char *extension = RTSflags.ParFlags.granSimStats_Binary? "gb": "gr";
- sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0],extension);
+ if ( !RTSflags.GranFlags.DoReScheduleOnFetch && (tso != RunnableThreadsHd[proc]) ) {
+ fprintf(stderr,"Qagh {blockFetch}Daq: TSO 0x%lx (%x) is not first on runnable list of proc %d (first is 0x%lx)\n",
+ tso,TSO_ID(tso),proc,RunnableThreadsHd[proc]);
+ EXIT(EXIT_FAILURE);
+ }
+# endif
+
+ if (!IS_BLACK_HOLE(INFO_PTR(bh))) { /* catches BHs and RBHs */
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x100 ) {
+ P_ info;
+ W_ size, ptrs, nonptrs, vhs;
+ char str[80], junk_str[80];
+
+ info = get_closure_info(bh, &size, &ptrs, &nonptrs, &vhs, str);
+ fprintf(stderr,"blockFetch: node %#lx (%s) is not a BH => awakening TSO %#lx (%x) (PE %u)\n",
+ bh, str, tso, TSO_ID(tso), proc);
+ G_PRINT_NODE(bh);
+ }
+# endif
+ /* No BH anymore => immediately unblock tso */
+ new_event(proc,proc,CurrentTime[proc],
+ UNBLOCKTHREAD,tso,bh,NULL);
+
+ /* Is this always a REPLY to a FETCH in the profile ? */
+ if (RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(proc,proc,GR_REPLY,tso,bh,0);
+ return (1);
+ }
- if ((gr_file = fopen(gr_filename,"w")) == NULL )
- {
- fprintf(stderr, "Can't open granularity simulation report file %s\n", gr_filename);
- exit(EXIT_FAILURE);
- }
+ /* DaH {BQ}Daq Qu' Suq 'e' wISov!
+ Now we know that we have to put the tso into the BQ.
+ 2 case: If block-on-fetch, tso is at head of threadq =>
+ => take it out of threadq and into BQ
+ If reschedule-on-fetch, tso is only pointed to be event
+ => just put it into BQ
+ */
+ if (!RTSflags.GranFlags.DoReScheduleOnFetch) { /* block-on-fetch */
+ GranSimBlock(tso, proc, bh); /* get tso out of threadq & activate next
+ thread (same as in BQ_entry) */
+ } else { /* reschedule-on-fetch */
+ if(RTSflags.GranFlags.granSimStats)
+ DumpRawGranEvent(proc,where_is(bh),GR_BLOCK,tso,bh,0);
+
+ ++TSO_BLOCKCOUNT(tso);
+ TSO_BLOCKEDAT(tso) = CurrentTime[proc];
+ }
+
+ ASSERT(TSO_LINK(tso)==Prelude_Z91Z93_closure);
-#if defined(GRAN_CHECK) && defined(GRAN)
- if(DoReScheduleOnFetch)
- setbuf(gr_file,NULL);
+ /* Put tso into BQ */
+ switch (INFO_TYPE(INFO_PTR(bh))) {
+ case INFO_BH_TYPE:
+ case INFO_BH_U_TYPE:
+ TSO_LINK(tso) = Prelude_Z91Z93_closure;
+ SET_INFO_PTR(bh, BQ_info);
+ BQ_ENTRIES(bh) = (W_) tso;
+
+#ifdef GC_MUT_REQUIRED
+ /*
+ * If we modify a black hole in the old generation, we have to make
+ * sure it goes on the mutables list
+ */
+
+ if (bh <= StorageMgrInfo.OldLim) {
+ MUT_LINK(bh) = (W_) StorageMgrInfo.OldMutables;
+ StorageMgrInfo.OldMutables = bh;
+ } else
+ MUT_LINK(bh) = MUT_NOT_LINKED;
#endif
+ break;
+ case INFO_BQ_TYPE:
+ /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
+ TSO_LINK(tso) = (P_) BQ_ENTRIES(bh);
+ BQ_ENTRIES(bh) = (W_) tso;
+ break;
+ case INFO_FMBQ_TYPE:
+ fprintf(stderr,"ERROR: FMBQ closure (%#lx) found in GrAnSim (TSO=%#lx (%x))\n",
+ bh, tso, TSO_ID(tso));
+ EXIT(EXIT_FAILURE);
+ case INFO_SPEC_RBH_TYPE:
+ /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
+ TSO_LINK(tso) = (P_) SPEC_RBH_BQ(bh);
+ SPEC_RBH_BQ(bh) = (W_) tso;
+ break;
+ case INFO_GEN_RBH_TYPE:
+ /* BF_LINK(bf) = (P_) BQ_ENTRIES(bh); */
+ TSO_LINK(tso) = (P_) GEN_RBH_BQ(bh);
+ GEN_RBH_BQ(bh) = (W_) tso;
+ break;
+ default:
+ {
+ P_ info_ptr;
+ I_ size, ptrs, nonptrs, vhs;
+ char info_hdr_ty[80];
+
+ fprintf(stderr, "Panic: thought %#lx was a black hole (IP %#lx)",
+ bh, INFO_PTR(bh));
+# if defined(GRAN_CHECK)
+ info_ptr = get_closure_info(bh,
+ &size, &ptrs, &nonptrs, &vhs,
+ info_hdr_ty);
+ fprintf(stderr, " %s\n",info_hdr_ty);
+ G_PRINT_NODE(bh);
+# endif
+ EXIT(EXIT_FAILURE);
+ }
+ }
+ return (0);
+}
- fputs("Granularity Simulation for ",gr_file);
- for(i=0; i < prog_argc; ++i)
- {
- fputs(prog_argv[i],gr_file);
- fputc(' ',gr_file);
- }
-
- if(rts_argc > 0)
- {
- fputs("+RTS ",gr_file);
-
- for(i=0; i < rts_argc; ++i)
- {
- fputs(rts_argv[i],gr_file);
- fputc(' ',gr_file);
- }
- }
-
- fputs("\n\n--------------------\n\n",gr_file);
-
- fputs("General Parameters:\n\n",gr_file);
-
- fprintf(gr_file, "PEs %u, %s Scheduler, %sMigrate Threads%s\n",
- max_proc,DoFairSchedule?"Fair":"Unfair",
- DoThreadMigration?"":"Don't ",
- DoThreadMigration && DoStealThreadsFirst?" Before Sparks":"",
- DoReScheduleOnFetch?"":"Don't ");
-
- fprintf(gr_file, "%s, Fetch %s in Each Packet\n",
- SimplifiedFetch?"Simplified Fetch":(DoReScheduleOnFetch?"Reschedule on Fetch":"Block on Fetch"),
- DoGUMMFetching?"Many Closures":"Exactly One Closure");
- fprintf(gr_file, "Fetch Strategy(%u): If outstanding fetches %s\n",
- FetchStrategy,
- FetchStrategy==1?"only run runnable threads (don't create new ones":
- FetchStrategy==2?"create threads only from local sparks":
- FetchStrategy==3?"create threads from local or global sparks":
- FetchStrategy==4?"create sparks and steal threads if necessary":
- "unknown");
-
- fprintf(gr_file, "Thread Creation Time %lu, Thread Queue Time %lu\n",
- gran_threadcreatetime,gran_threadqueuetime);
- fprintf(gr_file, "Thread DeSchedule Time %lu, Thread Schedule Time %lu\n",
- gran_threaddescheduletime,gran_threadscheduletime);
- fprintf(gr_file, "Thread Context-Switch Time %lu\n",
- gran_threadcontextswitchtime);
- fputs("\n\n--------------------\n\n",gr_file);
-
- fputs("Communication Metrics:\n\n",gr_file);
- fprintf(gr_file,
- "Latency %lu (1st) %lu (rest), Fetch %lu, Notify %lu (Global) %lu (Local)\n",
- gran_latency, gran_additional_latency, gran_fetchtime,
- gran_gunblocktime, gran_lunblocktime);
- fprintf(gr_file,
- "Message Creation %lu (+ %lu after send), Message Read %lu\n",
- gran_mpacktime, gran_mtidytime, gran_munpacktime);
- fputs("\n\n--------------------\n\n",gr_file);
-
- fputs("Instruction Metrics:\n\n",gr_file);
- fprintf(gr_file,"Arith %lu, Branch %lu, Load %lu, Store %lu, Float %lu, Alloc %lu\n",
- gran_arith_cost, gran_branch_cost,
- gran_load_cost, gran_store_cost,gran_float_cost,gran_heapalloc_cost);
- fputs("\n\n++++++++++++++++++++\n\n",gr_file);
- }
-
- if(RTSflags.ParFlags.granSimStats_Binary)
- grputw(sizeof(TIME));
-
- Idlers = max_proc;
- return(0);
-}
-
-void end_gr_simulation() {
- if(do_gr_sim)
- {
- fprintf(stderr,"The simulation is finished. Look at %s for details.\n",
- gr_filename);
- fclose(gr_file);
- }
-}
-#endif /*0*/
-\end{code}
+#endif /* GRAN */
+\end{code}
%****************************************************************************
%
%****************************************************************************
\begin{code}
-#ifndef PAR
+/* ToDo: Check if this is really still used anywhere!? */
I_ do_qp_prof;
FILE *qp_file;
/* *Virtual* Time in milliseconds */
+#if !defined(GRAN)
long
qp_elapsed_time(STG_NO_ARGS)
{
return ((long) (usertime() * 1e3));
}
+#else
+long
+qp_elapsed_time(STG_NO_ARGS)
+{
+ return ((long) CurrentTime[CurrentProc] );
+}
+#endif
static void
init_qp_profiling(STG_NO_ARGS)
TSO_ID(tso1), TSO_NAME(tso1), TSO_ID(tso2), TSO_NAME(tso2));
}
-#endif /* !PAR */
\end{code}
%****************************************************************************
%
-\subsection[entry-points]{Routines directly called from Haskell world}
+\subsection[gc-GrAnSim]{Garbage collection routines for GrAnSim objects}
%
%****************************************************************************
-The @GranSim...@ rotuines in here are directly called via macros from the
-threaded world.
+Garbage collection code for the event queue. We walk the event queue
+so that if the only reference to a TSO is in some event (e.g. RESUME),
+the TSO is still preserved.
-First some auxiliary routines.
+The GC code now uses a breadth-first pruning strategy. This prevents
+the GC from keeping all sparks of the low-numbered PEs while discarding all
+sparks from high-numbered PEs. Such a depth-first pruning may have
+disastrous effects for programs that generate a huge number of sparks!
\begin{code}
-#ifdef GRAN
-/* Take the current thread off the thread queue and thereby activate the */
-/* next thread. It's assumed that the next ReSchedule after this uses */
-/* NEW_THREAD as param. */
-/* This fct is called from GranSimBlock and GranSimFetch */
-
-void
-ActivateNextThread ()
-{
-#if defined(GRAN_CHECK) && defined(GRAN)
- if(ThreadQueueHd != CurrentTSO) {
- fprintf(stderr,"Error: ThreadQueueHd != CurrentTSO in ActivateNextThread\n");
- exit(99);
- }
-#endif
-
- ThreadQueueHd = TSO_LINK(ThreadQueueHd);
- if(ThreadQueueHd==Nil_closure) {
- MAKE_IDLE(CurrentProc);
- ThreadQueueTl = Nil_closure;
- } else if (RTSflags.ParFlags.granSimStats) {
- CurrentTime[CurrentProc] += gran_threadcontextswitchtime;
- DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
- }
-}
-\end{code}
+#if defined(GRAN)
-Now the main stg-called routines:
+extern smInfo StorageMgrInfo;
-\begin{code}
-/* ------------------------------------------------------------------------ */
-/* The following GranSim... fcts are stg-called from the threaded world. */
-/* ------------------------------------------------------------------------ */
+/* Auxiliary functions needed in Save/RestoreSparkRoots if breadth-first */
+/* pruning is done. */
-/* Called from HEAP_CHK -- NB: node and liveness are junk here now.
- They are left temporarily to avoid complete recompilation.
- KH
-*/
-void
-GranSimAllocate(n,node,liveness)
-I_ n;
-P_ node;
-W_ liveness;
+static W_
+arr_and(W_ arr[], I_ max)
{
- TSO_ALLOCS(CurrentTSO) += n;
- ++TSO_BASICBLOCKS(CurrentTSO);
-
- TSO_EXECTIME(CurrentTSO) += gran_heapalloc_cost;
- CurrentTime[CurrentProc] += gran_heapalloc_cost;
-}
+ I_ i;
+ W_ res;
-/*
- Subtract the values added above, if a heap check fails and
- so has to be redone.
-*/
-void
-GranSimUnallocate(n,node,liveness)
-W_ n;
-P_ node;
-W_ liveness;
-{
- TSO_ALLOCS(CurrentTSO) -= n;
- --TSO_BASICBLOCKS(CurrentTSO);
-
- TSO_EXECTIME(CurrentTSO) -= gran_heapalloc_cost;
- CurrentTime[CurrentProc] -= gran_heapalloc_cost;
+ /* Doesn't work with max==0; but then, many things don't work in this */
+ /* special case. */
+ for (i=1, res = arr[0]; i<max; i++)
+ res &= arr[i];
+
+ return (res);
}
-void
-GranSimExec(ariths,branches,loads,stores,floats)
-W_ ariths,branches,loads,stores,floats;
+static W_
+arr_max(W_ arr[], I_ max)
{
- W_ cost = gran_arith_cost*ariths + gran_branch_cost*branches + gran_load_cost * loads +
- gran_store_cost*stores + gran_float_cost*floats;
+ I_ i;
+ W_ res;
- TSO_EXECTIME(CurrentTSO) += cost;
- CurrentTime[CurrentProc] += cost;
+ /* Doesn't work with max==0; but then, many things don't work in this */
+ /* special case. */
+ for (i=1, res = arr[0]; i<max; i++)
+ res = (arr[i]>res) ? arr[i] : res;
+
+ return (res);
}
-
/*
- Fetch the node if it isn't local
- -- result indicates whether fetch has been done.
-
- This is GRIP-style single item fetching.
+ Routines working on spark queues.
+ It would be a good idea to make that an ADT!
*/
-I_
-GranSimFetch(node /* , liveness_mask */ )
-P_ node;
-/* I_ liveness_mask; */
-{
- /* Note: once a node has been fetched, this test will be passed */
- if(!IS_LOCAL_TO(PROCS(node),CurrentProc) )
- {
- /* I suppose we shouldn't do this for CAFs? -- KH */
- /* Should reschedule if the latency is high */
- /* We should add mpacktime to the remote PE for the reply,
- but we don't know who owns the node
- */
- /* if(DYNAMIC_POINTER(node)) */ /* For 0.22; gone in 0.23 !!! */
- {
- PROC p = where_is(node);
- TIME fetchtime;
-
-#ifdef GRAN_CHECK
- if ( ( debug & 0x40 ) &&
- p == CurrentProc )
- fprintf(stderr,"GranSimFetch: Trying to fetch from own processor%u\n", p);
-#endif /* GRAN_CHECK */
-
- CurrentTime[CurrentProc] += gran_mpacktime;
-
- ++TSO_FETCHCOUNT(CurrentTSO);
- TSO_FETCHTIME(CurrentTSO) += gran_fetchtime;
-
- if (SimplifiedFetch)
- {
- FetchNode(node,CurrentProc);
- CurrentTime[CurrentProc] += gran_mtidytime+gran_fetchtime+
- gran_munpacktime;
- return(1);
- }
-
- fetchtime = max(CurrentTime[CurrentProc],CurrentTime[p]) +
- gran_latency;
-
- newevent(p,CurrentProc,fetchtime,FETCHNODE,CurrentTSO,node,NULL);
- ++OutstandingFetches[CurrentProc];
-
- /* About to block */
- TSO_BLOCKEDAT(CurrentTSO) = CurrentTime[p];
-
- if (DoReScheduleOnFetch)
- {
-
- /* Remove CurrentTSO from the queue
- -- assumes head of queue == CurrentTSO */
- if(!DoFairSchedule)
- {
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEventAndNode(GR_FETCH,CurrentTSO,node,p);
-
- ActivateNextThread();
-
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (debug & 0x10) {
- if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
- fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
- CurrentTSO,CurrentTime[CurrentProc]);
- exit (99);
- } else {
- TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
- }
-
- }
-#endif
-
- TSO_LINK(CurrentTSO) = Nil_closure;
- /* CurrentTSO = Nil_closure; */
-
- /* ThreadQueueHd is now the next TSO to schedule or NULL */
- /* CurrentTSO is pointed to by the FETCHNODE event */
- }
- else /* DoFairSchedule */
- {
- /* Remove from the tail of the thread queue */
- fprintf(stderr,"Reschedule-on-fetch is not yet compatible with fair scheduling\n");
- exit(99);
- }
- }
- else /* !DoReScheduleOnFetch */
- {
- /* Note: CurrentProc is still busy as it's blocked on fetch */
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEventAndNode(GR_FETCH,CurrentTSO,node,p);
-
-#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
- if (debug & 0x04)
- BlockedOnFetch[CurrentProc] = CurrentTSO; /*- StgTrue; -*/
-
- if (debug & 0x10) {
- if (TSO_TYPE(CurrentTSO) & FETCH_MASK_TSO) {
- fprintf(stderr,"FETCHNODE: TSO 0x%x has fetch-mask set @ %d\n",
- CurrentTSO,CurrentTime[CurrentProc]);
- exit (99);
- } else {
- TSO_TYPE(CurrentTSO) |= FETCH_MASK_TSO;
- }
-
- CurrentTSO = Nil_closure;
- }
-#endif
- }
-
- CurrentTime[CurrentProc] += gran_mtidytime;
-
- /* Rescheduling is necessary */
- NeedToReSchedule = StgTrue;
-
- return(1);
- }
- }
- return(0);
-}
-
-void
-GranSimSpark(local,node)
-W_ local;
-P_ node;
+I_
+spark_queue_len(PROC proc, I_ pool)
{
- ++SparksAvail;
- if(do_sp_profile)
- DumpSparkGranEvent(SP_SPARK,node);
-
- /* Force the PE to take notice of the spark */
- if(DoAlwaysCreateThreads)
- newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
- FINDWORK,Nil_closure,Nil_closure,NULL);
-
- if(local)
- ++TSO_LOCALSPARKS(CurrentTSO);
- else
- ++TSO_GLOBALSPARKS(CurrentTSO);
+ sparkq prev, spark; /* prev only for testing !! */
+ I_ len;
+
+ for (len = 0, prev = NULL, spark = PendingSparksHd[proc][pool];
+ spark != NULL;
+ len++, prev = spark, spark = SPARK_NEXT(spark))
+ {}
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x1000 )
+ if ( (prev!=NULL) && (prev!=PendingSparksTl[proc][pool]) )
+ fprintf(stderr,"ERROR in spark_queue_len: (PE %u, pool %u) PendingSparksTl (%#lx) not end of queue (%#lx)\n",
+ proc, pool, PendingSparksTl[proc][pool], prev);
+# endif
+
+ return (len);
}
-void
-GranSimSparkAt(spark,where,identifier)
-sparkq spark;
-P_ where; /* This should be a node; alternatively could be a GA */
-I_ identifier;
-{
- PROC p = where_is(where);
- TIME exporttime;
-
- if(do_sp_profile)
- DumpSparkGranEvent(SP_SPARKAT,SPARK_NODE(spark));
-
- CurrentTime[CurrentProc] += gran_mpacktime;
+sparkq
+delete_from_spark_queue (prev,spark) /* unlink and dispose spark */
+sparkq prev, spark;
+{ /* Global Vars: CurrentProc, SparkQueueHd, SparkQueueTl */
+ sparkq tmp;
+
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x10000 ) {
+ fprintf(stderr,"** |%#x:%#x| prev=%#x->(%#x), (%#x)<-spark=%#x->(%#x) <-(%#x)\n",
+ SparkQueueHd, SparkQueueTl,
+ prev, (prev==NULL ? 0 : SPARK_NEXT(prev)),
+ SPARK_PREV(spark), spark, SPARK_NEXT(spark),
+ (SPARK_NEXT(spark)==NULL ? 0 : SPARK_PREV(SPARK_NEXT(spark))));
+ }
+# endif
- exporttime = (CurrentTime[p] > CurrentTime[CurrentProc]?
- CurrentTime[p]: CurrentTime[CurrentProc])
- + gran_latency;
+ tmp = SPARK_NEXT(spark);
+ if (prev==NULL) {
+ SparkQueueHd = SPARK_NEXT(spark);
+ } else {
+ SPARK_NEXT(prev) = SPARK_NEXT(spark);
+ }
+ if (SPARK_NEXT(spark)==NULL) {
+ SparkQueueTl = prev;
+ } else {
+ SPARK_PREV(SPARK_NEXT(spark)) = prev;
+ }
+ if(SparkQueueHd == NULL)
+ SparkQueueTl = NULL;
+ SPARK_NEXT(spark) = NULL;
- newevent(p,CurrentProc,exporttime,MOVESPARK,Nil_closure,Nil_closure,spark);
-
- CurrentTime[CurrentProc] += gran_mtidytime;
-
- ++TSO_GLOBALSPARKS(CurrentTSO);
-}
-
-void
-GranSimBlock()
-{
- if(RTSflags.ParFlags.granSimStats)
- DumpGranEvent(GR_BLOCK,CurrentTSO);
-
- ++TSO_BLOCKCOUNT(CurrentTSO);
- TSO_BLOCKEDAT(CurrentTSO) = CurrentTime[CurrentProc];
- ActivateNextThread();
+ DisposeSpark(spark);
+
+ spark = tmp;
+# if defined(GRAN_CHECK)
+ if ( RTSflags.GranFlags.debug & 0x10000 ) {
+ fprintf(stderr,"## prev=%#x->(%#x)\n",
+ prev, (prev==NULL ? 0 : SPARK_NEXT(prev)));
+ }
+# endif
+ return (tmp);
}
-#endif /* GRAN */
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[gc-GrAnSim]{Garbage collection routines for GrAnSim objects}
-%
-%****************************************************************************
-
-Garbage collection code for the event queue. We walk the event queue
-so that if the only reference to a TSO is in some event (e.g. RESUME),
-the TSO is still preserved.
-
-\begin{code}
-#ifdef GRAN
-
-extern smInfo StorageMgrInfo;
+#if 0
+/* NB: These functions have been replaced by functions:
+ EvacuateEvents, EvacuateSparks, (in ../storage/SMcopying.lc)
+ LinkEvents, LinkSparks (in ../storage/SMcompacting.lc)
+ Thus, GrAnSim does not need additional entries in the list of roots
+ any more.
+*/
I_
SaveEventRoots(num_ptr_roots)
{
if(EVENT_TYPE(event) == RESUMETHREAD ||
EVENT_TYPE(event) == MOVETHREAD ||
+ EVENT_TYPE(event) == CONTINUETHREAD ||
+ /* EVENT_TYPE(event) >= CONTINUETHREAD1 || */
EVENT_TYPE(event) == STARTTHREAD )
StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
EVENT_TYPE(event) == FETCHREPLY )
{
StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
- StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
- }
-
+ /* In the case of packet fetching, EVENT_NODE(event) points to */
+ /* the packet (currently, malloced). The packet is just a list of */
+ /* closure addresses, with the length of the list at index 1 (the */
+ /* structure of the packet is defined in Pack.lc). */
+ if ( RTSflags.GranFlags.DoGUMMFetching && (EVENT_TYPE(event)==FETCHREPLY)) {
+ P_ buffer = (P_) EVENT_NODE(event);
+ int size = (int) buffer[PACK_SIZE_LOCN], i;
+
+ for (i = PACK_HDR_SIZE; i <= size-1; i++) {
+ StorageMgrInfo.roots[num_ptr_roots++] = (P_) buffer[i];
+ }
+ } else
+ StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
+ }
+ else if (EVENT_TYPE(event) == GLOBALBLOCK)
+ {
+ StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
+ StorageMgrInfo.roots[num_ptr_roots++] = EVENT_NODE(event);
+ }
+ else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
+ {
+ StorageMgrInfo.roots[num_ptr_roots++] = EVENT_TSO(event);
+ }
event = EVENT_NEXT(event);
}
return(num_ptr_roots);
}
+#if defined(DEPTH_FIRST_PRUNING)
+/* Is it worthwhile keeping the depth-first pruning code !? -- HWL */
+
I_
SaveSparkRoots(num_ptr_roots)
I_ num_ptr_roots;
sparkq spark, /* prev, */ disposeQ=NULL;
PROC proc;
I_ i, sparkroots=0, prunedSparks=0;
+ I_ tot_sparks[MAX_PROC], tot = 0;;
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(stderr,"D> Saving spark roots for GC ...\n");
-#endif
-
- for(proc = 0; proc < max_proc; ++proc) {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ tot_sparks[proc] = 0;
for(i = 0; i < SPARK_POOLS; ++i) {
for(/* prev = &PendingSparksHd[proc][i],*/ spark = PendingSparksHd[proc][i];
spark != NULL;
{
if(++sparkroots <= MAX_SPARKS)
{
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Saving Spark Root %d(proc: %d; pool: %d) -- 0x%lx\n",
- num_ptr_roots,proc,i,SPARK_NODE(spark));
-#endif
+ if ( RTSflags.GcFlags.giveStats )
+ if (i==ADVISORY_POOL) {
+ tot_sparks[proc]++;
+ tot++;
+ }
StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
}
else
{
- SPARK_NODE(spark) = Nil_closure;
+ SPARK_NODE(spark) = Prelude_Z91Z93_closure;
if (prunedSparks==0) {
disposeQ = spark;
/*
prunedSparks++;
}
} /* forall spark ... */
- if (prunedSparks>0) {
+ if ( (RTSflags.GcFlags.giveStats) && (prunedSparks>0) ) {
fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %d for GC purposes\n",
prunedSparks,MAX_SPARKS,proc);
if (disposeQ == PendingSparksHd[proc][i])
} /* forall i ... */
} /*forall proc .. */
+ if ( RTSflags.GcFlags.giveStats ) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Spark statistics (after pruning) (total sparks = %d):",tot);
+ for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
+ if (proc % 4 == 0)
+ fprintf(RTSflags.GcFlags.statsFile,"\n> ");
+ fprintf(RTSflags.GcFlags.statsFile,"\tPE %d: %d ",proc,tot_sparks[proc]);
+ }
+ fprintf(RTSflags.GcFlags.statsFile,".\n");
+ }
+
+ return(num_ptr_roots);
+}
+
+#else /* !DEPTH_FIRST_PRUNING */
+
+/* In case of an excessive number of sparks, depth first pruning is a Bad */
+/* Idea as we might end up with all remaining sparks on processor 0 and */
+/* none on the other processors. So, this version uses breadth first */
+/* pruning. -- HWL */
+
+I_
+SaveSparkRoots(num_ptr_roots)
+I_ num_ptr_roots;
+{
+ sparkq spark,
+ curr_spark[MAX_PROC][SPARK_POOLS];
+ PROC proc;
+ W_ allProcs = 0,
+ endQueues[SPARK_POOLS], finishedQueues[SPARK_POOLS];
+ I_ i, sparkroots=0,
+ prunedSparks[MAX_PROC][SPARK_POOLS];
+ I_ tot_sparks[MAX_PROC], tot = 0;;
+
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x40 )
+ fprintf(stderr,"D> Saving spark roots for GC ...\n");
+# endif
+
+ /* Init */
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ allProcs |= PE_NUMBER(proc);
+ tot_sparks[proc] = 0;
+ for(i = 0; i < SPARK_POOLS; ++i) {
+ curr_spark[proc][i] = PendingSparksHd[proc][i];
+ prunedSparks[proc][i] = 0;
+ endQueues[i] = 0;
+ finishedQueues[i] = 0;
+ }
+ }
+
+ /* Breadth first pruning */
+ do {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(i = 0; i < SPARK_POOLS; ++i) {
+ spark = curr_spark[proc][i];
+ if ( spark != NULL ) {
+
+ if(++sparkroots <= MAX_SPARKS)
+ {
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( (RTSflags.GranFlags.debug & 0x1000) &&
+ (RTSflags.GcFlags.giveStats) )
+ fprintf(RTSflags.GcFlags.statsFile,"Saving Spark Root %d(proc: %d; pool: %d): 0x%lx \t(info ptr=%#lx)\n",
+ num_ptr_roots,proc,i,SPARK_NODE(spark),
+ INFO_PTR(SPARK_NODE(spark)));
+# endif
+ if ( RTSflags.GcFlags.giveStats )
+ if (i==ADVISORY_POOL) {
+ tot_sparks[proc]++;
+ tot++;
+ }
+ StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
+ curr_spark[proc][i] = spark = SPARK_NEXT(spark);
+ }
+ else /* sparkroots > MAX_SPARKS */
+ {
+ if (curr_spark[proc][i] == PendingSparksHd[proc][i])
+ PendingSparksHd[proc][i] = NULL;
+ else
+ SPARK_NEXT(SPARK_PREV(curr_spark[proc][i])) = NULL;
+ PendingSparksTl[proc][i] = SPARK_PREV(curr_spark[proc][i]);
+ endQueues[i] |= PE_NUMBER(proc);
+ }
+ } else { /* spark == NULL ; actually, this only has to be done once */
+ endQueues[i] |= PE_NUMBER(proc);
+ }
+ }
+ }
+ } while (arr_and(endQueues,SPARK_POOLS) != allProcs);
+
+ /* The buffer for spark roots in StorageMgrInfo.roots is full */
+ /* now. Prune all sparks on all processor starting with */
+ /* curr_spark[proc][i]. */
+
+ do {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(i = 0; i < SPARK_POOLS; ++i) {
+ spark = curr_spark[proc][i];
+
+ if ( spark != NULL ) {
+ SPARK_NODE(spark) = Prelude_Z91Z93_closure;
+ curr_spark[proc][i] = SPARK_NEXT(spark);
+
+ prunedSparks[proc][i]++;
+ DisposeSpark(spark);
+ } else {
+ finishedQueues[i] |= PE_NUMBER(proc);
+ }
+ }
+ }
+ } while (arr_and(finishedQueues,SPARK_POOLS) != allProcs);
+
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x1000) {
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(i = 0; i < SPARK_POOLS; ++i) {
+ if ( (RTSflags.GcFlags.giveStats) && (prunedSparks[proc][i]>0)) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Discarding %lu sparks on proc %d (pool %d) for GC purposes\n",
+ prunedSparks[proc][i],proc,i);
+ }
+ }
+ }
+
+ if ( RTSflags.GcFlags.giveStats ) {
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Spark statistics (after discarding) (total sparks = %d):",tot);
+ for (proc=0; proc<RTSflags.GranFlags.proc; proc++) {
+ if (proc % 4 == 0)
+ fprintf(RTSflags.GcFlags.statsFile,"\n> ");
+ fprintf(RTSflags.GcFlags.statsFile,
+ "\tPE %d: %d ",proc,tot_sparks[proc]);
+ }
+ fprintf(RTSflags.GcFlags.statsFile,".\n");
+ }
+ }
+# endif
+
return(num_ptr_roots);
}
+#endif /* DEPTH_FIRST_PRUNING */
+
/*
GC roots must be restored in *reverse order*.
The recursion is a little ugly, but is better than
if(EVENT_TYPE(event) == RESUMETHREAD ||
EVENT_TYPE(event) == MOVETHREAD ||
+ EVENT_TYPE(event) == CONTINUETHREAD ||
+ /* EVENT_TYPE(event) >= CONTINUETHREAD1 || */
EVENT_TYPE(event) == STARTTHREAD )
EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
else if (EVENT_TYPE(event) == FETCHNODE ||
EVENT_TYPE(event) == FETCHREPLY )
{
- EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
+ if ( RTSflags.GranFlags.DoGUMMFetching && (EVENT_TYPE(event)==FETCHREPLY)) {
+ P_ buffer = (P_) EVENT_NODE(event);
+ int size = (int) buffer[PACK_SIZE_LOCN], i;
+
+ for (i = size-1; i >= PACK_HDR_SIZE; i--) {
+ buffer[i] = StorageMgrInfo.roots[--num_ptr_roots];
+ }
+ } else
+ EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
+
EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
}
+ else if (EVENT_TYPE(event) == GLOBALBLOCK)
+ {
+ EVENT_NODE(event) = StorageMgrInfo.roots[--num_ptr_roots];
+ EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
+ }
+ else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
+ {
+ EVENT_TSO(event) = StorageMgrInfo.roots[--num_ptr_roots];
+ }
}
-
return(num_ptr_roots);
}
return(RestoreEvtRoots(EventHd,num_ptr_roots));
}
+#if defined(DEPTH_FIRST_PRUNING)
+
static I_
RestoreSpkRoots(spark,num_ptr_roots,sparkroots)
sparkq spark;
{
P_ n = SPARK_NODE(spark);
SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Restoring Spark Root %d -- new: 0x%lx \n",
- num_ptr_roots,SPARK_NODE(spark));
-#endif
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( RTSflags.GranFlags.debug & 0x40 )
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Restoring Spark Root %d: 0x%lx \t(info ptr=%#lx\n",
+ num_ptr_roots,SPARK_NODE(spark),
+ INFO_PTR(SPARK_NODE(spark)));
+# endif
}
+# if defined(GRAN_CHECK) && defined(GRAN)
else
-#if defined(GRAN_CHECK) && defined(GRAN)
- if ( debug & 0x40 )
- fprintf(RTSflags.GcFlags.statsFile,"Error in RestoreSpkRoots (%d; @ spark 0x%x): More than MAX_SPARKS (%d) sparks\n",
+ if ( RTSflags.GranFlags.debug & 0x40 )
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Error in RestoreSpkRoots (%d; @ spark %#lx): More than MAX_SPARKS (%d) sparks\n",
num_ptr_roots,SPARK_NODE(spark),MAX_SPARKS);
-#endif
+# endif
}
-
return(num_ptr_roots);
}
PROC proc;
I_ i;
+#if defined(GRAN_JSM_SPARKS)
+ fprintf(stderr,"Error: RestoreSparkRoots should be never be entered in a JSM style sparks set-up\n");
+ EXIT(EXIT_FAILURE);
+#endif
+
/* NB: PROC is currently an unsigned datatype i.e. proc>=0 is always */
/* true ((PROC)-1 == (PROC)255). So we need a second clause in the head */
/* of the for loop. For i that is currently not necessary. C is really */
/* impressive in datatype abstraction! -- HWL */
- for(proc = max_proc - 1; (proc >= 0) && (proc < max_proc); --proc) {
+ for(proc = RTSflags.GranFlags.proc - 1; (proc >= 0) && (proc < RTSflags.GranFlags.proc); --proc) {
for(i = SPARK_POOLS - 1; (i >= 0) && (i < SPARK_POOLS) ; --i) {
num_ptr_roots = RestoreSpkRoots(PendingSparksHd[proc][i],num_ptr_roots,0);
}
return(num_ptr_roots);
}
-#endif /* GRAN */
-
-\end{code}
-
-%****************************************************************************
-%
-\subsection[GrAnSim-profile]{Writing profiling info for GrAnSim}
-%
-%****************************************************************************
-
-Event dumping routines.
-
-\begin{code}
-#ifdef GRAN
-
-DumpGranEvent(name,tso)
-enum gran_event_types name;
-P_ tso;
-{
- DumpRawGranEvent(CurrentProc,name,TSO_ID(tso));
-}
+#else /* !DEPTH_FIRST_PRUNING */
-DumpSparkGranEvent(name,id)
-enum gran_event_types name;
-W_ id;
+I_
+RestoreSparkRoots(num_ptr_roots)
+I_ num_ptr_roots;
{
- DumpRawGranEvent(CurrentProc,name,id);
-}
+ sparkq spark,
+ curr_spark[MAX_PROC][SPARK_POOLS];
+ PROC proc;
+ I_ i, max_len, len, pool, count,
+ queue_len[MAX_PROC][SPARK_POOLS];
-DumpGranEventAndNode(name,tso,node,proc)
-enum gran_event_types name;
-P_ tso, node;
-PROC proc;
-{
- PROC pe = CurrentProc;
- W_ id = TSO_ID(tso);
+ /* NB: PROC is currently an unsigned datatype i.e. proc>=0 is always */
+ /* true ((PROC)-1 == (PROC)255). So we need a second clause in the head */
+ /* of the for loop. For i that is currently not necessary. C is really */
+ /* impressive in datatype abstraction! -- HWL */
- if(name > GR_EVENT_MAX)
- name = GR_EVENT_MAX;
+ max_len=0;
+ for (proc=0; proc < RTSflags.GranFlags.proc; proc++) {
+ for (i=0; i<SPARK_POOLS; i++) {
+ curr_spark[proc][i] = PendingSparksTl[proc][i];
+ queue_len[proc][i] = spark_queue_len(proc,i);
+ max_len = (queue_len[proc][i]>max_len) ? queue_len[proc][i] : max_len;
+ }
+ }
- if(RTSflags.ParFlags.granSimStats_Binary)
- {
- grputw(name);
- grputw(pe);
- grputw(CurrentTime[CurrentProc]);
- grputw(id);
+ for (len=max_len; len > 0; len--){
+ for(proc = RTSflags.GranFlags.proc - 1; (proc >= 0) && (proc < RTSflags.GranFlags.proc); --proc) {
+ for(i = SPARK_POOLS - 1; (i >= 0) && (i < SPARK_POOLS) ; --i) {
+ if (queue_len[proc][i]>=len) {
+ spark = curr_spark[proc][i];
+ SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
+# if defined(GRAN_CHECK) && defined(GRAN)
+ count++;
+ if ( (RTSflags.GranFlags.debug & 0x1000) &&
+ (RTSflags.GcFlags.giveStats) )
+ fprintf(RTSflags.GcFlags.statsFile,
+ "Restoring Spark Root %d (PE %u, pool %u): 0x%lx \t(info ptr=%#lx)\n",
+ num_ptr_roots,proc,i,SPARK_NODE(spark),
+ INFO_PTR(SPARK_NODE(spark)));
+# endif
+ curr_spark[proc][i] = SPARK_PREV(spark);
+ /*
+ num_ptr_roots = RestoreSpkRoots(PendingSparksHd[proc][i],
+ num_ptr_roots,0);
+ */
+ }
+ }
}
- else
- fprintf(gr_file,"PE %2u [%lu]: %s %lx \t0x%lx\t(from %2u)\n",
- pe,CurrentTime[CurrentProc],gran_event_names[name],id,node,proc);
+ }
+# if defined(GRAN_CHECK) && defined(GRAN)
+ if ( (RTSflags.GranFlags.debug & 0x1000) && (RTSflags.GcFlags.giveStats) )
+ fprintf(RTSflags.GcFlags.statsFile,"Number of restored spark roots: %d\n",
+ count);
+# endif
+ return(num_ptr_roots);
}
-DumpRawGranEvent(pe,name,id)
-PROC pe;
-enum gran_event_types name;
-W_ id;
-{
- if(name > GR_EVENT_MAX)
- name = GR_EVENT_MAX;
+#endif /* DEPTH_FIRST_PRUNING */
- if(RTSflags.ParFlags.granSimStats_Binary)
- {
- grputw(name);
- grputw(pe);
- grputw(CurrentTime[CurrentProc]);
- grputw(id);
- }
- else
- fprintf(gr_file,"PE %2u [%lu]: %s %lx\n",
- pe,CurrentTime[CurrentProc],gran_event_names[name],id);
-}
+#endif /* 0 */
-DumpGranInfo(pe,tso,mandatory_thread)
-PROC pe;
-P_ tso;
-I_ mandatory_thread;
-{
- if(RTSflags.ParFlags.granSimStats_Binary)
- {
- grputw(GR_END);
- grputw(pe);
- grputw(CurrentTime[CurrentProc]);
- grputw(TSO_ID(tso));
- grputw(TSO_SPARKNAME(tso));
- grputw(TSO_STARTEDAT(tso));
- grputw(TSO_EXPORTED(tso));
- grputw(TSO_BASICBLOCKS(tso));
- grputw(TSO_ALLOCS(tso));
- grputw(TSO_EXECTIME(tso));
- grputw(TSO_BLOCKTIME(tso));
- grputw(TSO_BLOCKCOUNT(tso));
- grputw(TSO_FETCHTIME(tso));
- grputw(TSO_FETCHCOUNT(tso));
- grputw(TSO_LOCALSPARKS(tso));
- grputw(TSO_GLOBALSPARKS(tso));
- grputw(mandatory_thread);
- }
- else
- {
- /* NB: DumpGranEvent cannot be used because PE may be wrong (as well as the extra info) */
- fprintf(gr_file,"PE %2u [%lu]: END %lx, SN %lu, ST %lu, EXP %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu), LS %lu, GS %lu, MY %c\n"
- ,pe
- ,CurrentTime[CurrentProc]
- ,TSO_ID(tso)
- ,TSO_SPARKNAME(tso)
- ,TSO_STARTEDAT(tso)
- ,TSO_EXPORTED(tso)?'T':'F'
- ,TSO_BASICBLOCKS(tso)
- ,TSO_ALLOCS(tso)
- ,TSO_EXECTIME(tso)
- ,TSO_BLOCKTIME(tso)
- ,TSO_BLOCKCOUNT(tso)
- ,TSO_FETCHTIME(tso)
- ,TSO_FETCHCOUNT(tso)
- ,TSO_LOCALSPARKS(tso)
- ,TSO_GLOBALSPARKS(tso)
- ,mandatory_thread?'T':'F'
- );
- }
-}
-
-DumpTSO(tso)
-P_ tso;
-{
- fprintf(stderr,"TSO 0x%lx, NAME 0x%lx, ID %lu, LINK 0x%lx, TYPE %s\n"
- ,tso
- ,TSO_NAME(tso)
- ,TSO_ID(tso)
- ,TSO_LINK(tso)
- ,TSO_TYPE(tso)==T_MAIN?"MAIN":
- TSO_TYPE(tso)==T_FAIL?"FAIL":
- TSO_TYPE(tso)==T_REQUIRED?"REQUIRED":
- TSO_TYPE(tso)==T_ADVISORY?"ADVISORY":
- "???"
- );
-
- fprintf(stderr,"PC (0x%lx,0x%lx), ARG (0x%lx,0x%lx), SWITCH %lx0x\n"
- ,TSO_PC1(tso)
- ,TSO_PC2(tso)
- ,TSO_ARG1(tso)
- ,TSO_ARG2(tso)
- ,TSO_SWITCH(tso)
- );
-
- fprintf(gr_file,"SN %lu, ST %lu, GBL %c, BB %lu, HA %lu, RT %lu, BT %lu (%lu), FT %lu (%lu) LS %lu, GS %lu\n"
- ,TSO_SPARKNAME(tso)
- ,TSO_STARTEDAT(tso)
- ,TSO_EXPORTED(tso)?'T':'F'
- ,TSO_BASICBLOCKS(tso)
- ,TSO_ALLOCS(tso)
- ,TSO_EXECTIME(tso)
- ,TSO_BLOCKTIME(tso)
- ,TSO_BLOCKCOUNT(tso)
- ,TSO_FETCHTIME(tso)
- ,TSO_FETCHCOUNT(tso)
- ,TSO_LOCALSPARKS(tso)
- ,TSO_GLOBALSPARKS(tso)
- );
-}
-
-/*
- Output a terminate event and an 8-byte time.
-*/
-
-grterminate(v)
-TIME v;
-{
- DumpGranEvent(GR_TERMINATE,0);
-
- if(sizeof(TIME)==4)
- {
- putc('\0',gr_file);
- putc('\0',gr_file);
- putc('\0',gr_file);
- putc('\0',gr_file);
- }
- else
- {
- putc(v >> 56l,gr_file);
- putc((v >> 48l)&0xffl,gr_file);
- putc((v >> 40l)&0xffl,gr_file);
- putc((v >> 32l)&0xffl,gr_file);
- }
- putc((v >> 24l)&0xffl,gr_file);
- putc((v >> 16l)&0xffl,gr_file);
- putc((v >> 8l)&0xffl,gr_file);
- putc(v&0xffl,gr_file);
-}
-
-/*
- Length-coded output: first 3 bits contain length coding
-
- 00x 1 byte
- 01x 2 bytes
- 10x 4 bytes
- 110 8 bytes
- 111 5 or 9 bytes
-*/
-
-grputw(v)
-TIME v;
-{
- if(v <= 0x3fl)
- {
- fputc(v & 0x3f,gr_file);
- }
-
- else if (v <= 0x3fffl)
- {
- fputc((v >> 8l)|0x40l,gr_file);
- fputc(v&0xffl,gr_file);
- }
-
- else if (v <= 0x3fffffffl)
- {
- fputc((v >> 24l)|0x80l,gr_file);
- fputc((v >> 16l)&0xffl,gr_file);
- fputc((v >> 8l)&0xffl,gr_file);
- fputc(v&0xffl,gr_file);
- }
-
- else if (sizeof(TIME) == 4)
- {
- fputc(0x70,gr_file);
- fputc((v >> 24l)&0xffl,gr_file);
- fputc((v >> 16l)&0xffl,gr_file);
- fputc((v >> 8l)&0xffl,gr_file);
- fputc(v&0xffl,gr_file);
- }
-
- else
- {
- if (v <= 0x3fffffffffffffl)
- putc((v >> 56l)|0x60l,gr_file);
- else
- {
- putc(0x70,gr_file);
- putc((v >> 56l)&0xffl,gr_file);
- }
-
- putc((v >> 48l)&0xffl,gr_file);
- putc((v >> 40l)&0xffl,gr_file);
- putc((v >> 32l)&0xffl,gr_file);
- putc((v >> 24l)&0xffl,gr_file);
- putc((v >> 16l)&0xffl,gr_file);
- putc((v >> 8l)&0xffl,gr_file);
- putc(v&0xffl,gr_file);
- }
-}
#endif /* GRAN */
+#endif /* CONCURRENT */ /* the whole module! */
\end{code}
-%****************************************************************************
-%
-\subsection[GrAnSim-debug]{Debugging routines for GrAnSim}
-%
-%****************************************************************************
-
-Debugging routines, mainly for GrAnSim. They should really be in a separate file.
-
-The first couple of routines are general ones (look also into
-c-as-asm/StgDebug.lc).
-
-\begin{code}
-
-#define NULL_REG_MAP /* Not threaded */
-#include "stgdefs.h"
-
-char *
-info_hdr_type(info_ptr)
-W_ info_ptr;
-{
-#if ! defined(PAR) && !defined(GRAN)
- switch (INFO_TAG(info_ptr))
- {
- case INFO_OTHER_TAG:
- return("OTHER_TAG");
-/* case INFO_IND_TAG:
- return("IND_TAG");
-*/ default:
- return("TAG<n>");
- }
-#else /* PAR */
- switch(INFO_TYPE(info_ptr))
- {
- case INFO_SPEC_U_TYPE:
- return("SPECU");
-
- case INFO_SPEC_N_TYPE:
- return("SPECN");
-
- case INFO_GEN_U_TYPE:
- return("GENU");
-
- case INFO_GEN_N_TYPE:
- return("GENN");
-
- case INFO_DYN_TYPE:
- return("DYN");
-
- /*
- case INFO_DYN_TYPE_N:
- return("DYNN");
-
- case INFO_DYN_TYPE_U:
- return("DYNU");
- */
-
- case INFO_TUPLE_TYPE:
- return("TUPLE");
-
- case INFO_DATA_TYPE:
- return("DATA");
-
- case INFO_MUTUPLE_TYPE:
- return("MUTUPLE");
-
- case INFO_IMMUTUPLE_TYPE:
- return("IMMUTUPLE");
-
- case INFO_STATIC_TYPE:
- return("STATIC");
-
- case INFO_CONST_TYPE:
- return("CONST");
-
- case INFO_CHARLIKE_TYPE:
- return("CHAR");
-
- case INFO_INTLIKE_TYPE:
- return("INT");
-
- case INFO_BH_TYPE:
- return("BHOLE");
-
- case INFO_IND_TYPE:
- return("IND");
-
- case INFO_CAF_TYPE:
- return("CAF");
-
- case INFO_FETCHME_TYPE:
- return("FETCHME");
-
- case INFO_BQ_TYPE:
- return("BQ");
-
- /*
- case INFO_BQENT_TYPE:
- return("BQENT");
- */
-
- case INFO_TSO_TYPE:
- return("TSO");
-
- case INFO_STKO_TYPE:
- return("STKO");
-
- default:
- fprintf(stderr,"Unknown header type %lu\n",INFO_TYPE(info_ptr));
- return("??");
- }
-#endif /* PAR */
-}
-
-/*
-@var_hdr_size@ computes the size of the variable header for a closure.
-*/
-
-I_
-var_hdr_size(node)
-P_ node;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE: return(0); /* by decree */
- case INFO_SPEC_N_TYPE: return(0);
- case INFO_GEN_U_TYPE: return(GEN_VHS);
- case INFO_GEN_N_TYPE: return(GEN_VHS);
- case INFO_DYN_TYPE: return(DYN_VHS);
- /*
- case INFO_DYN_TYPE_N: return(DYN_VHS);
- case INFO_DYN_TYPE_U: return(DYN_VHS);
- */
- case INFO_TUPLE_TYPE: return(TUPLE_VHS);
- case INFO_DATA_TYPE: return(DATA_VHS);
- case INFO_MUTUPLE_TYPE: return(MUTUPLE_VHS);
- case INFO_IMMUTUPLE_TYPE: return(MUTUPLE_VHS); /* same layout */
- case INFO_STATIC_TYPE: return(STATIC_VHS);
- case INFO_CONST_TYPE: return(0);
- case INFO_CHARLIKE_TYPE: return(0);
- case INFO_INTLIKE_TYPE: return(0);
- case INFO_BH_TYPE: return(0);
- case INFO_IND_TYPE: return(0);
- case INFO_CAF_TYPE: return(0);
- case INFO_FETCHME_TYPE: return(0);
- case INFO_BQ_TYPE: return(0);
- /*
- case INFO_BQENT_TYPE: return(0);
- */
- case INFO_TSO_TYPE: return(TSO_VHS);
- case INFO_STKO_TYPE: return(STKO_VHS);
- default:
- fprintf(stderr,"Unknown info type 0x%lx (%lu)\n", INFO_PTR(node),
- INFO_TYPE(INFO_PTR(node)));
- return(0);
- }
-}
-
-
-/* Determine the size and number of pointers for this kind of closure */
-void
-size_and_ptrs(node,size,ptrs)
-P_ node;
-W_ *size, *ptrs;
-{
- switch(INFO_TYPE(INFO_PTR(node)))
- {
- case INFO_SPEC_U_TYPE:
- case INFO_SPEC_N_TYPE:
- *size = INFO_SIZE(INFO_PTR(node)); /* New for 0.24; check */
- *ptrs = INFO_NoPTRS(INFO_PTR(node)); /* that! -- HWL */
- /*
- *size = SPEC_CLOSURE_SIZE(node);
- *ptrs = SPEC_CLOSURE_NoPTRS(node);
- */
- break;
-
- case INFO_GEN_U_TYPE:
- case INFO_GEN_N_TYPE:
- *size = GEN_CLOSURE_SIZE(node);
- *ptrs = GEN_CLOSURE_NoPTRS(node);
- break;
-
- /*
- case INFO_DYN_TYPE_U:
- case INFO_DYN_TYPE_N:
- */
- case INFO_DYN_TYPE:
- *size = DYN_CLOSURE_SIZE(node);
- *ptrs = DYN_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_TUPLE_TYPE:
- *size = TUPLE_CLOSURE_SIZE(node);
- *ptrs = TUPLE_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_DATA_TYPE:
- *size = DATA_CLOSURE_SIZE(node);
- *ptrs = DATA_CLOSURE_NoPTRS(node);
- break;
-
- case INFO_IND_TYPE:
- *size = IND_CLOSURE_SIZE(node);
- *ptrs = IND_CLOSURE_NoPTRS(node);
- break;
-
-/* ToDo: more (WDP) */
-
- /* Don't know about the others */
- default:
- *size = *ptrs = 0;
- break;
- }
-}
-
-void
-DEBUG_PRINT_NODE(node)
-P_ node;
-{
- W_ info_ptr = INFO_PTR(node);
- I_ size = 0, ptrs = 0, i, vhs = 0;
- char *info_type = info_hdr_type(info_ptr);
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- fprintf(stderr,"Node: 0x%lx", (W_) node);
-
-#if defined(PAR)
- fprintf(stderr," [GA: 0x%lx]",GA(node));
-#endif
-
-#if defined(PROFILING)
- fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
-#endif
-
-#if defined(GRAN)
- fprintf(stderr," [Bitmask: 0%lo]",PROCS(node));
-#endif
-
- fprintf(stderr," IP: 0x%lx (%s), size %ld, %ld ptrs\n",
- info_ptr,info_type,size,ptrs);
-
- /* For now, we ignore the variable header */
-
- for(i=0; i < size; ++i)
- {
- if(i == 0)
- fprintf(stderr,"Data: ");
-
- else if(i % 6 == 0)
- fprintf(stderr,"\n ");
-
- if(i < ptrs)
- fprintf(stderr," 0x%lx[P]",*(node+_FHS+vhs+i));
- else
- fprintf(stderr," %lu[D]",*(node+_FHS+vhs+i));
- }
- fprintf(stderr, "\n");
-}
-
-
-#define INFO_MASK 0x80000000
-
-void
-DEBUG_TREE(node)
-P_ node;
-{
- W_ size = 0, ptrs = 0, i, vhs = 0;
-
- /* Don't print cycles */
- if((INFO_PTR(node) & INFO_MASK) != 0)
- return;
-
- size_and_ptrs(node,&size,&ptrs);
- vhs = var_hdr_size(node);
-
- DEBUG_PRINT_NODE(node);
- fprintf(stderr, "\n");
-
- /* Mark the node -- may be dangerous */
- INFO_PTR(node) |= INFO_MASK;
-
- for(i = 0; i < ptrs; ++i)
- DEBUG_TREE((P_)node[i+vhs+_FHS]);
-
- /* Unmark the node */
- INFO_PTR(node) &= ~INFO_MASK;
-}
-
-
-void
-DEBUG_INFO_TABLE(node)
-P_ node;
-{
- W_ info_ptr = INFO_PTR(node);
- char *ip_type = info_hdr_type(info_ptr);
-
- fprintf(stderr,"%s Info Ptr @0x%lx; Entry: 0x%lx; Size: %lu; Ptrs: %lu\n\n",
- ip_type,info_ptr,(W_) ENTRY_CODE(info_ptr),INFO_SIZE(info_ptr),INFO_NoPTRS(info_ptr));
-#if defined(PAR)
- fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
-#endif
-
-#if defined(PROFILING)
- fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr));
-#endif
-
-#if defined(_INFO_COPYING)
- fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
- INFO_EVAC_2S(info_ptr),INFO_SCAV_2S(info_ptr));
-#endif
-
-#if defined(_INFO_COMPACTING)
- fprintf(stderr,"Scan Link: 0x%lx;\tScan Move: 0x%lx\n",
- (W_) INFO_SCAN_LINK_1S(info_ptr), (W_) INFO_SCAN_MOVE_1S(info_ptr));
- fprintf(stderr,"Mark: 0x%lx;\tMarked: 0x%lx;\t",
- (W_) INFO_MARK_1S(info_ptr), (W_) INFO_MARKED_1S(info_ptr));
-#if 0 /* avoid INFO_TYPE */
- if(BASE_INFO_TYPE(info_ptr)==INFO_SPEC_TYPE)
- fprintf(stderr,"plus specialised code\n");
- else
- fprintf(stderr,"Marking: 0x%lx\n",(W_) INFO_MARKING_1S(info_ptr));
-#endif /* 0 */
-#endif
-}
-#endif /* GRAN */
-
-\end{code}
-
-The remaining debugging routines are more or less specific for GrAnSim.
-
-\begin{code}
-#if defined(GRAN) && defined(GRAN_CHECK)
-void
-DEBUG_CURR_THREADQ(verbose)
-I_ verbose;
-{
- fprintf(stderr,"Thread Queue on proc %d: ", CurrentProc);
- DEBUG_THREADQ(ThreadQueueHd, verbose);
-}
-
-void
-DEBUG_THREADQ(closure, verbose)
-P_ closure;
-I_ verbose;
-{
- P_ x;
-
- fprintf(stderr,"Thread Queue: ");
- for (x=closure; x!=Nil_closure; x=TSO_LINK(x))
- if (verbose)
- DEBUG_TSO(x,0);
- else
- fprintf(stderr," 0x%x",x);
-
- if (closure==Nil_closure)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-/* Check with Threads.lh */
-static char *type_name[] = { "T_MAIN", "T_REQUIRED", "T_ADVISORY", "T_FAIL"};
-
-void
-DEBUG_TSO(closure,verbose)
-P_ closure;
-I_ verbose;
-{
-
- if (closure==Nil_closure) {
- fprintf(stderr,"TSO at 0x%x is Nil_closure!\n");
- return;
- }
-
- fprintf(stderr,"TSO at 0x%x has the following contents:\n",closure);
-
- fprintf(stderr,"> Name: 0x%x",TSO_NAME(closure));
- fprintf(stderr,"\tLink: 0x%x\n",TSO_LINK(closure));
- fprintf(stderr,"> Id: 0x%x",TSO_ID(closure));
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (debug & 0x10)
- fprintf(stderr,"\tType: %s %s\n",
- type_name[TSO_TYPE(closure) & ~FETCH_MASK_TSO],
- (TSO_TYPE(closure) & FETCH_MASK_TSO) ? "SLEEPING" : "");
- else
- fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
-#else
- fprintf(stderr,"\tType: %s\n",type_name[TSO_TYPE(closure)]);
-#endif
- fprintf(stderr,"> PC1: 0x%x",TSO_PC1(closure));
- fprintf(stderr,"\tPC2: 0x%x\n",TSO_PC2(closure));
- fprintf(stderr,"> ARG1: 0x%x",TSO_ARG1(closure));
- fprintf(stderr,"\tARG2: 0x%x\n",TSO_ARG2(closure));
- fprintf(stderr,"> SWITCH: 0x%x\n", TSO_SWITCH(closure));
-
- if (verbose) {
- fprintf(stderr,"} LOCKED: 0x%x",TSO_LOCKED(closure));
- fprintf(stderr,"\tSPARKNAME: 0x%x\n", TSO_SPARKNAME(closure));
- fprintf(stderr,"} STARTEDAT: 0x%x", TSO_STARTEDAT(closure));
- fprintf(stderr,"\tEXPORTED: 0x%x\n", TSO_EXPORTED(closure));
- fprintf(stderr,"} BASICBLOCKS: 0x%x", TSO_BASICBLOCKS(closure));
- fprintf(stderr,"\tALLOCS: 0x%x\n", TSO_ALLOCS(closure));
- fprintf(stderr,"} EXECTIME: 0x%x", TSO_EXECTIME(closure));
- fprintf(stderr,"\tFETCHTIME: 0x%x\n", TSO_FETCHTIME(closure));
- fprintf(stderr,"} FETCHCOUNT: 0x%x", TSO_FETCHCOUNT(closure));
- fprintf(stderr,"\tBLOCKTIME: 0x%x\n", TSO_BLOCKTIME(closure));
- fprintf(stderr,"} BLOCKCOUNT: 0x%x", TSO_BLOCKCOUNT(closure));
- fprintf(stderr,"\tBLOCKEDAT: 0x%x\n", TSO_BLOCKEDAT(closure));
- fprintf(stderr,"} GLOBALSPARKS: 0x%x", TSO_GLOBALSPARKS(closure));
- fprintf(stderr,"\tLOCALSPARKS: 0x%x\n", TSO_LOCALSPARKS(closure));
- }
-}
-
-void
-DEBUG_EVENT(event, verbose)
-eventq event;
-I_ verbose;
-{
- if (verbose) {
- print_event(event);
- }else{
- fprintf(stderr," 0x%x",event);
- }
-}
-
-void
-DEBUG_EVENTQ(verbose)
-I_ verbose;
-{
- eventq x;
-
- fprintf(stderr,"Eventq (hd @0x%x):\n",EventHd);
- for (x=EventHd; x!=NULL; x=EVENT_NEXT(x)) {
- DEBUG_EVENT(x,verbose);
- }
- if (EventHd==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-DEBUG_SPARK(spark, verbose)
-sparkq spark;
-I_ verbose;
-{
- if (verbose)
- print_spark(spark);
- else
- fprintf(stderr," 0x%x",spark);
-}
-
-void
-DEBUG_SPARKQ(spark,verbose)
-sparkq spark;
-I_ verbose;
-{
- sparkq x;
-
- fprintf(stderr,"Sparkq (hd @0x%x):\n",spark);
- for (x=spark; x!=NULL; x=SPARK_NEXT(x)) {
- DEBUG_SPARK(x,verbose);
- }
- if (spark==NULL)
- fprintf(stderr,"NIL\n");
- else
- fprintf(stderr,"\n");
-}
-
-void
-DEBUG_CURR_SPARKQ(verbose)
-I_ verbose;
-{
- DEBUG_SPARKQ(SparkQueueHd,verbose);
-}
-
-void
-DEBUG_PROC(proc,verbose)
-I_ proc;
-I_ verbose;
-{
- fprintf(stderr,"Status of proc %d at time %d (0x%x): %s\n",
- proc,CurrentTime[proc],CurrentTime[proc],
- (CurrentProc==proc)?"ACTIVE":"INACTIVE");
- DEBUG_THREADQ(RunnableThreadsHd[proc],verbose & 0x2);
- if ( (CurrentProc==proc) )
- DEBUG_TSO(CurrentTSO,1);
-
- if (EventHd!=NULL)
- fprintf(stderr,"Next event (%s) is on proc %d\n",
- event_names[EVENT_TYPE(EventHd)],EVENT_PROC(EventHd));
-
- if (verbose & 0x1) {
- fprintf(stderr,"\nREQUIRED sparks: ");
- DEBUG_SPARKQ(PendingSparksHd[proc][REQUIRED_POOL],1);
- fprintf(stderr,"\nADVISORY_sparks: ");
- DEBUG_SPARKQ(PendingSparksHd[proc][ADVISORY_POOL],1);
- }
-}
-
-/* Debug CurrentTSO */
-void
-DCT(){
- fprintf(stderr,"Current Proc: %d\n",CurrentProc);
- DEBUG_TSO(CurrentTSO,1);
-}
-
-/* Debug Current Processor */
-void
-DCP(){ DEBUG_PROC(CurrentProc,2); }
-
-/* Shorthand for debugging event queue */
-void
-DEQ() { DEBUG_EVENTQ(1); }
-
-/* Shorthand for debugging spark queue */
-void
-DSQ() { DEBUG_CURR_SPARKQ(1); }
-
-/* Shorthand for printing a node */
-void
-DN(P_ node) { DEBUG_PRINT_NODE(node); }
-
-#endif /* GRAN */
-\end{code}
-
-
-%****************************************************************************
-%
-\subsection[qp-profile]{Quasi-Parallel Profiling}
-%
-%****************************************************************************
-
-\begin{code}
-#ifndef GRAN
-I_ do_qp_prof;
-FILE *qp_file;
-
-/* *Virtual* Time in milliseconds */
-long
-qp_elapsed_time()
-{
- return ((long) (usertime() * 1e3));
-}
-
-static void
-init_qp_profiling(STG_NO_ARGS)
-{
- I_ i;
- char qp_filename[STATS_FILENAME_MAXLEN];
-
- sprintf(qp_filename, QP_FILENAME_FMT, prog_argv[0]);
- if ((qp_file = fopen(qp_filename,"w")) == NULL ) {
- fprintf(stderr, "Can't open quasi-parallel profile report file %s\n",
- qp_filename);
- do_qp_prof = 0;
- } else {
- fputs(prog_argv[0], qp_file);
- for(i = 1; prog_argv[i]; i++) {
- fputc(' ', qp_file);
- fputs(prog_argv[i], qp_file);
- }
- fprintf(qp_file, "+RTS -C%ld -t%ld\n"
- , RTSflags.ConcFlags.ctxtSwitchTime
- , RTSflags.ConcFlags.maxThreads);
-
- fputs(time_str(), qp_file);
- fputc('\n', qp_file);
- }
-}
-
-void
-QP_Event0(tid, node)
-I_ tid;
-P_ node;
-{
- fprintf(qp_file, "%lu ** %lu 0x%lx\n", qp_elapsed_time(), tid, INFO_PTR(node));
-}
-
-void
-QP_Event1(event, tso)
-char *event;
-P_ tso;
-{
- fprintf(qp_file, "%lu %s %lu 0x%lx\n", qp_elapsed_time(), event,
- TSO_ID(tso), (W_) TSO_NAME(tso));
-}
-
-void
-QP_Event2(event, tso1, tso2)
-char *event;
-P_ tso1, tso2;
-{
- fprintf(qp_file, "%lu %s %lu 0x%lx %lu 0x%lx\n", qp_elapsed_time(), event,
- TSO_ID(tso1), (W_) TSO_NAME(tso1), TSO_ID(tso2), (W_) TSO_NAME(tso2));
-}
-#endif /* 0 */
-#endif /* GRAN */
-
-#if defined(CONCURRENT) && !defined(GRAN)
-/* romoluSnganpu' SamuS! */
-
-unsigned CurrentProc = 0;
-W_ IdleProcs = ~0l, Idlers = 32;
-
-void
-GranSimAllocate(I_ n, P_ node, W_ liveness)
-{ }
-
-void
-GranSimUnallocate(W_ n, P_ node, W_ liveness)
-{ }
-
-void
-GranSimExec(W_ ariths, W_ branches, W_ loads, W_ stores, W_ floats)
-{ }
-
-int
-GranSimFetch(P_ node /* , liveness_mask */ )
-/* I_ liveness_mask; */
-{ return(9999999); }
-
-void
-GranSimSpark(W_ local, P_ node)
-{ }
-
-#if 0
-void
-GranSimSparkAt(spark,where,identifier)
-sparkq spark;
-P_ where; /* This should be a node; alternatively could be a GA */
-I_ identifier;
-{ }
-#endif
-
-void
-GranSimBlock(STG_NO_ARGS)
-{ }
-#endif
-
-\end{code}
-/* this one will be linked in for Haskell 1.2 */
+/* this one will be linked in for Haskell 1.3 */
\begin{code}
#include "rtsdefs.h"
-EXTDATA(Main_mainPrimIO_closure);
+EXTDATA(GHCmain_mainPrimIO_closure);
-P_ TopClosure = Main_mainPrimIO_closure;
+P_ TopClosure = GHCmain_mainPrimIO_closure;
\end{code}
+++ /dev/null
-/* this one will be linked in for Haskell 1.3 */
-\begin{code}
-#include "rtsdefs.h"
-
-EXTDATA(Main_mainPrimIO13_closure);
-
-P_ TopClosure = Main_mainPrimIO13_closure;
-\end{code}
/* memory.h and strings.h conflict on some systems. */
#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-#if defined(PROFILING) || defined(PAR)
+#if defined(PROFILING) || defined(PAR) || defined(GRAN)
/* need some "time" things */
/* ToDo: This is a mess! Improve ? */
/* a real nasty Global Variable */
/* moved to main/TopClosure(13)?.lc -- *one* of them will get linked in
-P_ TopClosure = Main_mainPrimIO_closure;
+P_ TopClosure = GHCmain_mainPrimIO_closure;
*/
/* structure to carry around info about the storage manager */
extern void SetTrace PROTO((W_ address, I_ level/*?*/));
#endif
-#if defined(GRAN_CHECK) && defined(GRAN)
-extern W_ debug;
-extern W_ event_trace ;
-extern W_ event_trace_all ;
-#endif
-
extern void *stgAllocForGMP PROTO((size_t));
extern void *stgReallocForGMP PROTO ((void *, size_t, size_t));
extern void stgDeallocForGMP PROTO ((void *, size_t));
int /* return type of "main" is defined by the C standard */
main(int argc, char *argv[])
{
+#ifdef GRAN
+ int i;
+#endif
\end{code}
The very first thing we do is grab the start time...just in case we're
\begin{code}
#ifdef PAR
- if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
+ if (*argv[0] == '-') { /* Look to see whether we're the Main Thread */
IAmMainThread = rtsTrue;
argv++; argc--; /* Strip off flag argument */
/* fprintf(stderr, "I am Main Thread\n"); */
nPEs = atoi(argv[1]);
argv[1] = argv[0];
argv++; argc--;
+ initEachPEHook(); /* HWL: hook to be execed on each PE */
SynchroniseSystem();
#endif
-#if defined(PROFILING) || defined(PAR)
+#if defined(PROFILING) || defined(PAR) || defined(GRAN)
/* setup string indicating time of run -- only used for profiling */
(void) time_str();
#endif
}
#endif
-#if defined(CONCURRENT) && defined(GRAN)
- if (!no_gr_profile)
+#if defined(GRAN)
+ if (!RTSflags.GranFlags.granSimStats_suppressed)
if (init_gr_simulation(rts_argc, rts_argv, prog_argc, prog_argv) != 0) {
- fprintf(stderr, "init_gr_simulation failed!\n"); EXIT(EXIT_FAILURE);
+ fprintf(stderr, "init_gr_simulation failed!\n");
+ EXIT(EXIT_FAILURE);
}
#endif
/* Record initialization times */
end_init();
-#if defined(PROFILING) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
/*
* Both the context-switcher and the cost-center profiler use
* a virtual timer.
#endif
#ifdef CONCURRENT
+ AvailableStack = AvailableTSO = Prelude_Z91Z93_closure;
# if defined(GRAN) /* HWL */
- /* RunnableThreadsHd etc. are init in ScheduleThreads */
- /*
- * I'm not sure about this. Note that this code is for re-initializing
- * things when a longjmp to restart_main occurs. --JSM
- */
-
-# else /* !GRAN */
- AvailableStack = AvailableTSO = Nil_closure;
- RunnableThreadsHd = RunnableThreadsTl = Nil_closure;
- WaitingThreadsHd = WaitingThreadsTl = Nil_closure;
+ /* Moved in here from ScheduleThreads, to handle a restart_main
+ (because of a signal) properly. */
+ for (i=0; i<RTSflags.GranFlags.proc; i++)
+ {
+ RunnableThreadsHd[i] = RunnableThreadsTl[i] = Prelude_Z91Z93_closure;
+ WaitThreadsHd[i] = WaitThreadsTl[i] = Prelude_Z91Z93_closure;
+ PendingSparksHd[i][REQUIRED_POOL] = PendingSparksHd[i][ADVISORY_POOL] =
+ PendingSparksTl[i][REQUIRED_POOL] = PendingSparksTl[i][ADVISORY_POOL] =
+ NULL;
+ }
+# else
+ RunnableThreadsHd = RunnableThreadsTl = Prelude_Z91Z93_closure;
+ WaitingThreadsHd = WaitingThreadsTl = Prelude_Z91Z93_closure;
PendingSparksHd[REQUIRED_POOL] =
PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL];
PendingSparksHd[ADVISORY_POOL] =
PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL];
# endif
- CurrentTSO = Nil_closure;
+ CurrentTSO = Prelude_Z91Z93_closure;
# ifdef PAR
RunParallelSystem(TopClosure);
# else
- STKO_LINK(MainStkO) = Nil_closure;
+ STKO_LINK(MainStkO) = Prelude_Z91Z93_closure;
ScheduleThreads(TopClosure);
# endif /* PAR */
{
STOP_TIME_PROFILER;
- if (! exitSM(&StorageMgrInfo)) {
+#if defined(GRAN)
+ /* For some reason this must be before exitSM */
+ if (!RTSflags.GranFlags.granSimStats_suppressed)
+ end_gr_simulation();
+#endif
+
+ if (! exitSM(&StorageMgrInfo) ) {
fflush(stdout);
fprintf(stderr, "exitSM failed!\n");
EXIT(EXIT_FAILURE);
if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
-#if defined(GRAN_CHECK) && defined(GRAN)
- if (PrintFetchMisses)
- fprintf(stderr,"Number of fetch misses: %d\n",fetch_misses);
-
-# if defined(COUNT)
- fprintf(stderr,"COUNT statistics:\n");
- fprintf(stderr," Total number of updates: %u\n",nUPDs);
- fprintf(stderr," Needed to awaken BQ: %u with avg BQ len of: %f\n",
- nUPDs_BQ,(float)BQ_lens/(float)nUPDs_BQ);
- fprintf(stderr," Number of PAPs: %u\n",nPAPs);
-# endif
-
- if (!no_gr_profile)
- end_gr_simulation();
-#endif
-
fflush(stdout);
/* This fflush is important, because: if "main" just returns,
then we will end up in pre-supplied exit code that will close
Only used for profiling.
\begin{code}
-#if defined(PROFILING) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT) || defined(GRAN)
# include <time.h>
char *
return (StgInt) errorHandler;
}
-#ifndef PAR
+#if !defined(PAR)
void
raiseError( handler )
ctype i; \
unsigned char cs[sizeof (ctype)]; \
} u; \
- int k; \
+ unsigned int k; \
unsigned char *arr = (unsigned char *) in; \
\
for (k = 0; k < sizeof(ctype); k++) \
ctype i; \
unsigned char cs[sizeof (ctype)]; \
} u; \
- int k; \
+ unsigned int k; \
unsigned char *arr = (unsigned char *) in; \
\
for (k = 0; k < sizeof(ctype); k++) \
size_t old_size, new_size;
{
void *new_stuff_ptr = stgAllocForGMP(new_size);
- I_ i = 0;
+ unsigned int i = 0;
char *p = (char *) ptr;
char *q = (char *) new_stuff_ptr;
might have to perform a DynamicReturn (just Bool at the moment).
\begin{code}
+ED_RO_(Prelude_False_inregs_info);
+ED_RO_(Prelude_True_inregs_info);
-ED_RO_(False_inregs_info);
-ED_RO_(True_inregs_info);
-const W_ Bool_itblvtbl[] = {
- (W_) False_inregs_info,
- (W_) True_inregs_info
+const W_ Prelude_Bool_itblvtbl[] = {
+ (W_) Prelude_False_inregs_info,
+ (W_) Prelude_True_inregs_info
};
-
\end{code}
# endif
\end{code}
-The current cost centre. It is initially set to "MAIN" by main.
-We have to be careful when doing so, as an initial @SET_CCC(CC_MAIN)@
-would try to increment some @sub_scc_count@ of the @CCC@ (nothing!).
-
\begin{code}
CostCentre CCC; /* _not_ initialised */
\begin{code}
#if defined(PROFILING)
-CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "MAIN", CC_IS_CAF,/*not static*/);
-CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", "MAIN", CC_IS_SUBSUMED,/*not static*/);
-CC_DECLARE(CC_DONTZuCARE,"DONT_CARE", "MAIN", "MAIN", CC_IS_BORING,/*not static*/);
+CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "PROFILING", CC_IS_CAF, /*not static*/);
+CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", "MAIN", CC_IS_SUBSUMED, /*not static*/);
+CC_DECLARE(CC_DONTZuCARE,"DONT_CARE", "MAIN", "MAIN", CC_IS_BORING, /*not static*/);
#endif
\end{code}
char *rts_argv[], *prog_argv[];
{
I_ arg, ch;
-#ifndef PAR
- char *select_cc = 0;
- char *select_mod = 0;
- char *select_grp = 0;
- char *select_descr = 0;
- char *select_type = 0;
- char *select_kind = 0;
- char *left, *right;
-#endif
prog_argv_save = prog_argv;
rts_argv_save = rts_argv;
}
#if defined(PROFILING)
- if (heap_profile_init(select_cc, select_mod, select_grp,
- select_descr, select_type, select_kind,
- prog_argv))
+ if (heap_profile_init(prog_argv))
return 1;
#endif
REGISTER_CC(CC_DONTZuCARE); /* register cost centre CC_DONT_CARE Right??? ToDo */
#endif
- /* as per SET_CCC macro, without the sub_scc_count++ bit */
- CCC = (CostCentre)STATIC_CC_REF(CC_MAIN);
- CCC->scc_count++;
+ SET_CCC_RTS(CC_MAIN,0,1); /* without the sub_scc_count++ */
#if defined(PROFILING)
/* always register -- if we do not, we get warnings (WDP 94/12) */
# endif /* PROFILING */
}
+rtsBool
+have_interesting_groups(CostCentre cc)
+{
+ char* interesting_group = NULL;
+
+ for (; cc != REGISTERED_END; cc = cc->registered) {
+ if (! cc_to_ignore(cc) && strcmp(cc->module,cc->group) != 0) {
+ if (interesting_group && strcmp(cc->group, interesting_group) != 0) {
+ return(rtsTrue);
+ } else {
+ interesting_group = cc->group;
+ }
+ }
+ }
+ return(rtsFalse);
+}
+
void
report_cc_profiling(final)
I_ final;
CostCentre cc;
I_ count;
char temp[128]; /* sigh: magic constant */
- W_ total_ticks = 0, total_alloc = 0, total_allocs = 0;
- W_ ignored_ticks = 0, ignored_alloc = 0, ignored_allocs = 0;
+ W_ total_ticks, ignored_ticks;
+ W_ total_alloc = 0, total_allocs = 0;
+ rtsBool do_groups = rtsFalse;
#ifdef PAR
- I_ final_ticks = 0; /*No. ticks in last sample*/
+ I_ final_ticks; /*No. ticks in last sample*/
#endif
if (!RTSflags.CcFlags.doCostCentres)
return;
blockVtAlrmSignal();
+ /* To avoid inconsistency, initialise the tick variables
+ after having blocked out VTALRM */
+ total_ticks = 0;
+ ignored_ticks = 0;
+#ifdef PAR
+ final_ticks = 0;
+#endif
if (serial_file) {
StgFloat seconds = (previous_ticks + current_ticks) / (StgFloat) TICK_FREQUENCY;
if ( cc_to_ignore(cc) ) { /* reporting these just confuses users... */
ignored_ticks += cc->prev_ticks;
- ignored_alloc += cc->mem_alloc;
- ignored_allocs += cc->mem_allocs;
} else {
total_ticks += cc->prev_ticks;
total_alloc += cc->mem_alloc;
+#if defined(PROFILING_DETAIL_COUNTS)
total_allocs += cc->mem_allocs;
+#endif
}
}
fprintf(prof_file, " %s", prog_argv_save[count]);
fprintf(prof_file, "\n\n");
+
fprintf(prof_file, "\ttotal time = %11.2f secs (%lu ticks @ %d ms)\n",
- total_ticks / (StgFloat) TICK_FREQUENCY, total_ticks, TICK_MILLISECS);
- fprintf(prof_file, "\ttotal alloc = %11s bytes (%lu closures) (excludes profiling overheads)\n",
- ullong_format_string((ullong) total_alloc * sizeof(W_), temp, rtsTrue/*commas*/), total_allocs);
+ total_ticks / (StgFloat) TICK_FREQUENCY, total_ticks, TICK_MILLISECS);
+ fprintf(prof_file, "\ttotal alloc = %11s bytes",
+ ullong_format_string((ullong) total_alloc * sizeof(W_), temp, rtsTrue/*commas*/));
/* ToDo: 64-bit error! */
- fprintf(prof_file, "\n");
+
+#if defined(PROFILING_DETAIL_COUNTS)
+ fprintf(prof_file, " (%lu closures)", total_allocs);
+#endif
+ fprintf(prof_file, " (excludes profiling overheads)\n\n");
+
fprintf(prof_file, "%-16.16s %-11.11s", "COST CENTRE", "MODULE");
-/* ToDo:group
- fprintf(prof_file, " %-11.11s", "GROUP");
-*/
- fprintf(prof_file, " %5s %5s %6s %6s", "scc", "subcc", "%time", "%alloc");
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE)
- fprintf(prof_file, " %11s %13s %8s %8s %8s (%5s %8s)", "cafcc", "thunks", "funcs", "PAPs", "closures", "ticks", "bytes");
+ do_groups = have_interesting_groups(Registered_CC);
+ if (do_groups) fprintf(prof_file, " %-11.11s", "GROUP");
+
+ fprintf(prof_file, "%8s %6s %6s %8s %5s %5s", "scc", "%time", "%alloc", "inner", "cafs", "dicts");
+
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
+ fprintf(prof_file, " %5s %9s", "ticks", "bytes");
+#if defined(PROFILING_DETAIL_COUNTS)
+ fprintf(prof_file, " %8s %8s %8s %8s %8s %8s %8s",
+ "closures", "thunks", "funcs", "PAPs", "subfuns", "subcafs", "cafssub");
+#endif
+ }
fprintf(prof_file, "\n\n");
for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
if ( (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_ALL
/* force printing of *all* cost centres if -P -P */ )
- || ( ! cc_to_ignore(cc)
- && (cc->scc_count || cc->sub_scc_count || cc->prev_ticks || cc->mem_alloc
- || (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
- && (cc->thunk_count || cc->function_count || cc->pap_count
- || cc->cafcc_count || cc->sub_cafcc_count))))
- ) {
-
+ || ( ! cc_to_ignore(cc)
+ && (cc->scc_count || cc->sub_scc_count || cc->prev_ticks || cc->mem_alloc
+ || (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
+ && (cc->sub_cafcc_count || cc->sub_dictcc_count
+#if defined(PROFILING_DETAIL_COUNTS)
+ || cc->thunk_count || cc->function_count || cc->pap_count
+#endif
+ ))))) {
fprintf(prof_file, "%-16.16s %-11.11s", cc->label, cc->module);
-/* ToDo:group
- fprintf(prof_file, " %-11.11s",cc->group);
-*/
- fprintf(prof_file, " %5ld %5ld %5.1f %5.1f",
- cc->scc_count, cc->sub_scc_count,
- total_ticks == 0 ? 0.0 : (cc->prev_ticks / (StgFloat) total_ticks * 100),
- total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat) total_alloc * 100));
-
- if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE)
- fprintf(prof_file, " %8ld %-8ld %8ld %8ld %8ld %8ld (%5ld %8ld)",
- cc->cafcc_count, cc->sub_cafcc_count,
- cc->thunk_count, cc->function_count, cc->pap_count,
- cc->mem_allocs,
- cc->prev_ticks, cc->mem_alloc*sizeof(W_));
+ if (do_groups) fprintf(prof_file, " %-11.11s",cc->group);
+
+ fprintf(prof_file, "%8ld %5.1f %5.1f %8ld %5ld %5ld",
+ cc->scc_count,
+ total_ticks == 0 ? 0.0 : (cc->prev_ticks / (StgFloat) total_ticks * 100),
+ total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat) total_alloc * 100),
+ cc->sub_scc_count, cc->sub_cafcc_count, cc->sub_dictcc_count);
+
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
+ fprintf(prof_file, " %5ld %9ld", cc->prev_ticks, cc->mem_alloc*sizeof(W_));
+#if defined(PROFILING_DETAIL_COUNTS)
+ fprintf(prof_file, " %8ld %8ld %8ld %8ld %8ld %8ld %8ld",
+ cc->mem_allocs, cc->thunk_count,
+ cc->function_count, cc->pap_count,
+ cc->subsumed_fun_count, cc->subsumed_caf_count,
+ cc->caffun_subsumed);
+#endif
+ }
fprintf(prof_file, "\n");
}
}
else if (cc1->mem_alloc < cc2->mem_alloc) /* time equal; alloc less */
return 0;
- if (cc1->thunk_count > cc2->thunk_count) /* time & alloc equal: cmp enters */
- return 1;
- else if (cc1->thunk_count < cc2->thunk_count)
- return 0;
-
return (cc_lt_label(cc1, cc2)); /* all data equal: cmp labels */
}
else if (cc1->prev_ticks < cc2->prev_ticks) /* alloc equal; time less */
return 0;
- if (cc1->thunk_count > cc2->thunk_count) /* alloc & time: cmp enters */
- return 1;
- else if (cc1->thunk_count < cc2->thunk_count)
- return 0;
-
return (cc_lt_label(cc1, cc2)); /* all data equal: cmp labels */
}
static FILE *heap_file = NULL;
I_
-heap_profile_init(cc_select_str, mod_select_str, grp_select_str,
- descr_select_str, type_select_str, kind_select_str,
- argv)
- char *cc_select_str;
- char *mod_select_str;
- char *grp_select_str;
- char *descr_select_str;
- char *type_select_str;
- char *kind_select_str;
- char *argv[];
+heap_profile_init(argv)
+ char *argv[];
{
+ char *cc_select_str = RTSflags.ProfFlags.ccSelector;
+ char *mod_select_str = RTSflags.ProfFlags.modSelector;
+ char *grp_select_str = RTSflags.ProfFlags.grpSelector;
+ char *descr_select_str = RTSflags.ProfFlags.descrSelector;
+ char *type_select_str = RTSflags.ProfFlags.typeSelector;
+ char *kind_select_str = RTSflags.ProfFlags.kindSelector;
+
hash_t count, max, first;
W_ heap_prof_style;
#define NON_PROF_HS (FIXED_HS - PROF_FIXED_HDR - TICKY_FIXED_HDR)
void
-profile_closure_none(P_ closure, I_ size)
-{
- return;
-}
-
-void
profile_closure_cc(P_ closure, I_ size)
{
CostCentre cc = (CostCentre) CC_HDR(closure);
@heap_profile_setup@ is called before garbage collection to initialise
for the profile. It assigns the appropriate closure profiling function
to @heap_profile_fn@ and memoises any cost centre selection. If no
-profile is required @profile_closure_none@ is assigned.
+profile is required @heap_profile_fn@ is assigned NULL.
On completion of garbage collection @heap_profile_done@ is called. It
produces a heap profile report and resets the residency counts to 0.
\begin{code}
-void (* heap_profile_fn) PROTO((P_,I_)) = profile_closure_none;
+void (* heap_profile_fn) PROTO((P_,I_)) = NULL;
void (* profiling_fns_select[]) PROTO((P_,I_)) = {
- profile_closure_none,
+ NULL,
profile_closure_cc_select,
profile_closure_mod_select,
profile_closure_grp_select,
};
void (* profiling_fns[]) PROTO((P_,I_)) = {
- profile_closure_none,
+ NULL,
profile_closure_cc,
profile_closure_mod,
profile_closure_grp,
return;
heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
- heap_profile_fn = profile_closure_none;
+ heap_profile_fn = NULL;
seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
/* end of bracket */
#ifndef PAR
- sweepUpDeadMallocPtrs(sm->MallocPtrList,
- compactingInfo.base,
- compactingInfo.bits );
+ sweepUpDeadForeignObjs(sm->ForeignObjList,
+ compactingInfo.base,
+ compactingInfo.bits );
#endif
LinkCAFs(sm->CAFlist);
LinkRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
+#if defined(GRAN)
+ LinkEvents();
+#endif
+#if defined(CONCURRENT) /* && !defined(GRAN) */
LinkSparks();
#endif
#ifdef PAR
LinkLiveGAs(compactingInfo.base, compactingInfo.bits);
#else
+ /*
+ The stable pointer table is reachable via sm->roots,
+ (Reason: in markHeapRoots all roots have to be considered,
+ including the StablePointerTable)
+
DEBUG_STRING("Linking Stable Pointer Table:");
LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
+
+ */
+# if /* !defined(GRAN) */ /* HWL */
LinkAStack( MAIN_SpA, stackInfo.botA );
LinkBStack( MAIN_SuB, stackInfo.botB );
+# endif
#endif /* parallel */
/* Do Inplace Compaction */
compactingInfo.bits,
compactingInfo.bit_words
#if ! defined(PAR)
- , &(sm->MallocPtrList)
+ , &(sm->ForeignObjList)
#endif
) - 1;
#ifdef PAR
EvacuateLocalGAs(rtsTrue);
#else
- evacSPTable( sm );
+ /* evacSPTable( sm ); stable pointers now reachable via sm->roots */
#endif /* PAR */
EvacuateRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
+#if defined(GRAN)
+ EvacuateEvents();
+#endif
+#if defined(CONCURRENT) /* && !defined(GRAN) */
EvacuateSparks();
#endif
-#ifndef PAR
+#if !defined(PAR) && !defined(GRAN)
EvacuateAStack( MAIN_SpA, stackInfo.botA );
EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
#endif /* !PAR */
#ifdef PAR
RebuildGAtables(rtsTrue);
#else
- reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+ reportDeadForeignObjs(sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
#endif /* PAR */
/* TIDY UP AND RETURN */
if (appelInfo.oldbase > appelInfo.oldmax) {
fprintf(stderr, "Not enough heap for requested/minimum allocation area\n");
- fprintf(stderr, "heap_space=%ld\n", heap_space);
+ fprintf(stderr, "heap_space=%ld\n", (W_) heap_space);
fprintf(stderr, "heapSize=%ld\n", RTSflags.GcFlags.heapSize);
fprintf(stderr, "newmin=%ld\n", appelInfo.newmin);
return rtsFalse;
#ifdef PAR
EvacuateLocalGAs(rtsTrue);
#else
- evacSPTable( sm );
+ /* evacSPTable( sm ); StablePointerTable now accessable in sm->roots SOF 4/96 */
#endif /* PAR */
EvacuateRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
+#if defined(GRAN)
+ EvacuateEvents();
+#endif
+#if defined(CONCURRENT) /* && !defined(GRAN) */
EvacuateSparks();
#endif
-#ifndef PAR
+#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
EvacuateAStack( MAIN_SpA, stackInfo.botA );
EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
#endif /* !PAR */
#ifdef PAR
RebuildGAtables(rtsTrue);
#else
- reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+ reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
#endif /* PAR */
/* TIDY UP AND RETURN */
if (RTSflags.GcFlags.giveStats) {
char comment_str[BIG_STRING_LEN];
-#ifndef PAR
+#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
sprintf(comment_str, "%4lu %4ld %3ld %3ld %6lu %6lu %6lu 2s",
(W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno,
while ( mutptr ) {
/* Scavenge the OldMutable */
- P_ orig_mutptr = mutptr;
P_ info = (P_) INFO_PTR(mutptr);
StgScavPtr scav_code = SCAV_CODE(info);
Scav = mutptr;
#ifdef PAR
EvacuateLocalGAs(rtsFalse);
#else
- evacSPTable( sm );
+ /* evacSPTable( sm ); SP table is now in sm->roots*/
#endif /* PAR */
DEBUG_STRING("Scavenge evacuated old generation roots:");
EvacuateRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
+#if defined(GRAN)
+ EvacuateEvents();
+#endif
+#if defined(CONCURRENT) /* && !defined(GRAN) */
EvacuateSparks();
#endif
-#ifndef PAR
+#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
EvacuateAStack( MAIN_SpA, stackInfo.botA );
EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
/* ToDo: Optimisation which squeezes out garbage update frames */
#ifdef PAR
RebuildGAtables(rtsFalse);
#else
- reportDeadMallocPtrs(sm->MallocPtrList,
- sm->OldMallocPtrList,
- &(sm->OldMallocPtrList));
- sm->MallocPtrList = NULL; /* all (new) MallocPtrs have been promoted */
+ reportDeadForeignObjs(sm->ForeignObjList,
+ sm->OldForeignObjList,
+ &(sm->OldForeignObjList));
+ sm->ForeignObjList = NULL; /* all (new) ForeignObjs have been promoted */
#endif /* PAR */
resident = appelInfo.oldlim - sm->OldLim;
if (RTSflags.GcFlags.giveStats) {
char minor_str[BIG_STRING_LEN];
-#ifndef PAR
+#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
sprintf(minor_str, "%4lu %4ld %3ld %3ld %4ld Minor",
(W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno, caf_roots, mutable); /* oldnew_roots, old_words */
/* end of bracket */
#ifndef PAR
- sweepUpDeadMallocPtrs(sm->OldMallocPtrList,
- appelInfo.oldbase,
- appelInfo.bits
+ sweepUpDeadForeignObjs(sm->OldForeignObjList,
+ appelInfo.oldbase,
+ appelInfo.bits
);
#endif /* !PAR */
LinkCAFs(appelInfo.OldCAFlist);
LinkRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
+#if defined(GRAN)
+ LinkEvents();
+#endif
+#if defined(CONCURRENT) /* && !defined(GRAN) */
LinkSparks();
#endif
#ifdef PAR
LinkLiveGAs(appelInfo.oldbase, appelInfo.bits);
#else
+/* stable pointers now included in sm->roots -- SOF
DEBUG_STRING("Linking Stable Pointer Table:");
LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
+*/
+#if 1 /* !defined(GRAN) */ /* HWL */
LinkAStack( MAIN_SpA, stackInfo.botA );
LinkBStack( MAIN_SuB, stackInfo.botB );
#endif
+#endif
/* Do Inplace Compaction */
/* Returns start of next closure, -1 gives last allocated word */
appelInfo.bits,
appelInfo.bit_words
#ifndef PAR
- ,&(sm->OldMallocPtrList)
+ ,&(sm->OldForeignObjList)
#endif
) - 1;
if (RTSflags.GcFlags.giveStats) {
char major_str[BIG_STRING_LEN];
-#ifndef PAR
+#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
sprintf(major_str, "%4lu %4ld %3ld %3ld %4d %4d *Major* %4.1f%%",
(W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno, appelInfo.OldCAFno,
\end{code}
\begin{code}
+#if defined(GRAN)
+void
+LinkEvents(STG_NO_ARGS)
+{
+ eventq event = EventHd;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"Linking Events ...\n");
+#endif
+
+ DEBUG_STRING("Linking Events:");
+ while(event != NULL)
+ {
+ if(EVENT_TYPE(event) == RESUMETHREAD ||
+ EVENT_TYPE(event) == MOVETHREAD ||
+ EVENT_TYPE(event) == CONTINUETHREAD ||
+ EVENT_TYPE(event) == STARTTHREAD )
+
+ { LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) ); }
+
+ else if(EVENT_TYPE(event) == MOVESPARK)
+
+ { LINK_LOCATION_TO_CLOSURE( &(SPARK_NODE(EVENT_SPARK(event))) ); }
+
+ else if (EVENT_TYPE(event) == FETCHNODE ||
+ EVENT_TYPE(event) == FETCHREPLY )
+ {
+ LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) );
+
+ /* In the case of packet fetching, EVENT_NODE(event) points to */
+ /* the packet (currently, malloced). The packet is just a list of */
+ /* closure addresses, with the length of the list at index 1 (the */
+ /* structure of the packet is defined in Pack.lc). */
+ if ( RTSflags.GranFlags.DoGUMMFetching &&
+ (EVENT_TYPE(event)==FETCHREPLY)) {
+ P_ buffer = (P_) EVENT_NODE(event);
+ int size = (int) buffer[PACK_SIZE_LOCN], i;
+
+ for (i = PACK_HDR_SIZE; i <= size-1; i++) {
+ LINK_LOCATION_TO_CLOSURE( (buffer+i) );
+ }
+ } else
+ { LINK_LOCATION_TO_CLOSURE( &(EVENT_NODE(event)) ); }
+ }
+ else if (EVENT_TYPE(event) == GLOBALBLOCK)
+ {
+ LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) );
+ LINK_LOCATION_TO_CLOSURE( &(EVENT_NODE(event)) );
+ }
+ else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
+ {
+ LINK_LOCATION_TO_CLOSURE( &(EVENT_TSO(event)) );
+ }
+ event = EVENT_NEXT(event);
+ }
+}
+#endif /* GRAN */
+\end{code}
+
+\begin{code}
+
+#if defined(CONCURRENT)
+# if defined(GRAN)
+void
+LinkSparks(STG_NO_ARGS)
+{
+ sparkq spark;
+ PROC proc;
+ I_ pool, total_sparks=0;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"Linking Sparks ...\n");
+#endif
+
+ DEBUG_STRING("Linking Sparks:");
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ for(spark = PendingSparksHd[proc][pool];
+ spark != NULL;
+ spark = SPARK_NEXT(spark))
+ {
+ LINK_LOCATION_TO_CLOSURE( &(SPARK_NODE(spark)));
+ } /* forall spark ... */
+ } /* forall pool ... */
+ } /*forall proc .. */
+}
+
+# else /* ! GRAN */
-#ifdef CONCURRENT
void
LinkSparks(STG_NO_ARGS)
{
}
}
}
-#endif
+#endif /* GRAN */
+#endif /* CONCURRENT */
\end{code}
sendFreeMessages();
}
-#else
+#endif
\end{code}
don't have a single main stack.
\begin{code}
+#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
void
LinkAStack(stackA, botA)
ToDo (Patrick?): Dont explicitly mark & compact unmarked Bstack frames
\begin{code}
-#if ! defined(PAR)
+#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
+
void
LinkBStack(stackB, botB)
P_ stackB;
I_ CountCAFs PROTO((P_ CAFlist));
void LinkCAFs PROTO((P_ CAFlist));
+#ifdef GRAN
+void LinkEvents(STG_NO_ARGS);
+#endif
#ifdef CONCURRENT
void LinkSparks(STG_NO_ARGS);
#endif
}
\end{code}
+Evacuating events is necessary in GRAN since some TSOs and closures are only
+pointed at by events we have to schedule later on.
+
+\begin{code}
+#if defined(GRAN)
+void
+EvacuateEvents(STG_NO_ARGS)
+{
+ eventq event = EventHd;
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"Evacuating Events ...\n");
+#endif
+
+ DEBUG_STRING("Evacuate Events:");
+ while(event != NULL)
+ {
+ if(EVENT_TYPE(event) == RESUMETHREAD ||
+ EVENT_TYPE(event) == MOVETHREAD ||
+ EVENT_TYPE(event) == CONTINUETHREAD ||
+ EVENT_TYPE(event) == STARTTHREAD )
+
+ MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
+
+ else if(EVENT_TYPE(event) == MOVESPARK)
+
+ MAYBE_EVACUATE_CLOSURE( SPARK_NODE(EVENT_SPARK(event)) );
+
+ else if (EVENT_TYPE(event) == FETCHNODE ||
+ EVENT_TYPE(event) == FETCHREPLY )
+ {
+
+ MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
+
+ /* In the case of packet fetching, EVENT_NODE(event) points to */
+ /* the packet (currently, malloced). The packet is just a list of */
+ /* closure addresses, with the length of the list at index 1 (the */
+ /* structure of the packet is defined in Pack.lc). */
+ if ( RTSflags.GranFlags.DoGUMMFetching &&
+ (EVENT_TYPE(event)==FETCHREPLY)) {
+ P_ buffer = (P_) EVENT_NODE(event);
+ int size = (int) buffer[PACK_SIZE_LOCN], i;
+
+ for (i = PACK_HDR_SIZE; i <= size-1; i++) {
+ MAYBE_EVACUATE_CLOSURE( (P_)buffer[i] );
+ }
+ } else
+ MAYBE_EVACUATE_CLOSURE( EVENT_NODE(event) );
+ }
+ else if (EVENT_TYPE(event) == GLOBALBLOCK)
+ {
+ MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
+ MAYBE_EVACUATE_CLOSURE( EVENT_NODE(event) );
+ }
+ else if (EVENT_TYPE(event) == UNBLOCKTHREAD)
+ {
+ MAYBE_EVACUATE_CLOSURE( EVENT_TSO(event) );
+ }
+ event = EVENT_NEXT(event);
+ }
+}
+#endif /* GRAN */
+\end{code}
+
\begin{code}
-#ifdef CONCURRENT
+#if defined(CONCURRENT)
+# if defined(GRAN)
+void
+EvacuateSparks(STG_NO_ARGS)
+{
+ sparkq spark;
+ PROC proc;
+ I_ pool, total_sparks=0;
+
+ /* Sparks have been pruned already at this point */
+
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GcFlags.giveStats && (RTSflags.GranFlags.debug & 0x40) )
+ fprintf(RTSflags.GcFlags.statsFile,"Evacuating Sparks ...\n");
+# endif
+
+ DEBUG_STRING("Evacuate Sparks (GRAN):");
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; ++pool) {
+ for(spark = PendingSparksHd[proc][pool];
+ spark != NULL;
+ spark = SPARK_NEXT(spark))
+ {
+# if defined(GRAN) && defined(GRAN_CHECK)
+ if ( RTSflags.GcFlags.giveStats &&
+ (RTSflags.GranFlags.debug & 0x40) &&
+ !SHOULD_SPARK(SPARK_NODE(spark)) )
+ fprintf(RTSflags.GcFlags.statsFile,"Qagh {EvacuateSparks}Daq: spark @ 0x%x with node 0x%x shouldn't spark!\n",
+ spark,SPARK_NODE(spark));
+# endif
+ MAYBE_EVACUATE_CLOSURE(SPARK_NODE(spark));
+ } /* forall spark ... */
+ } /* forall pool ... */
+ } /* forall proc ... */
+}
+
+# else /* !GRAN */
+
void
EvacuateSparks(STG_NO_ARGS)
{
}
}
}
-#endif
+# endif
+#endif /* CONCURRENT */
\end{code}
Note: no \tr{evacuate[AB]Stack} for ``parallel'' systems, because they
don't have a single main stack.
\begin{code}
-#ifndef PAR
+#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
void
EvacuateAStack(PP_ stackA, PP_ botA /* botA points to bottom-most word */)
{
Otherwise closure is live update reference to to-space address
\begin{code}
-#ifndef PAR
+#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
void
EvacuateBStack( stackB, botB, roots )
P_ stackB;
void EvacuateBStack PROTO(( P_ stackB, P_ botB, I_ *roots ));
void Scavenge (STG_NO_ARGS);
+#ifdef GRAN
+void EvacuateEvents(STG_NO_ARGS);
+#endif
#ifdef CONCURRENT
void EvacuateSparks(STG_NO_ARGS);
#endif
/* end of bracket */
#ifndef PAR
- sweepUpDeadMallocPtrs(sm->MallocPtrList,
- dualmodeInfo.modeinfo[COMPACTING].base,
- dualmodeInfo.bits);
+ sweepUpDeadForeignObjs(sm->ForeignObjList,
+ dualmodeInfo.modeinfo[COMPACTING].base,
+ dualmodeInfo.bits);
#endif
LinkCAFs(sm->CAFlist);
#ifdef PAR
LinkLiveGAs(dualmodeInfo.modeinfo[COMPACTING].base, dualmodeInfo.bits);
#else
+/* stable pointers are now accessed via sm->roots
DEBUG_STRING("Linking Stable Pointer Table:");
LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable);
+*/
+#if 1 /* !defined(GRAN) */ /* HWL */
LinkAStack( MAIN_SpA, stackInfo.botA );
LinkBStack( MAIN_SuB, stackInfo.botB );
#endif
+#endif
/* Do Inplace Compaction */
/* Returns start of next closure, -1 gives last allocated word */
dualmodeInfo.bits,
dualmodeInfo.bit_words
#ifndef PAR
- ,&(sm->MallocPtrList)
+ ,&(sm->ForeignObjList)
#endif
) - 1;
#ifdef PAR
EvacuateLocalGAs(rtsTrue);
#else
- evacSPTable( sm );
+ /* evacSPTable( sm ); stable pointers now reachable via sm->roots */
#endif /* PAR */
EvacuateRoots( sm->roots, sm->rootno );
-#ifdef CONCURRENT
+#if defined(CONCURRENT) && !defined(GRAN)
EvacuateSparks();
#endif
-#ifndef PAR
+#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */
EvacuateAStack( MAIN_SpA, stackInfo.botA );
EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots );
#endif /* !PAR */
#ifdef PAR
RebuildGAtables(rtsTrue);
#else
- reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+ reportDeadForeignObjs(sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
#endif /* PAR */
sm->hp = hp_start = ToHp; /* Last allocated word */
closure. This is normally fine since, if we want the data, we'll
have made a copy of it.
- But, Malloc Pointer closures are special: we have to make sure that
+ But, Foreign Object closures are special: we have to make sure that
we don't damage either the linked list (which will include both
- copied and uncopied Malloc ptrs) or the data (which we must report
- to the outside world). Malloc Ptr closures are carefully designed
+ copied and uncopied Foreign objs) or the data (which we must report
+ to the outside world). Foreign Objects closures are carefully designed
to have a little extra space in them that can be safely
overwritten. [ADR]
*/
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
#define SPEC_RBH_EVAC_FN(n) \
EVAC_FN(CAT2(RBH_,n)) \
#endif
#ifndef PAR
-EVAC_FN(MallocPtr)
+EVAC_FN(ForeignObj)
{
- I_ size = MallocPtr_SIZE;
+ I_ size = ForeignObj_SIZE;
START_ALLOC(size);
DEBUG_EVAC(size);
#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
- printf("DEBUG: Evacuating MallocPtr(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
- printf(" Data = %x, Next = %x\n",
- MallocPtr_CLOSURE_DATA(evac), MallocPtr_CLOSURE_LINK(evac) );
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
+ printf("DEBUG: Evacuating ForeignObj(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
+ printf(" Data = %x, Finaliser= %x, Next = %x\n",
+ ForeignObj_CLOSURE_DATA(evac),
+ ForeignObj_CLOSURE_FINALISER(evac),
+ ForeignObj_CLOSURE_LINK(evac) );
}
#endif
COPY_FIXED_HDR;
SET_FORWARD_REF(evac,ToHp);
- MallocPtr_CLOSURE_DATA(ToHp) = MallocPtr_CLOSURE_DATA(evac);
- MallocPtr_CLOSURE_LINK(ToHp) = MallocPtr_CLOSURE_LINK(evac);
+ ForeignObj_CLOSURE_DATA(ToHp) = ForeignObj_CLOSURE_DATA(evac);
+ ForeignObj_CLOSURE_FINALISER(ToHp) = ForeignObj_CLOSURE_FINALISER(evac);
+ ForeignObj_CLOSURE_LINK(ToHp) = ForeignObj_CLOSURE_LINK(evac);
#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
- printf("DEBUG: Evacuated MallocPtr(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
- printf(" Data = %x, Next = %x\n",
- MallocPtr_CLOSURE_DATA(ToHp), MallocPtr_CLOSURE_LINK(ToHp) );
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
+ printf("DEBUG: Evacuated ForeignObj(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
+ printf(" Data = %x, Finaliser = %x, Next = %x\n",
+ ForeignObj_CLOSURE_DATA(ToHp),
+ ForeignObj_CLOSURE_FINALISER(ToHp),
+ ForeignObj_CLOSURE_LINK(ToHp));
}
#endif
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
EVAC_FN(RBH_S)
{
I_ count = GEN_RBH_HS - 1;
This is a collection of C functions use in implementing the stable
-pointer and malloc pointer extensions.
+pointer and foreign object extensions.
The motivation for making this a separate file/section is twofold:
\begin{code}
-#ifndef PAR /* To end of the file */
+#if !defined(PAR) /* To end of the file */
\end{code}
void initExtensions( sm )
smInfo *sm;
{
- sm->MallocPtrList = NULL;
+ sm->ForeignObjList = NULL;
#if defined(GCap) || defined(GCgn)
- sm->OldMallocPtrList = NULL;
+ sm->OldForeignObjList = NULL;
#endif
sm->StablePointerTable = (P_) EmptySPTable_closure;
}
-extern void FreeMallocPtr PROTO(( StgMallocPtr mp ));
\end{code}
\begin{code}
#if defined(DEBUG)
\end{code}
-When a Malloc Pointer is released, there should be absolutely no
+When a Foreign Object is released, there should be absolutely no
references to it. To encourage and dangling references to show
themselves, we'll trash its contents when we're done with it.
\begin{code}
-#define TRASH_MallocPtr_CLOSURE( mptr ) Trash_MallocPtr_Closure(mptr)
+#define TRASH_ForeignObj_CLOSURE( mptr ) Trash_ForeignObj_Closure(mptr)
void
-Trash_MallocPtr_Closure(mptr)
+Trash_ForeignObj_Closure(mptr)
P_ mptr;
{
int i;
- for( i = 0; i < MallocPtr_SIZE + _FHS; i++ ) {
+ for( i = 0; i < ForeignObj_SIZE + _FHS; i++ ) {
mptr[ i ] = DEALLOCATED_TRASH;
}
}
\end{code}
-Also, every time we fiddle with the MallocPtr list, we should check it
+Also, every time we fiddle with the ForeignObj list, we should check it
still makes sense. This function returns @0@ if the list is sensible.
-(Would maintaining a separate Malloc Ptr count allow better testing?)
+(Would maintaining a separate Foreign Obj count allow better testing?)
\begin{code}
void
-Validate_MallocPtrList( MallocPtrList )
- P_ MallocPtrList;
+Validate_ForeignObjList( ForeignObjList )
+ P_ ForeignObjList;
{
- P_ MPptr;
+ P_ FOptr;
- for(MPptr = MallocPtrList;
- MPptr != NULL;
- MPptr = MallocPtr_CLOSURE_LINK(MPptr) ) {
- CHECK_MallocPtr_CLOSURE(MPptr);
+ for(FOptr = ForeignObjList;
+ FOptr != NULL;
+ FOptr = ForeignObj_CLOSURE_LINK(FOptr) ) {
+ CHECK_ForeignObj_CLOSURE(FOptr);
}
}
\end{code}
\begin{code}
#else /* !DEBUG */
-#define TRASH_MallocPtr_CLOSURE( mp ) /* nothing */
+#define TRASH_ForeignObj_CLOSURE( mp ) /* nothing */
#endif /* !DEBUG */
\end{code}
\begin{code}
#ifdef DEBUG
-#define TRACE_MallocPtr(MPptr) Trace_MallocPtr( MPptr )
-#define TRACE_MPdies(MPptr) Trace_MPdies()
-#define TRACE_MPlives(MPptr) Trace_MPlives()
-#define TRACE_MPforwarded(MPptr, newAddress) Trace_MPforwarded( MPptr, newAddress )
+#define TRACE_ForeignObj(FOptr) Trace_ForeignObj( FOptr )
+#define TRACE_FOdies(FOptr) Trace_FOdies()
+#define TRACE_FOlives(FOptr) Trace_FOlives()
+#define TRACE_FOforwarded(FOptr, newAddress) Trace_FOforwarded( FOptr, newAddress )
void
-Trace_MallocPtr( MPptr )
- P_ MPptr;
+Trace_ForeignObj( FOptr )
+ P_ FOptr;
{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
- printf("DEBUG: MallocPtr(%lx)=<%lx,_,%lx,%lx,%lx>\n", (W_) MPptr, (W_) MPptr[0], (W_) MPptr[1], (W_) MPptr[2], (W_) MPptr[3]);
- printf(" Data = %lx, Next = %lx\n",
- (W_) MallocPtr_CLOSURE_DATA(MPptr), (W_) MallocPtr_CLOSURE_LINK(MPptr) );
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
+ printf("DEBUG: ForeignObj(%lx)=<%lx,_,%lx,%lx,%lx>\n", (W_) FOptr, (W_) FOptr[0], (W_) FOptr[1], (W_) FOptr[2], (W_) FOptr[3]);
+ printf(" Data = %lx, Finaliser = %lx, Next = %lx\n",
+ (W_) ForeignObj_CLOSURE_DATA(FOptr),
+ (W_) ForeignObj_CLOSURE_FINALISER(FOptr),
+ (W_) ForeignObj_CLOSURE_LINK(FOptr) );
}
}
void
-Trace_MPdies()
+Trace_FOdies()
{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
printf(" dying\n");
}
}
void
-Trace_MPlives()
+Trace_FOlives()
{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
printf(" lived to tell the tale\n");
}
}
void
-Trace_MPforwarded( MPPtr, newAddress )
- P_ MPPtr, newAddress;
+Trace_FOforwarded( FOPtr, newAddress )
+ P_ FOPtr, newAddress;
{
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
printf(" forwarded to %lx\n", (W_) newAddress);
}
}
#else
-#define TRACE_MallocPtr(MPptr) /* nothing */
-#define TRACE_MPdies(MPptr) /* nothing */
-#define TRACE_MPlives(MPptr) /* nothing */
-#define TRACE_MPforwarded(MPptr, newAddress) /* nothing */
+#define TRACE_ForeignObj(FOptr) /* nothing */
+#define TRACE_FOdies(FOptr) /* nothing */
+#define TRACE_FOlives(FOptr) /* nothing */
+#define TRACE_FOforwarded(FOptr, newAddress) /* nothing */
#endif /* DEBUG */
\end{code}
\begin{code}
#if defined(_INFO_COMPACTING)
-/* Sweep up the dead MallocPtrs */
+/* Sweep up the dead ForeignObjs */
/* Note that this has to happen before the linking phase trashes
- the stable pointer table so that the FreeMallocPtr function can
+ the stable pointer table so that the finaliser functions can
safely call freeStablePointer.
*/
void
-sweepUpDeadMallocPtrs( MallocPtrList, base, bits )
- P_ MallocPtrList;
+sweepUpDeadForeignObjs( ForeignObjList, base, bits )
+ P_ ForeignObjList;
P_ base;
BitWord *bits;
{
- P_ MPptr, temp;
- I_ MallocPtr_deaths = 0;
+ P_ FOptr, temp;
+ I_ ForeignObj_deaths = 0;
long _hp_word, bit_index, bit;
- /* At this point, the MallocPtrList is in an invalid state (since
+ /* At this point, the ForeignObjList is in an invalid state (since
some info ptrs will have been mangled) so we can't validate
it. ADR */
- DEBUG_STRING("Reporting Dead Malloc Ptrs:");
- MPptr = MallocPtrList;
- while ( MPptr != NULL ) {
+ DEBUG_STRING("Reporting Dead Foreign objects:");
+ FOptr = ForeignObjList;
+ while ( FOptr != NULL ) {
- TRACE_MallocPtr(MPptr);
+ TRACE_ForeignObj(FOptr);
- _hp_word = MPptr - base;
+ _hp_word = FOptr - base;
bit_index = _hp_word / BITS_IN(BitWord);
bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1));
if ( !( bits[bit_index] & bit ) ) { /* dead */
- TRACE_MPdies( MPptr );
- FreeMallocPtr( MallocPtr_CLOSURE_DATA(MPptr) );
- MallocPtr_deaths++;
+ TRACE_FOdies( FOptr );
+ (*(void (*)(StgAddr))((StgAddr)ForeignObj_CLOSURE_FINALISER(FOptr)))((StgAddr)ForeignObj_CLOSURE_DATA(FOptr));
+ ForeignObj_deaths++;
- temp = MPptr;
- MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+ temp = FOptr;
+ FOptr = ForeignObj_CLOSURE_LINK(FOptr);
/* Now trash the closure to encourage bugs to show themselves */
- TRASH_MallocPtr_CLOSURE( temp );
+ TRASH_ForeignObj_CLOSURE( temp );
} else {
- TRACE_MPlives(MPptr);
- MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+ TRACE_FOlives(FOptr);
+ FOptr = ForeignObj_CLOSURE_LINK(FOptr);
}
}
}
-/* First attempt at Malloc Ptr hackery... Later versions might
+/* First attempt at Foreign Obj hackery... Later versions might
do something useful with the two counters. [ADR] */
#if defined(DEBUG)
#endif
/*
- Call FreeMallocPtr on any dead MPs in oldMPList, add the remainder
- to new sticking the result into newMPList.
+ Call ForeignObj finalising routine on any dead FOs in oldFOList,
+ add the remainder to new sticking the result into newFOList.
*/
void
-reportDeadMallocPtrs(oldMPList, new, newMPList)
- P_ oldMPList;
+reportDeadForeignObjs(oldFOList, new, newFOList)
+ P_ oldFOList;
P_ new;
- P_ *newMPList;
+ P_ *newFOList;
{
- P_ MPptr, temp;
- I_ MP_no = 0, MP_deaths = 0;
+ P_ FOptr, temp;
+ I_ FO_no = 0, FO_deaths = 0;
- /* At this point, the MallocPtrList is in an invalid state (since
+ /* At this point, the ForeignObjList is in an invalid state (since
some info ptrs will have been mangled) so we can't validate
it. ADR */
- DEBUG_STRING("Updating MallocPtr List and reporting casualties:");
- MPptr = oldMPList;
- while ( MPptr != NULL ) {
- TRACE_MallocPtr(MPptr);
+ DEBUG_STRING("Updating Foreign Objects List and reporting casualties:");
+ FOptr = oldFOList;
+ while ( FOptr != NULL ) {
+ TRACE_ForeignObj(FOptr);
- if ((P_) INFO_PTR(MPptr) == MallocPtr_info ) {
+ if ((P_) INFO_PTR(FOptr) == ForeignObj_info ) {
/* can't have been forwarded - must be dead */
- TRACE_MPdies(MPptr);
- FreeMallocPtr( MallocPtr_CLOSURE_DATA(MPptr) );
- MP_deaths++;
+ TRACE_FOdies(FOptr);
+ (*(void (*)(StgAddr))(ForeignObj_CLOSURE_FINALISER(FOptr)))((StgAddr)ForeignObj_CLOSURE_DATA(FOptr));
+ FO_deaths++;
- temp = MPptr;
- MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+ temp = FOptr;
+ FOptr = ForeignObj_CLOSURE_LINK(FOptr);
/* Now trash the closure to encourage bugs to show themselves */
- TRASH_MallocPtr_CLOSURE( temp );
+ TRASH_ForeignObj_CLOSURE( temp );
} else { /* Must have been forwarded - so it must be live */
- P_ newAddress = (P_) FORWARD_ADDRESS(MPptr);
+ P_ newAddress = (P_) FORWARD_ADDRESS(FOptr);
#if defined(GCgn)
- ASSERT( ( (P_) INFO_PTR(MPptr) == Forward_Ref_New_info ) ||
- ( (P_) INFO_PTR(MPptr) == Forward_Ref_Old_info ) ||
- ( (P_) INFO_PTR(MPptr) == OldRoot_Forward_Ref_info ) );
+ ASSERT( ( (P_) INFO_PTR(FOptr) == Forward_Ref_New_info ) ||
+ ( (P_) INFO_PTR(FOptr) == Forward_Ref_Old_info ) ||
+ ( (P_) INFO_PTR(FOptr) == OldRoot_Forward_Ref_info ) );
#else
- ASSERT( (P_) INFO_PTR(MPptr) == Forward_Ref_info );
+ ASSERT( (P_) INFO_PTR(FOptr) == Forward_Ref_info );
#endif
- TRACE_MPforwarded( MPptr, newAddress );
- MallocPtr_CLOSURE_LINK(newAddress) = new;
+ TRACE_FOforwarded( FOptr, newAddress );
+ ForeignObj_CLOSURE_LINK(newAddress) = new;
new = newAddress;
- MP_no++;
- MPptr = MallocPtr_CLOSURE_LINK(MPptr);
+ FO_no++;
+ FOptr = ForeignObj_CLOSURE_LINK(FOptr);
}
}
- VALIDATE_MallocPtrList( new );
- *newMPList = new;
+ VALIDATE_ForeignObjList( new );
+ *newFOList = new;
}
#endif /* _INFO_COPYING */
\end{code}
# if defined(_INFO_COPYING)
void evacSPTable PROTO((smInfo *sm));
-void reportDeadMallocPtrs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust));
+void reportDeadForeignObjs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust));
# endif /* _INFO_COPYING */
# if defined(_INFO_COMPACTING)
-void sweepUpDeadMallocPtrs PROTO((P_ MallocPtrList,
- P_ base,
- BitWord *bits
+void sweepUpDeadForeignObjs PROTO((P_ ForeignObjList,
+ P_ base,
+ BitWord *bits
));
# endif /* _INFO_COMPACTING */
# if defined(DEBUG)
-void Trash_MallocPtr_Closure PROTO((P_ mptr));
-void Validate_MallocPtrList PROTO(( P_ MallocPtrList ));
+void Trash_ForeignObj_Closure PROTO((P_ mptr));
+void Validate_ForeignObj PROTO(( P_ ForeignObjList ));
-void Trace_MPdies PROTO((void));
-void Trace_MPlives PROTO((void));
-void Trace_MPforwarded PROTO(( P_ MPPtr, P_ newAddress ));
+void Trace_FOdies PROTO((void));
+void Trace_FOlives PROTO((void));
+void Trace_FOforwarded PROTO(( P_ FOPtr, P_ newAddress ));
# endif /* DEBUG */
#ifdef PAR
EvacuateLocalGAs(rtsTrue);
#else
- evacSPTable( sm );
+ /* evacSPTable( sm ); stable pointers now reachable via sm->roots */
#endif /* PAR */
DEBUG_STRING("Evacuate Roots:");
sm->roots[root] = EVACUATE_CLOSURE(evac);
}
-#if !defined(PAR)
+#if defined(GRAN)
+ /* ToDo: Add evacuation of events and sparks here */
+#if defined(KLINGON_ERROR_MESSAGES)
+ fprintf(stderr,"no' veQ boSwI' yeq {GranSim}\n");
+ EXIT(EXIT_FAILURE);
+#else
+ fprintf(stderr,"Sorry, GranSim doesn't support generational GC yet\n");
+ EXIT(EXIT_FAILURE);
+#endif
+#endif
+
+#if !defined(PAR) /* && !defined(CONCURRENT) */ /* HWL */
DEBUG_STRING("Evacuate A Stack:");
for (stackptr = MAIN_SpA;
#ifdef PAR
RebuildGAtables(rtsTrue);
#else
- reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) );
+ reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList) );
#endif /* PAR */
/* TIDY UP AND RETURN */
}
}
+#if defined(GRAN)
+ /* ToDo: Add evacuation of events and sparks here */
+#if defined(KLINGON_ERROR_MESSAGES)
+ fprintf(stderr,"no' veQ boSwI' yeq {GranSim}\n");
+ EXIT(EXIT_FAILURE);
+#else
+ fprintf(stderr,"Sorry, GranSim doesn't support generational GC yet\n");
+ EXIT(EXIT_FAILURE);
+#endif
+#endif
+
#if !defined(PAR)
DEBUG_STRING("Evacuate A Stack:");
for (stackptr = MAIN_SpA, botA = stackInfo.botA;
#ifdef PAR
EvacuateLocalGAs(rtsFalse);
#else
- evacSPTable( sm );
+ /* evacSPTable( sm ); stable pointers now reachable via sm->roots
+ (see above)
+ */
#endif /* PAR */
while ((newscav <= ToHp) || (oldscav <= OldHp)) {
#ifdef PAR
RebuildGAtables(rtsFalse);
#else
- reportDeadMallocPtrs(sm->MallocPtrList,
- sm->OldMallocPtrList,
- &(sm->OldMallocPtrList));
- sm->MallocPtrList = NULL; /* all (new) MallocPtrs have been promoted */
+ reportDeadForeignObjs(sm->ForeignObjList,
+ sm->OldForeignObjList,
+ &(sm->OldForeignObjList));
+ sm->ForeignObjList = NULL; /* all (new) ForeignObjs have been promoted */
#endif /* PAR */
if (RTSflags.GcFlags.giveStats) {
/* end of bracket */
#ifndef PAR
- sweepUpDeadMallocPtrs(sm->OldMallocPtrList,
+ sweepUpDeadForeignObjs(sm->OldForeignObjList,
appelInfo.oldbase,
appelInfo.bits
);
#ifdef PAR
fall over here until we figure out how to link GAs
#else
+/* stable pointer root now included in sm->roots
DEBUG_STRING("Linking Stable Pointer Table:");
LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable, oldlim);
+*/
DEBUG_STRING("Linking A Stack:");
for (stackptr = MAIN_SpA;
SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0;
EXTFUN(_PRMarking_MarkNextSpark);
#endif
+#if defined(GRAN)
+EXTFUN(_PRMarking_MarkNextEvent);
+EXTFUN(_PRMarking_MarkNextClosureInFetchBuffer);
+#endif
+
#ifdef PAR
EXTFUN(_PRMarking_MarkNextGA);
MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextGA,)
MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextSpark,)
#endif
+#if defined(GRAN)
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextEvent,)
+MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextClosureInFetchBuffer,)
+#endif
+
MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextRoot,)
MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextCAF,)
/* #define MARK_REG_MAP -- Must be done on command line for threaded code */
#include "SMinternal.h"
#include "SMmarkDefs.h"
+
+#if defined(GRAN)
+extern P_ ret_MRoot, ret_Mark;
+#endif
\end{code}
Define appropriate variables as potential register variables.
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
#define SPEC_RBH_PRStart_N_CODE(ptrs) \
STGFUN(CAT2(_PRStart_RBH_,ptrs)) \
{ \
In code for revertible black holes with underlying @SPEC@ types.
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
#define SPEC_RBH_PRIn_N_CODE(ptrs) \
STGFUN(CAT2(_PRIn_RBH_,ptrs)) \
{ \
\end{code}
-Malloc Ptrs are in the sequential world only.
+Foreign Objs are in the non-parallel world only.
\begin{code}
#ifndef PAR
-STGFUN(_PRStart_MallocPtr)
+STGFUN(_PRStart_ForeignObj)
{
FUNBEGIN;
if (IS_MARK_BIT_SET(Mark)) {
DEBUG_PR_MARKED;
} else
- INIT_MARK_NODE("MallocPtr ",0);
+ INIT_MARK_NODE("ForeignObj ",0);
JUMP_MARK_RETURN;
FUNEND;
}
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
STGFUN(_PRStart_RBH_N)
{
\begin{code}
STGFUN(_PRStart_CharLike)
{
+#ifdef TICKY_TICKY
I_ val;
+#endif
FUNBEGIN;
#ifdef PAR
INTFUN(_PRMarking_MarkNextGA_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
#endif
+# if 1 /* !defined(CONCURRENT) */ /* HWL */
INTFUN(_PRMarking_MarkNextAStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
INTFUN(_PRMarking_MarkNextBStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+# endif
INTFUN(_PRMarking_MarkNextCAF_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+#if defined(GRAN)
+INTFUN(_PRMarking_MarkNextEvent_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+INTFUN(_PRMarking_MarkNextClosureInFetchBuffer_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+#endif
+
/* end of various ways to call _Dummy_PRReturn_entry */
EXTFUN(_PRMarking_MarkNextRoot);
#ifdef PAR
EXTFUN(_PRMarking_MarkNextGA);
#else
+# if 1 /* !defined(CONCURRENT) */ /* HWL */
EXTFUN(_PRMarking_MarkNextAStack);
EXTFUN(_PRMarking_MarkNextBStack);
+# endif
#endif /* not parallel */
CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN")
_PRMarking_MarkNextSpark_entry);
#endif
+#if defined(GRAN)
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextEvent_closure,
+ _PRMarking_MarkNextEvent_info,
+ _PRMarking_MarkNextEvent,
+ _PRMarking_MarkNextEvent_entry);
+DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextClosureInFetchBuffer_closure,
+ _PRMarking_MarkNextClosureInFetchBuffer_info,
+ _PRMarking_MarkNextClosureInFetchBuffer,
+ _PRMarking_MarkNextClosureInFetchBuffer_entry);
+#endif
+
#ifdef PAR
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
_PRMarking_MarkNextGA_info,
_PRMarking_MarkNextGA,
_PRMarking_MarkNextGA_entry);
#else
+# if 1 /* !defined(CONCURRENT) */ /* HWL */
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
_PRMarking_MarkNextAStack_info,
_PRMarking_MarkNextAStack,
_PRMarking_MarkNextBStack_info,
_PRMarking_MarkNextBStack,
_PRMarking_MarkNextBStack_entry);
-
+# endif
#endif /* PAR */
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
FUNEND;
}
-#ifdef CONCURRENT
+#if defined(CONCURRENT)
+# if !defined(GRAN)
extern P_ sm_roots_end; /* PendingSparksTl[pool] */
STGFUN(_PRMarking_MarkNextSpark)
JUMP_MARK;
FUNEND;
}
+#else /* GRAN */
+STGFUN(_PRMarking_MarkNextSpark)
+{
+ /* This is more similar to MarkNextGA than to the MarkNextSpark in
+ concurrent-but-not-gran land
+ NB: MRoot is a spark (with an embedded pointer to a closure) */
+ FUNBEGIN;
+ /* Update root -- may have short circuited Ind */
+ SPARK_NODE( ((sparkq) MRoot) ) = Mark;
+ MRoot = (P_) SPARK_NEXT( ((sparkq) MRoot) );
+
+ /* Is the next off the end */
+ if (MRoot == NULL)
+ RESUME_(miniInterpretEnd);
+
+ Mark = (P_) SPARK_NODE( ((sparkq) MRoot) );
+ JUMP_MARK;
+ FUNEND;
+}
+#endif /* GRAN */
+#endif /* CONCURRENT */
+\end{code}
+
+Note: Events are GranSim-only.
+Marking events is similar to marking GALA entries in parallel-land.
+The major difference is that depending on the type of the event we have
+to mark different field of the event (possibly several fields).
+Even worse, in the case of bulk fetching
+(@RTSflags.GranFlags.DoGUMMFetching@) we find a buffer of pointers to
+closures we have to mark (similar to sparks in concurrent-but-not-gransim
+setup).
+
+\begin{code}
+#if defined(GRAN)
+STGFUN(_PRMarking_MarkNextEvent)
+{
+ rtsBool found = rtsFalse;
+
+ FUNBEGIN;
+
+ /* First update the right component of the old event */
+ switch (EVENT_TYPE( ((eventq) MRoot) )) {
+ case CONTINUETHREAD:
+ case STARTTHREAD:
+ case RESUMETHREAD:
+ case MOVETHREAD:
+ EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
+ break;
+ case MOVESPARK:
+ SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) )) = (P_) Mark;
+ break;
+ case FETCHNODE:
+ switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
+ case 0:
+ EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
+ Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
+ JUMP_MARK;
+ break;
+ case 1:
+ EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0; /* reset flag */
+ break;
+ default:
+ fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
+ ((eventq) MRoot) );
+ EXIT(EXIT_FAILURE);
+ }
+ break;
+ case FETCHREPLY:
+ switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
+ case 0:
+ EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
+ /* In the case of packet fetching, EVENT_NODE(event) points to */
+ /* the packet (currently, malloced). The packet is just a list of */
+ /* closure addresses, with the length of the list at index 1 (the */
+ /* structure of the packet is defined in Pack.lc). */
+ if ( RTSflags.GranFlags.DoGUMMFetching ) {
+ P_ buffer = (P_) EVENT_NODE( ((eventq) MRoot) );
+ int size = (int) buffer[PACK_SIZE_LOCN];
+
+ /* was: for (i = PACK_HDR_SIZE; i <= size-1; i++) ... */
+ sm_roots_end = buffer + PACK_HDR_SIZE + size;
+ MRoot = (P_) buffer + PACK_HDR_SIZE;
+ ret_MRoot = MRoot;
+ Mark = (P_) *MRoot;
+ ret_Mark = Mark;
+ MStack = (P_) _PRMarking_MarkNextClosureInFetchBuffer_closure;
+ JUMP_MARK;
+ } else {
+ Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
+ JUMP_MARK;
+ }
+ break;
+ case 1:
+ if ( RTSflags.GranFlags.DoGUMMFetching ) {
+ /* no update necessary; fetch buffers are malloced */
+ } else {
+ EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
+ }
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0; /* reset flag */
+ break;
+ default:
+ fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHREPLY event @ %#x\n",
+ ((eventq) MRoot) );
+ EXIT(EXIT_FAILURE);
+ }
+ break;
+
+ case GLOBALBLOCK:
+ switch (EVENT_GC_INFO( ((eventq) MRoot) )) {
+ case 0:
+ EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 1;
+ Mark = (P_) EVENT_NODE( ((eventq) MRoot) );
+ JUMP_MARK;
+ break;
+ break;
+ case 1:
+ EVENT_NODE( ((eventq) MRoot) ) = (P_) Mark;
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0; /* reset flag */
+ break;
+ default:
+ fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of GLOBALBLOCK event @ %#x\n",
+ ((eventq) MRoot) );
+ EXIT(EXIT_FAILURE);
+ }
+ break;
+ case UNBLOCKTHREAD:
+ EVENT_TSO( ((eventq) MRoot) ) = (P_) Mark;
+ break;
+ case FINDWORK:
+ break;
+ default:
+ fprintf(stderr,"PRMarking_MarkNextEvent: Illegal gc_info field of FETCHNODE event @ %#x\n",
+ ((eventq) MRoot) );
+ EXIT(EXIT_FAILURE);
+ }
+
+ do {
+ MRoot = (P_) EVENT_NEXT( ((eventq) MRoot) );
+ /* Is the next off the end */
+ if (MRoot == NULL)
+ RESUME_(miniInterpretEnd);
+
+ switch (EVENT_TYPE( ((eventq) MRoot) )) {
+ case CONTINUETHREAD:
+ case STARTTHREAD:
+ case RESUMETHREAD:
+ case MOVETHREAD:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ found = rtsTrue;
+ break;
+ case MOVESPARK:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) ));
+ found = rtsTrue;
+ break;
+ case FETCHNODE:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ found = rtsTrue;
+ break;
+ case FETCHREPLY:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ found = rtsTrue;
+ break;
+ case GLOBALBLOCK:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ found = rtsTrue;
+ break;
+ case UNBLOCKTHREAD:
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ found = rtsTrue;
+ break;
+ case FINDWORK:
+ found = rtsFalse;
+ break;
+ default:
+ fprintf(stderr,"Unknown event type %d (event @ %#x) in SMmarking_NextEvent\n",
+ EVENT_TYPE( ((eventq) MRoot) ), MRoot);
+ EXIT(EXIT_FAILURE);
+ }
+ } while (!found && MRoot!=NULL);
+
+ JUMP_MARK;
+
+ FUNEND;
+}
+
+STGFUN(_PRMarking_MarkNextClosureInFetchBuffer)
+{
+ FUNBEGIN;
+ /* Update root -- may have short circuited Ind */
+ *MRoot = Mark;
+
+ /* Is the next off the end */
+ if (++MRoot >= sm_roots_end) {
+ /* We know that marking a fetch buffer is only called from within
+ marking a FETCHREPLY event; we have saved the important
+ registers before that */
+ MRoot = ret_MRoot;
+ Mark = ret_Mark;
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ JUMP_MARK;
+ }
+
+ Mark = *MRoot;
+ JUMP_MARK;
+ FUNEND;
+}
#endif
#ifdef PAR
}
#else
-
+#if 1 /* !defined(CONCURRENT) */ /* HWL */
STGFUN(_PRMarking_MarkNextAStack)
{
FUNBEGIN;
JUMP_MARK;
FUNEND;
}
+#endif /* !CONCURRENT */
#endif /* PAR */
\end{code}
EXTDATA(_PRMarking_MarkNextSpark_closure);
#endif
+#if defined(GRAN)
+EXTFUN(_PRMarking_MarkNextEvent);
+EXTDATA(_PRMarking_MarkNextEvent_closure);
+EXTFUN(_PRMarking_MarkNextClosureInFetchBuffer);
+EXTDATA(_PRMarking_MarkNextClosureInFetchBuffer_closure);
+#endif
+
#ifdef PAR
EXTFUN(_PRMarking_MarkNextGA);
EXTDATA(_PRMarking_MarkNextGA_closure);
#else
+# if 1 /* !defined(GRAN) */ /* HWL */
EXTFUN(_PRMarking_MarkNextAStack);
EXTFUN(_PRMarking_MarkNextBStack);
EXTDATA(_PRMarking_MarkNextAStack_closure);
EXTDATA(_PRMarking_MarkNextBStack_closure);
+# endif
#endif /* not parallel */
P_ sm_roots_end;
+#if defined(GRAN)
+P_ ret_MRoot, ret_Mark;
+#endif
I_
markHeapRoots(sm, cafs1, cafs2, base, lim, bit_array)
#ifdef CONCURRENT
int pool;
#endif
+#if defined(GRAN)
+ PROC proc;
+ eventq event;
+ sparkq spark;
+ rtsBool found = rtsFalse;
+#endif
BitArray = bit_array;
HeapBase = base;
miniInterpret((StgFunPtr)_startMarkWorld);
}
-#ifdef CONCURRENT
+#if defined(GRAN)
+ DEBUG_STRING("Marking Events (GRAN): ");
+ MRoot = (P_) EventHd;
+ found = rtsFalse;
+ do {
+ if (MRoot != NULL) {
+ /* inlined version of MarkNextEvent */
+ switch (EVENT_TYPE( ((eventq) MRoot) )) {
+ case CONTINUETHREAD:
+ case STARTTHREAD:
+ case RESUMETHREAD:
+ case MOVETHREAD:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ found = rtsTrue;
+ break;
+ case MOVESPARK:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) SPARK_NODE(EVENT_SPARK( ((eventq) MRoot) ));
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ found = rtsTrue;
+ break;
+ case FETCHNODE:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ found = rtsTrue;
+ break;
+ case FETCHREPLY:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ found = rtsTrue;
+ break;
+ case GLOBALBLOCK:
+ EVENT_GC_INFO( ((eventq) MRoot) ) = 0;
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ found = rtsTrue;
+ break;
+ case UNBLOCKTHREAD:
+ Mark = (P_) EVENT_TSO( ((eventq) MRoot) );
+ MStack = (P_) _PRMarking_MarkNextEvent_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ found = rtsTrue;
+ break;
+ case FINDWORK:
+ MRoot = (P_) EVENT_NEXT( ((eventq) MRoot) );
+ found = rtsFalse;
+ break;
+ default:
+ fprintf(stderr,"Unknown event type %d (event @ %#x) in SMmarking_NextEvent\n",
+ EVENT_TYPE( ((eventq) MRoot) ), MRoot);
+ EXIT(EXIT_FAILURE);
+ }
+ }
+ } while (!found && MRoot != NULL);
+
+ DEBUG_STRING("Marking Sparks (GRAN):");
+ /* ToDo: Check this code */
+ for(proc = 0; proc < RTSflags.GranFlags.proc; ++proc) {
+ for(pool = 0; pool < SPARK_POOLS; pool++) {
+ MRoot = (P_) PendingSparksHd[proc][pool];
+ if (MRoot != NULL) {
+ Mark = (P_) SPARK_NODE( ((sparkq) MRoot) );
+ MStack = (P_) _PRMarking_MarkNextSpark_closure;
+ miniInterpret((StgFunPtr)_startMarkWorld);
+ }
+ } /* forall pool .. */
+ } /* forall proc ... */
+#endif /* GRAN */
+
+#if defined(CONCURRENT) && !defined(GRAN)
for(pool = 0; pool < SPARK_POOLS; pool++) {
if (PendingSparksHd[pool] < PendingSparksTl[pool]) {
sm_roots_end = (P_) PendingSparksTl[pool];
miniInterpret((StgFunPtr) _startMarkWorld);
}
#else
-# ifndef CONCURRENT
+# if 1 /* !defined(GRAN) */ /* HWL */
/* Note: no *external* stacks in parallel/concurrent world */
DEBUG_STRING("Marking A Stack:");
RegisterTable ScanRegTable;
#ifndef PAR
-/* As we perform compaction, those CHP's which are still alive get
+/* As we perform compaction, those ForeignObjs which are still alive get
added to this list. [ADR] */
-StgPtr NewMallocPtrList;
+StgPtr NewForeignObjList;
#endif /* !PAR */
P_
Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words
#ifndef PAR
-, MallocPtrList
+, ForeignObjList
#endif
)
P_ base;
BitWord *bit_array;
I_ bit_array_words;
#ifndef PAR
- StgPtr *MallocPtrList;
+ StgPtr *ForeignObjList;
#endif
{
BitWord *bit_array_ptr, *bit_array_end;
New = base; /* used to unwind */
#ifndef PAR
- NewMallocPtrList = NULL; /* initialise new MallocPtrList */
- /* As we move MallocPtrs over, we'll add them to this list. */
+ NewForeignObjList = NULL; /* initialise new ForeignObjList */
+ /* As we move ForeignObjs over, we'll add them to this list. */
#endif /* !PAR */
while (bit_array_ptr < bit_array_end) {
Scan += size; /* skip size bits */
- if (size >= BITS_IN(BitWord)) break;
+ if ((W_) size >= BITS_IN(BitWord)) break;
/* NOTA BENE: if size >= # bits in BitWord, then the result
of this operation is undefined! Hence the need for
this break! */
New += size; /* set New address of next closure */
Scan += size; /* skip size bits */
- if (size >= BITS_IN(BitWord)) break;
+ if ((W_) size >= BITS_IN(BitWord)) break;
/* NOTA BENE: if size >= # bits in BitWord, then the result
of this operation is undefined! Hence the need for
this break! */
#ifdef PAR
RebuildLAGAtable();
#else
- VALIDATE_MallocPtrList( NewMallocPtrList );
- *MallocPtrList = NewMallocPtrList;
+ VALIDATE_ForeignObjList( NewForeignObjList );
+ *ForeignObjList = NewForeignObjList;
#endif /* PAR */
return(New);
#define SPEC_SLIDE_WORD(n) SLIDE_WORD((SPEC_HS-1) + (n))
#ifndef PAR
-/* Don't slide the MallocPtr list link - instead link moved object into
- @NewMallocPtrList@ */
+/* Don't slide the ForeignObj list link - instead link moved object into
+ @NewForeignObjList@ */
-#define MallocPtr_SLIDE_DATA \
- MallocPtr_CLOSURE_DATA(New) = MallocPtr_CLOSURE_DATA(Scan)
-#define MallocPtr_RELINK \
-{ \
- MallocPtr_CLOSURE_LINK(New) = NewMallocPtrList; \
- NewMallocPtrList = New; \
+#define ForeignObj_SLIDE_DATA \
+ ForeignObj_CLOSURE_DATA(New) = ForeignObj_CLOSURE_DATA(Scan); \
+ ForeignObj_CLOSURE_FINALISER(New) = ForeignObj_CLOSURE_FINALISER(Scan)
+#define ForeignObj_RELINK \
+{ \
+ ForeignObj_CLOSURE_LINK(New) = NewForeignObjList; \
+ NewForeignObjList = New; \
}
#endif /* !PAR */
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
I_
_ScanLink_RBH_2_1(STG_NO_ARGS)
{
#endif
\end{code}
-Scan-linking a MallocPtr is straightforward: exactly the same as
-@_ScanLink_[MallocPtr_SIZE]_0@.
+Scan-linking a ForeignObj is straightforward: exactly the same as
+@_ScanLink_[ForeignObj_SIZE]_0@.
\begin{code}
#ifndef PAR
I_
-_ScanLink_MallocPtr(STG_NO_ARGS) {
- I_ size = MallocPtr_SIZE;
- DEBUG_SCAN_LINK("MallocPtr", size, 0);
+_ScanLink_ForeignObj(STG_NO_ARGS) {
+ I_ size = ForeignObj_SIZE;
+ DEBUG_SCAN_LINK("ForeignObj", size, 0);
return(FIXED_HS + size);
}
#endif /* !PAR */
return(FIXED_HS + size);
}
-#if defined(PAR) && defined(GC_MUT_REQUIRED)
+#if (defined(PAR) || defined(GRAN)) && defined(GC_MUT_REQUIRED)
I_
_ScanMove_RBH_2(STG_NO_ARGS) {
I_ size = 2 + SPEC_RBH_VHS;
#endif
\end{code}
-Moving a Malloc Pointer is a little tricky: we want to copy the actual
-pointer unchanged (easy) but we want to link the MallocPtr into the
-new MallocPtr list.
+Moving a Foreign Object is a little tricky: we want to copy the actual
+pointer unchanged (easy) but we want to link the ForeignObj into the
+new ForeignObj list.
\begin{code}
#ifndef PAR
I_
-_ScanMove_MallocPtr(STG_NO_ARGS) {
- I_ size = MallocPtr_SIZE;
- DEBUG_SCAN_MOVE("MallocPtr", size);
+_ScanMove_ForeignObj(STG_NO_ARGS) {
+ I_ size = ForeignObj_SIZE;
+ DEBUG_SCAN_MOVE("ForeignObj", size);
#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
- printf("Moving MallocPtr(%x)=<%x,%x,%x>", Scan, Scan[0], Scan[1], Scan[2]);
- printf(" Data = %x, Next = %x\n",
- MallocPtr_CLOSURE_DATA(Scan), MallocPtr_CLOSURE_LINK(Scan) );
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
+ printf("Moving ForeignObj(%x)=<%x,%x,%x>", Scan, Scan[0], Scan[1], Scan[2]);
+ printf(" Data = %x, Finaliser = %x, Next = %x\n",
+ ForeignObj_CLOSURE_DATA(Scan),
+ ForeignObj_CLOSURE_FINALISER(Scan),
+ ForeignObj_CLOSURE_LINK(Scan) );
}
#endif
SLIDE_FIXED_HDR;
- MallocPtr_SLIDE_DATA;
- MallocPtr_RELINK;
+ ForeignObj_SLIDE_DATA;
+ ForeignObj_RELINK;
#if defined(DEBUG)
- if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
- printf("Moved MallocPtr(%x)=<%x,_,%x,%x,%x>", New, New[0], New[1], New[2], New[3]);
- printf(" Data = %x, Next = %x",
- MallocPtr_CLOSURE_DATA(New), MallocPtr_CLOSURE_LINK(New) );
- printf(", NewMallocPtrList = %x\n", NewMallocPtrList );
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_FOREIGNOBJS) {
+ printf("Moved ForeignObj(%x)=<%x,_,%x,%x,%x>", New, New[0], New[1], New[2], New[3]);
+ printf(" Data = %x, Finaliser = %x, Next = %x",
+ ForeignObj_CLOSURE_DATA(New),
+ ForeignObj_CLOSURE_FINALISER(New),
+ ForeignObj_CLOSURE_LINK(New) );
+ printf(", NewForeignObjList = %x\n", NewForeignObjList );
}
#endif
The linking code for revertible black holes with underlying @GEN@ closures.
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
I_
_ScanLink_RBH_N(STG_NO_ARGS)
fprintf(stderr, "Scav StkO: 0x%lx\n", \
Scav)
-# ifdef PAR
+# if defined(PAR) || defined(GRAN)
# define DEBUG_SCAV_RBH(s,p) \
if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Scav RBH: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
# define DEBUG_SCAV_BQ
# define DEBUG_SCAV_TSO
# define DEBUG_SCAV_STKO
-# ifdef PAR
+# if defined(PAR) || defined(GRAN)
# define DEBUG_SCAV_RBH(s,p)
# define DEBUG_SCAV_BF
# endif
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
# if defined(GCgn)
\begin{code}
#ifndef PAR
-/*** Malloc POINTER -- NOTHING TO SCAVENGE ***/
+/*** Foreign Object -- NOTHING TO SCAVENGE ***/
-/* (The MallocPtrList is updated at the end of GC and any unevacuated
- MallocPtrs reported to C World) [ADR]
+/* (The ForeignObjList is updated at the end of GC and any unevacuated
+ ForeignObjs are finalised) [ADR][SOF]
*/
void
-_Scavenge_MallocPtr(STG_NO_ARGS)
+_Scavenge_ForeignObj(STG_NO_ARGS)
{
- I_ size = MallocPtr_SIZE;
+ I_ size = ForeignObj_SIZE;
DEBUG_SCAV(size,0);
PROFILE_CLOSURE(Scav,size);
NEXT_Scav(size);
\begin{code}
-#ifdef PAR
+#if defined(PAR) || defined(GRAN)
void
_Scavenge_RBH_N(STG_NO_ARGS)
# define NULL_REG_MAP
# include "SMinternal.h"
-#ifndef CONCURRENT
+#if 1 /* ndef CONCURRENT */ /* HWL */
stackData stackInfo;
#endif
STKO_SIZE(MainStkO) = RTSflags.GcFlags.stksSize + STKO_VHS;
STKO_SpB(MainStkO) = STKO_SuB(MainStkO) = STKO_BSTK_BOT(MainStkO) + BREL(1);
STKO_SpA(MainStkO) = STKO_SuA(MainStkO) = STKO_ASTK_BOT(MainStkO) + AREL(1);
- STKO_LINK(MainStkO) = Nil_closure;
+ STKO_LINK(MainStkO) = Prelude_Z91Z93_closure;
STKO_RETURN(MainStkO) = NULL;
ASSERT(sanityChk_StkO(MainStkO));
+
+ if (RTSflags.GcFlags.trace)
+ fprintf(stderr, "STACK init: botA, spa: 0x%lx, 0x%lx\n botB, spb: 0x%lx, 0x%lx\n",
+ (W_) STKO_ASTK_BOT(MainStkO), (W_) STKO_SpA(MainStkO), (W_) STKO_BSTK_BOT(MainStkO), (W_) STKO_SpB(MainStkO));
#endif
}
# endif
/* Initialise Stack Info and pointers */
-#ifndef CONCURRENT
+#if 1 /* ndef CONCURRENT */ /* HWL */
stackInfo.botA = STK_A_FRAME_BASE(stks_space, RTSflags.GcFlags.stksSize);
stackInfo.botB = STK_B_FRAME_BASE(stks_space, RTSflags.GcFlags.stksSize);
***************************************************************************
-@CZh_entry@, @CZh_static_info@, @IZh_entry@ and @IZh_static_info@
+@Prelude_CZh_entry@, @Prelude_CZh_static_info@, @Prelude_IZh_entry@ and @Prelude_IZh_static_info@
are built by the compiler from {\tr uTys.hs}.
\begin{code}
#define NULL_REG_MAP
#include "SMinternal.h"
-EXTDATA_RO(CZh_static_info);
+EXTDATA_RO(Prelude_CZh_static_info);
+EXTDATA_RO(Prelude_IZh_static_info);
#define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1)))
#define __INTLIKE_CLOSURE(n) (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1)))
-#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),CZh_static_info,CC_DONTZuCARE), (W_) n
+#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),Prelude_CZh_static_info,CC_DONTZuCARE), (W_) n
-#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),IZh_static_info,CC_DONTZuCARE), (W_) n
+#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),Prelude_IZh_static_info,CC_DONTZuCARE), (W_) n
const W_ CHARLIKE_closures[] = {
CHARLIKE_HDR(0),
CHARLIKE_HDR(255)
};
-EXTDATA_RO(IZh_static_info);
-
static const W_ INTLIKE_closures_def[] = {
INTLIKE_HDR(-16), /* MIN_INTLIKE == -16 */
INTLIKE_HDR(-15),
*********************************************************************
\begin{code}
+#define NON_POSIX_SOURCE /*needed for solaris2 only?*/
+
+/* how is this to work given we have not read platform.h yet? */
#ifdef hpux_TARGET_OS
#define _INCLUDE_HPUX_SOURCE
#endif
#include <sys/resource.h>
#endif
+/* Needed for Solaris2 */
+#if /* defined(HAVE_SYS_RUSAGE_H) && */ defined(solaris2_TARGET_OS)
+#include <sys/rusage.h>
+#endif
+
#ifdef HAVE_SYS_TIMEB_H
#include <sys/timeb.h>
#endif
Is @mprotect@ POSIX now?
\begin{code}
-
#if STACK_CHECK_BY_PAGE_FAULT
/* #define STK_CHK_DEBUG */
# if defined(HAVE_GETPAGESIZE)
# define GETPAGESIZE() getpagesize()
# else
-# error getpagesize
+# if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS)
+# /* it has it, but it is in BSD land; easier to just say so */
+# define GETPAGESIZE() getpagesize()
+# else
+# error getpagesize
+# endif
# endif
# endif
extern int mprotect PROTO((caddr_t, size_t, int));
#endif
+/* Needed for FreeBSD (SDM, 96/03) */
+#ifndef PROT_NONE
+#define PROT_NONE 0
+#endif
+
void
unmapMiddleStackPage(addr_, size)
char * /*caddr_t*/ addr_;
}
#endif /* STACK_CHECK_BY_PAGE_FAULT */
-
\end{code}
+++ /dev/null
-\begin{onlystandalone}
-\documentstyle[11pt,literate]{article}
-\begin{document}
-\title{GRIP Runtime Support for Threads}
-\author{Kevin Hammond, \\
-Department of Computing Science, \\
-University of Glasgow, \\
-Glasgow, G12 8QQ, UK. \\
-\\
-Email: glasgow-haskell-\{request,bugs\}\@dcs.glasgow.ac.uk}
-\maketitle
-\tableofcontents
-\clearpage
-\end{onlystandalone}
-
-\input{grip/Scheduler.lc}
-\input{grip/Spark.lc}
-\input{grip/Thread.lc}
-\input{grip/ParInit.lc}
-
-\begin{onlystandalone}
-%\printindex
-\end{document}
-\end{onlystandalone}
fprintf(psfp, "gsave\n");
- fprintf(psfp, "%f setgray\n", shade);
+ SetPSColour(shade);
fprintf(psfp, "fill\n");
fprintf(psfp, "grestore\n");
printf(" -s use small title box\n");
printf(" -tf ignore trace bands which sum below f%% (default 1%%, max 5%%)\n");
printf(" -y traditional\n");
+ printf(" -c colour ouput\n");
exit(0);
}
fprintf(psfp, "closepath\n");
fprintf(psfp, "gsave\n");
- fprintf(psfp, "%f setgray\n", colour);
+ SetPSColour(colour);
fprintf(psfp, "fill\n");
fprintf(psfp, "grestore\n");
fprintf(psfp, "stroke\n");
boolish sflag = 0; /* use a small title box */
int mflag = 0; /* max no. of bands displayed (default 20) */
boolish tflag = 0; /* ignored threshold specified */
+boolish cflag = 0; /* colour output */
boolish filter; /* true when running as a filter */
if (THRESHOLD_PERCENT < 0 || THRESHOLD_PERCENT > 5)
Usage(*argv-1);
goto nextarg;
+ case 'c':
+ cflag++;
+ goto nextarg;
case '?':
default:
Usage(*argv-1);
extern boolish sflag;
extern int mflag;
extern boolish tflag;
+extern boolish cflag;
extern char *programname;
-#define N_SHADES 10
+#define N_MONO_SHADES 10
-static floatish shades[ N_SHADES ] = {
+static floatish m_shades[ N_MONO_SHADES ] = {
0.00000, 0.20000, 0.60000, 0.30000, 0.90000,
0.40000, 1.00000, 0.70000, 0.50000, 0.80000
};
+#define N_COLOUR_SHADES 27
+
+/* HACK: 0.100505 means 100% red, 50% green, 50% blue */
+
+static floatish c_shades[ N_COLOUR_SHADES ] = {
+ 0.000000, 0.000010, 0.001000, 0.001010, 0.100000,
+ 0.100010, 0.101000, 0.101010, 0.000005, 0.000500,
+ 0.000510, 0.001005, 0.050000, 0.050010, 0.051000,
+ 0.051010, 0.100005, 0.100500, 0.100510, 0.101005,
+ 0.000505, 0.050005, 0.050500, 0.050510, 0.051005,
+ 0.100505, 0.050505
+};
+
static floatish
ThinkOfAShade()
{
- static int thisshade = 0;
+ static int thisshade = -1;
floatish x;
- x = shades[ thisshade ];
- thisshade = (thisshade + 1) % N_SHADES;
- return x;
+ thisshade++;
+ return cflag ?
+ c_shades[ thisshade % N_COLOUR_SHADES ] :
+ m_shades[ thisshade % N_MONO_SHADES ] ;
+}
+
+static floatish
+extract_colour(shade,factor)
+ floatish shade;
+ intish factor;
+{
+ intish i,j;
+
+ i = (int)(shade * factor);
+ j = i / 100;
+ return (i - j * 100) / 10.0;
+}
+
+void
+SetPSColour(shade)
+ floatish shade;
+{
+ if (cflag) {
+ fprintf(psfp, "%f %f %f setrgbcolor\n",
+ extract_colour(shade, 100),
+ extract_colour(shade, 10000),
+ extract_colour(shade,1000000));
+ } else {
+ fprintf(psfp, "%f setgray\n", shade);
+ }
}
extern floatish ShadeOf PROTO((char *));
extern void ShadeFor PROTO((char *, floatish));
+extern void SetPSColour PROTO((floatish));
#endif /* SHADE_H */
if ($#tospec >= 0) {
$specty = shift(@tospec);
- print ($data_or_inst ? "{-# SPECIALIZE $data_inst_str $specty #-}" : "$space{-# SPECIALIZE $fun :: $specty");
+ print ($data_or_inst ? "\{-# SPECIALIZE $data_inst_str $specty #-\}" : "$space\{-# SPECIALIZE $fun :: $specty");
while ($#tospec >= 0) {
$specty = shift(@tospec);
- print ($data_or_inst ? "; {-# SPECIALIZE $data_inst_str $specty #-}" : ", $specty");
+ print ($data_or_inst ? "; \{-# SPECIALIZE $data_inst_str $specty #-\}" : ", $specty");
}
print ($data_or_inst ? "\n" : " #-}\n");
} else {
- print "{- NO_SPECS_GENERATED ", $data_or_inst ? $specty : $fun, " -}\n";
+ print "\{- NO_SPECS_GENERATED ", $data_or_inst ? $specty : $fun, " -\}\n";
print STDERR "Warning: No specs for GENERATE_SPECS pre-processing pragma:\n $_";
}
print $tysig if ! $data_or_inst;
# ToDo: strip out all the .h junk
#
($Pgm = $0) =~ s/.*\/([^\/]+)$/\1/;
-$Usage = "usage: $Pgm: not done yet\n";
+$Usage = <<EOUSAGE;
+Usage: $Pgm [mkdependHS options] [-- GHC options --] srcfile1 [srcfile2 ...]
+
+Options recognised wherever they occur (mkdependHS or GHC):
+
+ -D<blah> A cpp #define; usual meaning
+ -i<dirs> Add <dirs> (colon-separated) to list of directories
+ to search for "import"ed modules
+ -I<dir> Add <dir> to list of directories to search for
+ .h files (i.e., usual meaning)
+ -syslib <blah> This program uses this GHC system library; take
+ appropriate action (e.g., recognise when they are
+ "import"ing a module from that library).
+ -fhaskell1.[2-9] Deal with the oddities associated with a
+ particular version of Haskell 1.
+ -ignore <mod>
+
+mkdependHS-specific options (not between --'s):
+
+ -v Be verbose.
+ -v -v Be very verbose.
+ -f blah Use "blah" as the makefile, rather than "makefile"
+ or "Makefile".
+ -o <osuf> Use <osuf> as the "object file" suffix ( default: .o)
+ -s <suf> Make extra dependencies for files with
+ suffix <suf><osuf>; thus, "-o .hc -s _a" will
+ make dependencies both for .hc files and for _a.hc
+ files. (Useful in conjunction with NoFib "ways".)
+ -x <file> Regard <file> as "stable"; i.e., eXclude it from having
+ dependencies on it.
+EOUSAGE
$Status = 0; # just used for exit() status
-$Verbose = '';
+$Verbose = 0; # 1 => verbose, 2 => very verbose
$Dashdashes_seen = 0;
+# Try to guess how to run gcc's CPP directly -------------
+
$OrigCpp = '$(RAWCPP)';
-if ( $OrigCpp =~ /(\S+)\s+(.*)/ ) {
+if ( $OrigCpp !~ /(\S+)\s+(.*)/ ) {
+ $Cpp = $OrigCpp;
+} else {
$cmd = $1;
$rest = $2;
if ( -x $cmd ) { # cool
die "hscpp: don't know how to run cpp: $OrigCpp\n";
}
}
-} else {
- $Cpp = $OrigCpp;
}
if ( $ENV{'TMPDIR'} ) { # where to make tmp file names
$End_magic_str = "# DO NOT DELETE: End of Haskell dependencies\n";
$Obj_suffix = '.o';
$ghc_version_info = $(PROJECTVERSION) * 100;
-@Defines = ('-D__HASKELL1__=2', "-D__GLASGOW_HASKELL__=$ghc_version_info");
$Import_dirs = '.';
%Syslibs = ();
-%StableLibs = ();
-%PreludeIfaces = ( 'Prelude', '1',
- 'PreludeGlaST', '1',
- 'PreludeGlaMisc', '1',
- 'Concurrent', '1',
- 'Parallel', '1');
+%IgnoreMe = ();
+%PreludeIfaces = ( 'Prelude', '1',
+ , 'Array', '1'
+ , 'Char', '1'
+ , 'Complex', '1'
+ , 'Directory', '1'
+ , 'IO', '1'
+ , 'Ix', '1'
+ , 'List', '1'
+ , 'Maybe', '1'
+ , 'Monad', '1'
+ , 'Ratio', '1'
+ , 'System', '1'
+ , 'PreludeGlaST', '1'
+ , 'PreludeGlaMisc','1'
+ , 'Concurrent', '1'
+ , 'Parallel', '1');
%GhcLibIfaces = ( 'Bag', '1',
'BitSet', '1',
# CharSeq not supposed to be used by user (I think. WDP)
'LibPosix', '1',
'LibTime', '1' );
-$Haskell_1_3 = 0; # assume Haskell 1.2, still. Changed by -fhaskell-1.3
+$Haskell_1 = 2; # assume Haskell 1.2, still. Changed by -fhaskell-1.3
$Include_dirs = '-I.';
-$Col_width = 78; # ignored
$Makefile = '';
@Src_files = ();
&mangle_command_line_args();
+if ( $Status ) {
+ print stderr $Usage;
+ exit(1);
+}
+
+push(@Defines,
+ ("-D__HASKELL1__=$Haskell_1",
+ "-D__GLASGOW_HASKELL__=$ghc_version_info"));
+
+@Import_dirs = split(/:/,$Import_dirs);
+@Include_dirs = split(/\s+/,$Include_dirs); # still has -I's in it
+# NB: We keep the scalar-variable equivalents to use in error messages
+
if ( ! $Makefile && -f 'makefile' ) {
$Makefile = 'makefile';
} elsif ( ! $Makefile && -f 'Makefile') {
$Makefile = 'Makefile';
-} else {
+} elsif ( ! $Makefile) {
die "$Pgm: no makefile or Makefile found\n";
}
-@Depend_lines = ();
-
print STDERR "CPP defines=@Defines\n" if $Verbose;
-print STDERR "Import_dirs=$Import_dirs\n" if $Verbose;
-print STDERR "Include_dirs=$Include_dirs\n" if $Verbose;
+print STDERR "Import_dirs=@Import_dirs\n" if $Verbose;
+print STDERR "Include_dirs=@Include_dirs\n" if $Verbose;
+
+&preprocess_import_dirs();
+
+@Depend_lines = ();
foreach $sf (@Src_files) {
# just like lit-inputter
}
close(NMKF) || exit(1);
close(OMKF) || exit(1);
-chmod 0444, 'Makefile';
exit 0;
sub mangle_command_line_args {
$Include_dirs .= " $_";
} elsif ( /^-syslib$/ ) {
push(@Syslibs, &grab_arg_arg($_,''));
- } elsif ( /^-fhaskell-1\.3/ ) {
- $Haskell_1_3 = 1;
- } elsif ( /^-stable$/ ) {
- # user-defined syslibs that she believes are stable.
- push(@StableLibs, &grab_arg_arg($_,''));
-
+ } elsif ( /^-fhaskell-1\.([2-9])/ ) {
+ $Haskell_1 = $1;
} elsif ($Dashdashes_seen != 1) { # not between -- ... --
if ( /^-v$/ ) {
- $Verbose = '-v';
+ $Verbose++;
} elsif ( /^-f(.*)/ ) {
$Makefile = &grab_arg_arg('-f',$1);
} elsif ( /^-o(.*)/ ) {
$Obj_suffix = &grab_arg_arg('-o',$1);
+ } elsif ( /^-x(.*)/ ) {
+ local($thing) = &grab_arg_arg($_,$1);
+ $IgnoreMe{$thing} = 'y';
} elsif ( /^-s(.*)/ ) {
local($suff) = &grab_arg_arg('-s',$1);
- $File_suffix{$suff} = $suff;
- } elsif ( /^-bs(.*)/ ) {
- $Begin_magic_str = &grab_arg_arg('-bs',$1) . "\n";
- } elsif ( /^-es(.*)/ ) {
- $End_magic_str = &grab_arg_arg('-es',$1) . "\n";
- } elsif ( /^-w(.*)/ ) {
- $Width = &grab_arg_arg('-w',$1);
+ push(@File_suffix, $suff);
} elsif ( /^-/ ) {
print STDERR "$Pgm: unknown option ignored: $_\n";
+ $Status++;
} else {
push(@Src_files, $_);
}
} elsif ($Dashdashes_seen == 1) { # where we ignore unknown options
- push(@Src_files,$_) if ! /^-/;
+ push(@Src_files, $_) if ! /^-/;
}
}
- @File_suffix = sort (keys %File_suffix);
+ @File_suffix = sort (@File_suffix);
}
sub grab_arg_arg {
}
}
+sub preprocess_import_dirs {
+ # it's probably cheaper to find out what's in all
+ # the @Import_dirs before we start processing.
+ local($d, $thing);
+ local($_);
+ %ModuleIn = ();
+
+ foreach $d ( @Import_dirs ) {
+ opendir(DIR, $d) || die "$Pgm: can't open directory $d\n";
+
+ for ($_ = readdir(DIR); $_; $_ = readdir(DIR)) {
+ next unless /(.*)\.hi$/;
+ $thing = $1;
+ if ($ModuleIn{$thing} && $ModuleIn{$thing} ne $d) {
+ print STDERR "$Pgm: warning: $thing.hi appears in both $ModuleIn{$thing} and $d!\n";
+ } else {
+ $ModuleIn{$thing} = $d;
+ }
+ }
+ closedir(DIR); # No, don't check the error code
+ }
+}
+
sub slurp_file_for_imports {
local($file_to_read, $orig_src_file) = @_;
local($follow_file);
|| die "$Pgm: Can't open $file_to_read: $!\n";
while (<SRCFILE>) {
- if (/^>?\s*import\s+([A-Z][A-Za-z0-9_']*)/ || /^!include\s+"(\S+)"/) {
- $modname = $1;
- if (/^>?\s*import/) {
- $follow_file = &find_in_Import_dirs($orig_src_file, $modname, $last_seen_dir);
+ next unless (/^>?\s*(import)\s+([A-Z][A-Za-z0-9_']*)/ || /^!(include)\s+"(\S+)"/);
+ $todo = $1;
+ $modname = $2;
+
+ if ($todo eq 'import') {
+ if ( $IgnoreMe{$modname} eq 'y' ) {
+ $follow_file = '__ignore__';
+ } elsif ( $ModuleIn{$modname} ) {
+ $follow_file = "$ModuleIn{$modname}/$modname.hi";
+ } else { # hard way
+ $follow_file
+ = &find_in_Import_dirs($orig_src_file, $modname, $last_seen_dir);
+ }
+ } else {
+ if ( $IgnoreMe{$modname} eq 'y' ) {
+ $follow_file = '__ignore__';
} else {
- $follow_file = &find_in_Include_dirs($orig_src_file, $modname, $last_seen_dir);
+ $follow_file
+ = &find_in_Include_dirs($orig_src_file, $modname, $last_seen_dir);
}
+ }
- if ($follow_file) { # it found something
-
- if ($follow_file ne '__syslib__') {
- local($int_file);
- $int_file = $follow_file;
- if ( $int_file !~ /\.(l?hs|hi)$/ ) {
- push(@Depend_lines, "$bf$Obj_suffix : $int_file\n");
- foreach $suff (@File_suffix) {
- push(@Depend_lines, "$bf$suff$Obj_suffix : $int_file\n");
- }
-
- } else {
- $int_file =~ s/\.l?hs$//;
- $int_file =~ s/\.hi$//;
-
- push(@Depend_lines, "$bf$Obj_suffix : $int_file.hi\n");
- foreach $suff (@File_suffix) {
- push(@Depend_lines, "$bf$suff$Obj_suffix : $int_file$suff.hi\n");
- }
+ if (! $follow_file) { # it didnae find anything
+ die "$orig_src_file: Couldn't handle: $_\n";
+
+ } else { # it found something
+ if ($follow_file ne '__ignore__') {
+ local($int_file);
+ $int_file = $follow_file;
+
+ if ( $int_file !~ /\.(l?hs|hi)$/ ) {
+ push(@Depend_lines, "$bf$Obj_suffix : $int_file\n");
+ foreach $suff (@File_suffix) {
+ push(@Depend_lines, "$bf$suff$Obj_suffix : $int_file\n");
+ }
+
+ } else {
+ $int_file =~ s/\.l?hs$//;
+ $int_file =~ s/\.hi$//;
+
+ push(@Depend_lines, "$bf$Obj_suffix : $int_file.hi\n");
+ foreach $suff (@File_suffix) {
+ push(@Depend_lines, "$bf$suff$Obj_suffix : $int_file$suff.hi\n");
}
}
- } else {
- die "$orig_src_file: Couldn't handle: $_\n";
- }
+ }
}
}
close(SRCFILE) || exit(1);
local($do_magical_check) = 0;
local($name_to_check);
- # hop along Import_dir list
- foreach $import_dir (split(/:/,$Import_dirs)) {
+ # do it the old hard way: hop along Import_dir list
+ foreach $import_dir (@Import_dirs) {
# handle . magically
if ($import_dir eq '.') {
# record that we should do a SPECIAL try for a file in last_seen_dir (LAST)
$name_to_check = "$import_dir/$modname.hi";
if ( $FileExists{$name_to_check} ne 'n' ) { # either 'y' or nothing
- print STDERR "trying $name_to_check...\n" if $Verbose;
+ print STDERR "trying $name_to_check...\n" if $Verbose >= 2; # very verbose
return($name_to_check) if $FileExists{$name_to_check} eq 'y';
if (-f $name_to_check) {
$FileExists{$name_to_check} = 'y';
}
$name_to_check = "$import_dir/$modname.hs";
- print STDERR "trying... $name_to_check\n" if $Verbose;
+ print STDERR "trying... $name_to_check\n" if $Verbose >= 2; # very verbose
return($name_to_check) if -f $name_to_check;
$name_to_check = "$import_dir/$modname.lhs";
- print STDERR "trying... $name_to_check\n" if $Verbose;
+ print STDERR "trying... $name_to_check\n" if $Verbose >= 2; # very verbose
return($name_to_check) if -f $name_to_check;
}
if ($do_magical_check == 1) {
$name_to_check = "$last_seen_dir/$modname.hi";
if ( $FileExists{$name_to_check} ne 'n' ) { # either 'y' or nothing
- print STDERR "trying $name_to_check...\n" if $Verbose;
+ print STDERR "trying $name_to_check...\n" if $Verbose >= 2; # very verbose
return($name_to_check) if $FileExists{$name_to_check} eq 'y';
if (-f $name_to_check) {
$FileExists{$name_to_check} = 'y';
}
$name_to_check = "$last_seen_dir/$modname.lhs";
- print STDERR "trying... $name_to_check\n" if $Verbose;
+ print STDERR "trying... $name_to_check\n" if $Verbose >= 2; # very verbose
return($name_to_check) if -f $name_to_check;
$name_to_check = "$last_seen_dir/$modname.hs";
- print STDERR "trying... $name_to_check\n" if $Verbose;
+ print STDERR "trying... $name_to_check\n" if $Verbose >= 2; # very verbose
return($name_to_check) if -f $name_to_check;
}
# OK, maybe it's referring to something in a system library
foreach $lib ( @Syslibs ) {
if ( $lib eq 'ghc' ) {
- return('__syslib__') if $GhcLibIfaces{$modname};
+ return('__ignore__') if $GhcLibIfaces{$modname};
} elsif ( $lib eq 'hbc' ) {
- return('__syslib__') if $HbcLibIfaces{$modname};
+ return('__ignore__') if $HbcLibIfaces{$modname};
} else {
die "Unrecognised syslib: $lib\n";
}
}
- # HACK HACK: Let the user define his own "stable" modules.
- foreach $stableLib ( @StableLibs ) {
- return('__syslib__') if ( $stableLib eq $modname );
- }
-
# Might be a Haskell 1.3 Module (but only if we've said -fhaskell-1.3)
- if ( $Haskell_1_3 == 1 ) {
- return('__syslib__') if $IO13Ifaces{$modname};
+ if ( $Haskell_1 >= 3 ) {
+ return('__ignore__') if $IO13Ifaces{$modname};
}
# Last hope: referring to a Prelude interface
- return('__syslib__') if $PreludeIfaces{$modname};
+ return('__ignore__') if $PreludeIfaces{$modname};
die "No file `$modname.hi', `$modname.lhs' or `$modname.hs' (reqd from file `$orig_src_file')\namong import directories:\n\t$Import_dirs\n";
}
# no funny name guessing here
# hop along Include_dir list
- foreach $include_dir (split(/\s+/,$Include_dirs)) {
+ foreach $include_dir (@Include_dirs) {
$include_dir =~ s/^-I//;
# handle . magically
# record that we should do a SPECIAL try for a file in last_seen_dir (LAST)
$do_magical_check = 1;
}
- print STDERR "trying $include_dir/$name...\n" if $Verbose;
+ print STDERR "trying $include_dir/$name...\n" if $Verbose >= 2; # very verbose
if (-f "$include_dir/$name") {
return("$include_dir/$name");
}
}
if ($do_magical_check == 1) {
- print STDERR "trying $last_seen_dir/$name...\n" if $Verbose;
+ print STDERR "trying $last_seen_dir/$name...\n" if $Verbose >= 2; # very verbose
if (-f "$last_seen_dir/$name") {
return("$last_seen_dir/$name");
}
$the_stats{"mut_elap_$row"} = $2 - $tot_gc_elap - $tot_mut_elap;
next arg; };
- /GC time\s+([\d\.]+)s\s+\(\s*([\d.]+)s elapsed\)/ && do {
+ /GC\s+time\s+([\d\.]+)s\s+\(\s*([\d.]+)s elapsed\)/ && do {
# $1 == $tot_gc_user || die "GCuser $1 != $tot_gc_user \n";
# $2 == $tot_gc_elap || die "GCelap $2 != $tot_gc_elap \n";
$the_stats{"gc_user_total"} = $tot_gc_user;
$the_stats{"gc_elap_total"} = $tot_gc_elap;
next arg; };
- /MUT time/ && do { next arg; };
+ /MUT\s+time/ && do { next arg; };
+ /INIT\s+time/ && do { next arg; };
+ /^\s*([\d,]+) bytes maximum residency/ && do { next arg; };
/\%GC time/ && do { next arg; };
/Alloc rate/ && do { next arg; };
YaccRunWithExpectMsg(syntax,no,no)
-UgenTarget(tree)
+UgenTarget(.,tree)
CDependTarget( $(SRCS_C) )
fprintf(fh, "#define PROTO(x) /**/\n");
fprintf(fh, "#endif\n");
fprintf(fh, "#endif\n\n");
+ fprintf(fh, "#ifdef UGEN_DEBUG\n");
+ fprintf(fh, "int\tfprintf PROTO((FILE *, const char *, ...));\n");
+ fprintf(fh, "#endif /* UGEN_DEBUG */\n\n");
fprintf(fh, "typedef enum {\n");
ge_typlist(gtdeflist(t));
fprintf(fh, "\n} T%s;\n\n", gtid(t));
projects / ghc-hetmet.git / commitdiff