From: partain Date: Thu, 27 Jun 1996 16:16:52 +0000 (+0000) Subject: [project @ 1996-06-27 16:13:29 by partain] X-Git-Tag: Approximately_1000_patches_recorded~906 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=769ce8e72ae626356ce57162b7ff448c0ef7e700 [project @ 1996-06-27 16:13:29 by partain] partain 1.3 changes to 960626 --- diff --git a/ghc/mkworld/GHC_OPTS b/ghc/mkworld/GHC_OPTS index 094f1a4..df06f3c 100644 --- a/ghc/mkworld/GHC_OPTS +++ b/ghc/mkworld/GHC_OPTS @@ -2,33 +2,33 @@ 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,) diff --git a/ghc/mkworld/install-ghc.jm b/ghc/mkworld/install-ghc.jm index e69de29..abcb916 100644 --- a/ghc/mkworld/install-ghc.jm +++ b/ghc/mkworld/install-ghc.jm @@ -0,0 +1,9 @@ +#if 0 +%************************************************************************ +%* * +\section[mkworld-install-ghc]{Installation stuff for @ghc@ project} +%* * +%************************************************************************ + +NONE. +#endif diff --git a/ghc/mkworld/install-ghc.ljm b/ghc/mkworld/install-ghc.ljm deleted file mode 100644 index 69267af..0000000 --- a/ghc/mkworld/install-ghc.ljm +++ /dev/null @@ -1,7 +0,0 @@ -%************************************************************************ -%* * -\section[mkworld-install-ghc]{Installation stuff for @ghc@ project} -%* * -%************************************************************************ - -NONE. diff --git a/ghc/mkworld/macros-ghc.jm b/ghc/mkworld/macros-ghc.jm index 3c9d84b..bbe0bca 100644 --- a/ghc/mkworld/macros-ghc.jm +++ b/ghc/mkworld/macros-ghc.jm @@ -1,23 +1,20 @@ -# 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 */ diff --git a/ghc/mkworld/macros-ghc.ljm b/ghc/mkworld/macros-ghc.ljm deleted file mode 100644 index 0271d47..0000000 --- a/ghc/mkworld/macros-ghc.ljm +++ /dev/null @@ -1,31 +0,0 @@ -%************************************************************************ -%* * -\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} diff --git a/ghc/mkworld/only4-ghc.jm b/ghc/mkworld/only4-ghc.jm index 157c115..15b1c0f 100644 --- a/ghc/mkworld/only4-ghc.jm +++ b/ghc/mkworld/only4-ghc.jm @@ -1,4 +1,12 @@ -# 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 @@ -6,7 +14,7 @@ #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 @@ -14,9 +22,14 @@ #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 @@ -25,12 +38,24 @@ GHC_LIBSRC = $(TOP)/ghc/lib 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 @@ -60,7 +85,23 @@ GHC_RTS_STYLE = 'ghc' 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 @@ -73,13 +114,23 @@ GHCFLAGS=$(GLUED_CPP_DEFINES) $(GLUED_GHC_OPTS) #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 @@ -114,12 +165,49 @@ INSTBINDIR_GHC = InstBinDir_GHC 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 @@ -133,7 +221,16 @@ __SomeUtilNeededHere(target,$(GHC),$(GHC_DRIVERSRC),all) /* 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 @@ -145,7 +242,12 @@ __SomeUtilNeededHere(target,$(GHC_HSCPP),$(GHC_HSCPPSRC),hscpp) 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 @@ -157,7 +259,12 @@ __SomeUtilNeededHere(target,$(GHC_HSP),$(GHC_HSPSRC),hsp) 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 @@ -169,7 +276,12 @@ __SomeUtilNeededHere(target,$(GHC_HSC),$(GHC_HSCSRC),hsc) 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 @@ -181,7 +293,52 @@ __SomeUtilNeededHere(target,$(GHC_SYSMAN),$(GHC_SYSMANSRC),gum/SysMan) 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 @@ -203,7 +360,7 @@ GHC_SYSMANSRC = $(GHC_RUNTIMESRC) #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 @@ -229,3 +386,6 @@ GHC_GCC_IS_AVAILABLE = 0 #endif /* ! gcc */ #endif /* GhcOptHighLevelAsmCmd */ GHC_OPT_HILEV_ASM = GhcOptHighLevelAsmCmd +#if 0 +\end{code} +#endif /* 0 */ diff --git a/ghc/mkworld/only4-ghc.ljm b/ghc/mkworld/only4-ghc.ljm deleted file mode 100644 index 30e51e1..0000000 --- a/ghc/mkworld/only4-ghc.ljm +++ /dev/null @@ -1,367 +0,0 @@ -%************************************************************************ -%* * -\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} diff --git a/ghc/mkworld/site-ghc.jm.in b/ghc/mkworld/site-ghc.jm.in index 093cbbe..2fea38b 100644 --- a/ghc/mkworld/site-ghc.jm.in +++ b/ghc/mkworld/site-ghc.jm.in @@ -80,9 +80,18 @@ GHC_WITH_NATIVE_CODEGEN=GhcWithNativeCodeGen /* ================================================================ 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 @@ -91,7 +100,7 @@ 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 @@ -100,7 +109,7 @@ 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 @@ -109,7 +118,7 @@ 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 @@ -120,7 +129,7 @@ GHC_BUILD_FLAG_u = -build-u-not-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 @@ -129,7 +138,7 @@ 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 @@ -138,7 +147,7 @@ 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 @@ -147,7 +156,7 @@ 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 @@ -156,7 +165,7 @@ 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 @@ -170,7 +179,7 @@ GHC_BUILD_FLAG_mg = -build-mg-not-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 @@ -179,7 +188,7 @@ 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 @@ -188,7 +197,7 @@ 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 @@ -199,210 +208,176 @@ GHC_BUILD_FLAG_du = -build-du-not-defined /* === 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 ==================================== */ diff --git a/ghc/mkworld/suffixes-ghc.jm b/ghc/mkworld/suffixes-ghc.jm index 31af401..4d6f419 100644 --- a/ghc/mkworld/suffixes-ghc.jm +++ b/ghc/mkworld/suffixes-ghc.jm @@ -1,4 +1,27 @@ -# 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 */ diff --git a/ghc/mkworld/suffixes-ghc.ljm b/ghc/mkworld/suffixes-ghc.ljm deleted file mode 100644 index 968270a..0000000 --- a/ghc/mkworld/suffixes-ghc.ljm +++ /dev/null @@ -1,14 +0,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} -#ifndef SuffixRules_WantStdOnes -#define SuffixRules_WantStdOnes NO -#endif -\end{code} diff --git a/ghc/mkworld/utils-ghc.jm b/ghc/mkworld/utils-ghc.jm index d1421da..480d54f 100644 --- a/ghc/mkworld/utils-ghc.jm +++ b/ghc/mkworld/utils-ghc.jm @@ -1,4 +1,15 @@ -# 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 @@ -33,7 +44,7 @@ #ifndef ProjectJmakeDefines #define ProjectJmakeDefines /*none*/ #endif -# line 48 "utils-ghc.ljm" + #ifndef MkDependHSSrc #define MkDependHSSrc $(GHC_UTILSRC)/mkdependHS #endif @@ -70,7 +81,7 @@ __SomeUtilNeededHere(target,$(GHC_UNLIT),$(GHC_UNLITSRC),unlit) GHC_UNLIT = UnlitCmd GHC_UNLITSRC = $(GHC_UTILSRC)/unlit -# line 87 "utils-ghc.ljm" + #ifndef HsTagsSrc #define HsTagsSrc $(GHC_UTILSRC)/hstags #endif diff --git a/ghc/mkworld/utils-ghc.ljm b/ghc/mkworld/utils-ghc.ljm deleted file mode 100644 index 3338ab2..0000000 --- a/ghc/mkworld/utils-ghc.ljm +++ /dev/null @@ -1,144 +0,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} -#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} diff --git a/ghc/runtime/Jmakefile b/ghc/runtime/Jmakefile index 84e3897..e9f29c3 100644 --- a/ghc/runtime/Jmakefile +++ b/ghc/runtime/Jmakefile @@ -35,6 +35,7 @@ SUBDIRS = gmp regex GhcDriverNeededHere(depend all) /* we use its C-compiling know-how */ EtagsNeededHere(tags) +UnlitNeededHere(depend) /**************************************************************** * * @@ -48,7 +49,7 @@ strictly speaking), it will probably work -- it is pinned onto 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 @@ -144,11 +145,17 @@ CLIB_LC = \ 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 \ @@ -165,9 +172,13 @@ CLIB_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 \ @@ -176,11 +187,13 @@ CLIB_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 @@ -194,9 +207,9 @@ all depend :: $(H_FILES) 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) /**************************************************************** * * @@ -205,34 +218,34 @@ LitSuffixRule(.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) @@ -259,10 +272,16 @@ CompileClibishly(hooks/ErrorHdr,) 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,) @@ -280,9 +299,13 @@ CompileClibishly(io/getClockTime,) 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,) @@ -291,26 +314,26 @@ CompileClibishly(io/seekFile,) 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 @@ -453,12 +476,12 @@ IfGhcBuild_B(DoRtsFile(file,isuf,_B, flags $(GHC_OPTS_B))) 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,) @@ -476,9 +499,9 @@ CompileRTSishly(main/SMRep,.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,) @@ -500,7 +523,7 @@ CompileRTSishly(storage/SMevac,.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,) @@ -522,8 +545,3 @@ CTagsTarget( gmp/[a-z]*.c ) CTagsTarget( regex/[a-z]*.c ) CDependTarget( $(RTS_LC) $($RTS_LHC) $(CLIB_LC) ) - -LitStuffNeededHere(docs depend) -InfoStuffNeededHere(docs) - -/*LitDocRootTargetWithNamedOutput(threadroot,lit,threadroot-standalone)*/ diff --git a/ghc/runtime/c-as-asm/CallWrap_C.lc b/ghc/runtime/c-as-asm/CallWrap_C.lc index 66591d1..7985735 100644 --- a/ghc/runtime/c-as-asm/CallWrap_C.lc +++ b/ghc/runtime/c-as-asm/CallWrap_C.lc @@ -207,10 +207,7 @@ W_ args; 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; @@ -226,8 +223,74 @@ void PerformReschedule_wrapper(liveness, always_reenter_node) 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. @@ -254,14 +317,3 @@ checkInCCallGC() } \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} diff --git a/ghc/runtime/c-as-asm/FreeMallocPtr.lc b/ghc/runtime/c-as-asm/FreeMallocPtr.lc index f29ade0..8dd9d03 100644 --- a/ghc/runtime/c-as-asm/FreeMallocPtr.lc +++ b/ghc/runtime/c-as-asm/FreeMallocPtr.lc @@ -1,5 +1,7 @@ \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. @@ -10,8 +12,7 @@ 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); diff --git a/ghc/runtime/c-as-asm/HpOverflow.lc b/ghc/runtime/c-as-asm/HpOverflow.lc index b1cf98c..5c1c058 100644 --- a/ghc/runtime/c-as-asm/HpOverflow.lc +++ b/ghc/runtime/c-as-asm/HpOverflow.lc @@ -39,10 +39,6 @@ static void BlackHoleUpdateStack(STG_NO_ARGS); 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 @@ -106,19 +102,17 @@ RealPerformGC(liveness, reqsize, always_reenter_node, do_full_collection) } # 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); @@ -126,10 +120,8 @@ RealPerformGC(liveness, reqsize, always_reenter_node, 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 ---------------------------------- */ @@ -283,15 +275,21 @@ PerformGC(args) 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; @@ -299,23 +297,33 @@ PerformReschedule(liveness, always_reenter_node) 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]=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 @@ -348,10 +356,12 @@ StgPerformGarbageCollection() } #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. @@ -361,66 +371,283 @@ PruneSparks(STG_NO_ARGS) { sparkq spark, prev, next; I_ proc, pool, prunedSparks; + I_ tot_sparks[MAX_PROC], total_sparks = 0, tot = 0;; - for(proc=0; proc0) - 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 "); + 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]; ires) ? 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 "); + fprintf(RTSflags.GcFlags.statsFile, + "\tPE %d: %d ",proc,tot_sparks[proc]); + } + fprintf(RTSflags.GcFlags.statsFile,".\n"); + } + } +# endif } +# endif /* !DEPTH_FIRST_PRUNING */ + # else /* !GRAN */ void @@ -440,9 +667,12 @@ PruneSparks(STG_NO_ARGS) } 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 } } @@ -460,6 +690,7 @@ switching or other nonsense... just set up StorageMgrInfo and perform a garbage collection. \begin{code} +extern void handleTimerExpiry PROTO((rtsBool)); void ReallyPerformThreadGC(reqsize, do_full_collection) @@ -488,52 +719,45 @@ rtsBool 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 */ @@ -542,10 +766,10 @@ rtsBool do_full_collection; 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 @@ -556,10 +780,21 @@ rtsBool do_full_collection; 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*/ @@ -576,9 +811,14 @@ rtsBool do_full_collection; /* 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 @@ -597,44 +837,41 @@ rtsBool do_full_collection; # 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(); } @@ -675,7 +912,7 @@ BlackHoleUpdateStack(STG_NO_ARGS) \begin{code} -#if defined(CONCURRENT) && !defined(GRAN) +#if 0 /* defined(CONCURRENT) && !defined(GRAN) */ void PerformReschedule(W_ liveness, W_ always_reenter_node) { } diff --git a/ghc/runtime/c-as-asm/StablePtr.lc b/ghc/runtime/c-as-asm/StablePtr.lc index 21de425..749cd37 100644 --- a/ghc/runtime/c-as-asm/StablePtr.lc +++ b/ghc/runtime/c-as-asm/StablePtr.lc @@ -1,7 +1,7 @@ \section[Stable-Pointers]{Creation and use of Stable Pointers} \begin{code} -#ifndef PAR +#if !defined(PAR) #include "rtsdefs.h" \end{code} diff --git a/ghc/runtime/c-as-asm/StablePtrOps.lc b/ghc/runtime/c-as-asm/StablePtrOps.lc index dec93aa..6861bff 100644 --- a/ghc/runtime/c-as-asm/StablePtrOps.lc +++ b/ghc/runtime/c-as-asm/StablePtrOps.lc @@ -14,7 +14,7 @@ change it to take/return a byte array anyway. Code in PerformIO.lhc is even more dated.) \begin{code} -#ifndef PAR +#if !defined(PAR) #include "rtsdefs.h" @@ -81,14 +81,14 @@ deRefStablePointer(stableIndex) } \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); } diff --git a/ghc/runtime/c-as-asm/StgDebug.lc b/ghc/runtime/c-as-asm/StgDebug.lc index 676fadb..f198102 100644 --- a/ghc/runtime/c-as-asm/StgDebug.lc +++ b/ghc/runtime/c-as-asm/StgDebug.lc @@ -62,7 +62,7 @@ Older code (less fancy ==> more reliable) 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: @@ -708,7 +708,7 @@ getClosureShape( P_ node, int *vhs, int *size, int *ptrs, char **type ) /* 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; } } @@ -901,7 +901,7 @@ printClosure( P_ closure, int indentation, int weight ) 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: @@ -989,7 +989,7 @@ printClosure( P_ closure, int indentation, int weight ) /* 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; } } @@ -1023,12 +1023,99 @@ DEBUG_PrintA( int depth, int weight ) { 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); @@ -1043,14 +1130,15 @@ DEBUG_PrintA( int depth, int weight ) 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; @@ -1096,6 +1184,7 @@ DEBUG_PrintB( int depth, int weight ) } } } + #endif /* not CONCURRENT */ \end{code} @@ -1129,12 +1218,8 @@ numStacks( ) 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 */ @@ -1155,7 +1240,7 @@ printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size ) 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 ); @@ -1172,7 +1257,7 @@ printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size ) 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)) ); @@ -1414,7 +1499,7 @@ DEBUG_INFO_TABLE(node) 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) @@ -1502,18 +1587,22 @@ DEBUG_REGS() #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); @@ -1521,13 +1610,17 @@ DEBUG_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); */ @@ -1645,6 +1738,8 @@ DEBUG_BSTACK(lines) } fprintf(stderr, "\n"); } + + #endif /* not concurrent */ /* @@ -1718,3 +1813,1283 @@ DEBUG_TSO(P_ tso) #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"); + } +#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"); + } +#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} + diff --git a/ghc/runtime/griproot.lit b/ghc/runtime/griproot.lit deleted file mode 100644 index 2ac4f6e..0000000 --- a/ghc/runtime/griproot.lit +++ /dev/null @@ -1,57 +0,0 @@ -\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} diff --git a/ghc/runtime/gum/FetchMe.lhc b/ghc/runtime/gum/FetchMe.lhc index 05b9dc8..98be3d5 100644 --- a/ghc/runtime/gum/FetchMe.lhc +++ b/ghc/runtime/gum/FetchMe.lhc @@ -41,7 +41,7 @@ STGFUN(FetchMe_entry) 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; @@ -62,8 +62,10 @@ STGFUN(FetchMe_entry) 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 */ diff --git a/ghc/runtime/gum/HLComms.lc b/ghc/runtime/gum/HLComms.lc index 4599972..4eb58bc 100644 --- a/ghc/runtime/gum/HLComms.lc +++ b/ghc/runtime/gum/HLComms.lc @@ -116,7 +116,7 @@ blockFetch(P_ bf, P_ bh) { 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; @@ -172,7 +172,7 @@ processFetches() 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); /* @@ -218,7 +218,7 @@ processFetches() sendResume(&rga, size, graph); } } - PendingFetches = Nil_closure; + PendingFetches = Prelude_Z91Z93_closure; } \end{code} @@ -650,11 +650,13 @@ processResume(GLOBAL_TASK_ID sender) 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); diff --git a/ghc/runtime/gum/Pack.lc b/ghc/runtime/gum/Pack.lc index 4290c8a..f4f9572 100644 --- a/ghc/runtime/gum/Pack.lc +++ b/ghc/runtime/gum/Pack.lc @@ -2,7 +2,7 @@ % (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. % %************************************************************************ %* * @@ -13,37 +13,79 @@ 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} @@ -60,36 +102,133 @@ full, closures (other than primitive arrays) are packed as FetchMes, 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 @@ -99,7 +238,11 @@ normal closure layout (where all pointers occur before all non-pointers). 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; @@ -109,7 +252,11 @@ W_ *packbuffersize; return(PackBuffer); } +#if defined(GRAN) +P_ * +#else W_ * +#endif PackStkO(stko,packbuffersize) P_ stko; W_ *packbuffersize; @@ -142,18 +289,21 @@ hence a primitive array can always be packed along with it's parent 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); } @@ -173,25 +323,25 @@ P_ 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; @@ -200,27 +350,27 @@ P_ closure; 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; @@ -234,7 +384,7 @@ P_ closure; 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; @@ -295,11 +445,11 @@ P_ closure; */ if (IS_THUNK(info) && IS_UPDATABLE(info)) { -#ifdef DEBUG +# ifdef DEBUG P_ rbh = -#else +# else (void) -#endif +# endif convertToRBH(closure); ASSERT(rbh != NULL); @@ -310,6 +460,160 @@ P_ closure; 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} %************************************************************************ @@ -318,10 +622,39 @@ P_ closure; %* * %************************************************************************ +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; @@ -329,12 +662,58 @@ Pack(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; @@ -386,6 +765,7 @@ int offset; Pack(0L); /* pe */ Pack(offset); /* slot/offset */ } +#endif /* !GRAN */ \end{code} %************************************************************************ @@ -398,6 +778,7 @@ The offset hash table is used during packing to record the location in the pack buffer of each closure which is packed. \begin{code} +#if defined(PAR) static HashTable *offsettable; \end{code} @@ -416,18 +797,26 @@ InitPackBuffer(STG_NO_ARGS) 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} @@ -435,6 +824,8 @@ InitPacking(STG_NO_ARGS) etc. \begin{code} +#if defined(PAR) + static void DonePacking(STG_NO_ARGS) { @@ -480,6 +871,21 @@ int offset; { return(offset < PACK_HDR_SIZE); } + +#else /* GRAN */ + +static rtsBool +NotYetPacking(closure) +P_ closure; +{ int i; + rtsBool found = rtsFalse; + + for (i=PACK_HDR_SIZE; (i= 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} @@ -538,9 +958,8 @@ InitClosureQueue(STG_NO_ARGS) { clqpos = clqsize = 0; - if ( ClosureQueue == NULL ) { - AllocClosureQueue(RTSflags.ParFlags.packBufferSize); - } + if ( ClosureQueue == NULL ) + AllocClosureQueue(PACK_BUFFER_SIZE); } \end{code} @@ -562,7 +981,7 @@ void QueueClosure(closure) P_ closure; { - if(clqsize < RTSflags.ParFlags.packBufferSize) + if(clqsize < PACK_BUFFER_SIZE ) ClosureQueue[clqsize++] = closure; else { @@ -595,6 +1014,7 @@ These routines determine whether a GA is one of a number of special types of GA. \begin{code} +#if defined(PAR) rtsBool isOffset(ga) globalAddr *ga; @@ -608,6 +1028,7 @@ globalAddr *ga; { return (ga->weight == 0); } +#endif \end{code} %************************************************************************ @@ -617,12 +1038,15 @@ globalAddr *ga; %************************************************************************ \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; @@ -665,7 +1089,8 @@ P_ buffer; 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; @@ -718,7 +1143,8 @@ P_ buffer; 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; } } @@ -726,7 +1152,107 @@ P_ buffer; 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= 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); @@ -104,7 +105,18 @@ acquired a blocking queue. If that has happened, we first have to 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 @@ -152,6 +164,113 @@ globalAddr *ga; 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} diff --git a/ghc/runtime/gum/SysMan.lc b/ghc/runtime/gum/SysMan.lc index 50a6cd2..bfe2e7d 100644 --- a/ghc/runtime/gum/SysMan.lc +++ b/ghc/runtime/gum/SysMan.lc @@ -4,7 +4,7 @@ % % (c) The Parade/AQUA Projects, Glasgow University, 1994-1995. % P. Trinder, November 30th. 1994. -% +% %**************************************************************************** The Sysman task currently controls initiation, termination, of a @@ -139,6 +139,7 @@ main(int argc, char **argv) argv++; argc--; } sysman_id = pvm_mytid();/* This must be the first PVM call */ + checkerr(sysman_id); /* @@ -166,8 +167,8 @@ main(int argc, char **argv) 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 diff --git a/ghc/runtime/gum/Unpack.lc b/ghc/runtime/gum/Unpack.lc index 52b4cad..f6877df 100644 --- a/ghc/runtime/gum/Unpack.lc +++ b/ghc/runtime/gum/Unpack.lc @@ -2,7 +2,7 @@ % (c) Parade/AQUA Projects, Glasgow University, 1995 % Kevin Hammond, February 15th. 1995 % -% This is for GUM only. +% This is for GUM and GrAnSim. % %************************************************************************ %* * @@ -13,10 +13,14 @@ 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} @@ -52,7 +56,7 @@ CommonUp(P_ src, P_ dst) 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); @@ -99,6 +103,7 @@ W_ *nGAs; W_ bufsize; P_ graphroot, graph, parent; W_ pptr = 0, pptrs = 0, pvhs; + char str[80]; int i; globalAddr *gaga; @@ -158,7 +163,7 @@ W_ *nGAs; * 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++) @@ -268,7 +273,8 @@ W_ *nGAs; 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; } } @@ -282,8 +288,104 @@ W_ *nGAs; /* 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} + diff --git a/ghc/runtime/hooks/InitEachPE.lc b/ghc/runtime/hooks/InitEachPE.lc new file mode 100644 index 0000000..029784d --- /dev/null +++ b/ghc/runtime/hooks/InitEachPE.lc @@ -0,0 +1,18 @@ +\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} diff --git a/ghc/runtime/hooks/NoRunnableThrds.lc b/ghc/runtime/hooks/NoRunnableThrds.lc new file mode 100644 index 0000000..3ac6011 --- /dev/null +++ b/ghc/runtime/hooks/NoRunnableThrds.lc @@ -0,0 +1,14 @@ + + +\begin{code} +#ifdef CONCURRENT /* the whole thing! */ +#include "rtsdefs.h" + +void +NoRunnableThreadsHook () +{ + fprintf(stderr, "No runnable threads!\n"); +} +#endif /* CONCURRENT */ + +\end{code} diff --git a/ghc/runtime/io/acceptSocket.lc b/ghc/runtime/io/acceptSocket.lc new file mode 100644 index 0000000..55b4cb8 --- /dev/null +++ b/ghc/runtime/io/acceptSocket.lc @@ -0,0 +1,58 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/bindSocket.lc b/ghc/runtime/io/bindSocket.lc new file mode 100644 index 0000000..a8eab7e --- /dev/null +++ b/ghc/runtime/io/bindSocket.lc @@ -0,0 +1,98 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/connectSocket.lc b/ghc/runtime/io/connectSocket.lc new file mode 100644 index 0000000..0af37c1 --- /dev/null +++ b/ghc/runtime/io/connectSocket.lc @@ -0,0 +1,120 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/createSocket.lc b/ghc/runtime/io/createSocket.lc new file mode 100644 index 0000000..7529ccf --- /dev/null +++ b/ghc/runtime/io/createSocket.lc @@ -0,0 +1,58 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/env.lc b/ghc/runtime/io/env.lc index f68b0ef..ba4c06a 100644 --- a/ghc/runtime/io/env.lc +++ b/ghc/runtime/io/env.lc @@ -88,9 +88,12 @@ copyenv() 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; diff --git a/ghc/runtime/io/execvpe.lc b/ghc/runtime/io/execvpe.lc index 456d2a3..51235c3 100644 --- a/ghc/runtime/io/execvpe.lc +++ b/ghc/runtime/io/execvpe.lc @@ -5,6 +5,8 @@ \begin{code} +#define NON_POSIX_SOURCE + #include "rtsdefs.h" #include "stgio.h" #include "libposix.h" diff --git a/ghc/runtime/io/getCPUTime.lc b/ghc/runtime/io/getCPUTime.lc index 0a5d1a5..729a101 100644 --- a/ghc/runtime/io/getCPUTime.lc +++ b/ghc/runtime/io/getCPUTime.lc @@ -4,7 +4,9 @@ \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 diff --git a/ghc/runtime/io/getPeerName.lc b/ghc/runtime/io/getPeerName.lc new file mode 100644 index 0000000..458e596 --- /dev/null +++ b/ghc/runtime/io/getPeerName.lc @@ -0,0 +1,60 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/getSockName.lc b/ghc/runtime/io/getSockName.lc new file mode 100644 index 0000000..806b08c --- /dev/null +++ b/ghc/runtime/io/getSockName.lc @@ -0,0 +1,55 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/listenSocket.lc b/ghc/runtime/io/listenSocket.lc new file mode 100644 index 0000000..d9260cf --- /dev/null +++ b/ghc/runtime/io/listenSocket.lc @@ -0,0 +1,50 @@ +% +% (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 +#endif + +#ifdef HAVE_SYS_SOCKET_H +#include +#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} diff --git a/ghc/runtime/io/readDescriptor.lc b/ghc/runtime/io/readDescriptor.lc new file mode 100644 index 0000000..59eec97 --- /dev/null +++ b/ghc/runtime/io/readDescriptor.lc @@ -0,0 +1,59 @@ +% +% (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} diff --git a/ghc/runtime/io/shutdownSocket.lc b/ghc/runtime/io/shutdownSocket.lc new file mode 100644 index 0000000..96edb9f --- /dev/null +++ b/ghc/runtime/io/shutdownSocket.lc @@ -0,0 +1,42 @@ +% +% (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} diff --git a/ghc/runtime/io/writeDescriptor.lc b/ghc/runtime/io/writeDescriptor.lc new file mode 100644 index 0000000..acab07e --- /dev/null +++ b/ghc/runtime/io/writeDescriptor.lc @@ -0,0 +1,75 @@ +% +% (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} diff --git a/ghc/runtime/main/GranSim.lc b/ghc/runtime/main/GranSim.lc index f4650c4..34828be 100644 --- a/ghc/runtime/main/GranSim.lc +++ b/ghc/runtime/main/GranSim.lc @@ -1,5 +1,8 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1995 - 1996 +% Hans Wolfgang Loidl +% +% Time-stamp: % %************************************************************************ %* * @@ -19,45 +22,232 @@ which should be <= the length of a word in bits. -- HWL #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 +# endif +# else +# if defined(HAVE_GETTIMEOFDAY) +# if defined(HAVE_SYS_TIME_H) +# include +# endif +# else +# ifdef HAVE_TIME_H +# include +# 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 -#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 -#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 -#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); } @@ -66,61 +256,155 @@ PROC 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=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; @@ -129,36 +413,457 @@ newevent(proc,creator,time,evttype,tso,node,spark) 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 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 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)); @@ -324,11 +1128,11 @@ rtsBool mandatory_thread; } 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) @@ -348,6 +1152,47 @@ rtsBool mandatory_thread; } } +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. */ @@ -356,7 +1201,12 @@ void 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); @@ -389,12 +1239,17 @@ void 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); @@ -423,6 +1278,7 @@ TIME v; } } +#endif /* GRAN || PAR */ \end{code} %**************************************************************************** @@ -431,10 +1287,14 @@ TIME v; % %**************************************************************************** +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) @@ -443,19 +1303,21 @@ int prog_argc, rts_argc; { 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) { @@ -471,74 +1333,184 @@ int prog_argc, rts_argc; 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) @@ -571,6 +1543,10 @@ 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)) { @@ -587,7 +1563,7 @@ init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv) } #endif /* PAR */ -#endif /* GRAN || PAR */ +#endif /* GRAN || PAR */ \end{code} diff --git a/ghc/runtime/main/RtsFlags.lc b/ghc/runtime/main/RtsFlags.lc index ef646b3..616c48f 100644 --- a/ghc/runtime/main/RtsFlags.lc +++ b/ghc/runtime/main/RtsFlags.lc @@ -20,6 +20,10 @@ static void bad_option(const char *); 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)); @@ -69,7 +73,14 @@ initRtsFlagsDefaults (STG_NO_ARGS) #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 @@ -89,6 +100,73 @@ initRtsFlagsDefaults (STG_NO_ARGS) 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; @@ -152,7 +230,7 @@ usage_text[] = { " -p Produce cost centre time profile (output file .prof)", " sort: T = time (default), A = alloc, C = cost centre label", " -P Produce serial time profile (output file .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 Heap residency profile (output file .hp)", @@ -209,6 +287,9 @@ usage_text[] = { " -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.", @@ -326,7 +407,7 @@ error = rtsTrue; #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"); \ @@ -334,7 +415,7 @@ error = rtsTrue; #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"); \ @@ -342,7 +423,7 @@ error = rtsTrue; #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"); \ @@ -350,7 +431,7 @@ error = rtsTrue; #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"); \ @@ -468,7 +549,7 @@ error = rtsTrue; break; default: fprintf(stderr, "Invalid profiling sort option %s\n", rts_argv[arg]); - error = 1; + error = rtsTrue; } ) break; @@ -517,7 +598,7 @@ error = rtsTrue; default: fprintf(stderr, "Invalid heap profile option: %s\n", rts_argv[arg]); - error = 1; + error = rtsTrue; } ) break; @@ -528,41 +609,41 @@ error = rtsTrue; 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; @@ -573,37 +654,37 @@ error = rtsTrue; 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 ========================= */ @@ -702,7 +783,7 @@ error = rtsTrue; case 'b': GRAN_BUILD_ONLY( - process_gran_option(); + process_gran_option(arg, rts_argc, rts_argv, &error); ) break; /* =========== TICKY ============================== */ @@ -737,393 +818,663 @@ error = rtsTrue; } -#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 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 ... 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} diff --git a/ghc/runtime/main/SMRep.lc b/ghc/runtime/main/SMRep.lc index 2609195..19c6d51 100644 --- a/ghc/runtime/main/SMRep.lc +++ b/ghc/runtime/main/SMRep.lc @@ -123,8 +123,8 @@ MUTUPLE_RTBL(); IMMUTUPLE_RTBL(); STATIC_RTBL(); -#ifndef PAR -MallocPtr_RTBL(); +#if !defined(PAR) /* && !defined(GRAN) */ +ForeignObj_RTBL(); #endif BH_RTBL(N); @@ -152,11 +152,17 @@ DUMMY_PRRETURN_RTBL(_PRMarking_MarkNextCAF,_Dummy_PRReturn_entry); # 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 @@ -177,7 +183,7 @@ BF_RTBL(); # endif #endif -#ifdef PAR +#if defined(PAR) || defined(GRAN) SPEC_RBH_RTBL(2,0); SPEC_RBH_RTBL(2,1); SPEC_RBH_RTBL(2,2); diff --git a/ghc/runtime/main/Select.lc b/ghc/runtime/main/Select.lc index 4fdcaa4..325a4a9 100644 --- a/ghc/runtime/main/Select.lc +++ b/ghc/runtime/main/Select.lc @@ -7,6 +7,8 @@ %* * %************************************************************************ +Handling of select() of read&write on file descriptors or timer expiry. + \begin{code} #ifdef CONCURRENT @@ -16,7 +18,8 @@ #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 @@ -26,36 +29,75 @@ # include # 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); } } @@ -65,19 +107,42 @@ AwaitEvent(I_ delta) 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) { @@ -86,26 +151,29 @@ AwaitEvent(I_ delta) 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) @@ -116,9 +184,9 @@ AwaitEvent(I_ delta) } } 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; } } diff --git a/ghc/runtime/main/Signals.lc b/ghc/runtime/main/Signals.lc index af2738e..3189786 100644 --- a/ghc/runtime/main/Signals.lc +++ b/ghc/runtime/main/Signals.lc @@ -26,6 +26,10 @@ much pain. # 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 @@ -47,6 +51,11 @@ much pain. # include #endif +#if defined(linux_TARGET_OS) || defined(linuxaout_TARGET_OS) + /* to look *inside* sigcontext... */ +# include +#endif + #if defined(HAVE_SIGINFO_H) /* DEC OSF1 seems to need this explicitly. Maybe others do as well? */ # include @@ -78,17 +87,25 @@ to set up the handler to expect a different collection of arguments. 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(); @@ -101,13 +118,20 @@ segv_handler(sig, code, scp, addr) 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 */ @@ -161,10 +185,12 @@ the non-POSIX signal under SunOS 4.1.X, we adopt the same approach 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 @@ -198,8 +224,27 @@ vtalrm_handler(int sig) } # 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] || @@ -217,7 +262,7 @@ vtalrm_handler(int sig) 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]) { @@ -318,7 +363,7 @@ parallel world. Sorry. \begin{code} -#ifdef PAR +#if defined(PAR) /* || defined(GRAN) */ void blockUserSignals(void) diff --git a/ghc/runtime/main/StgOverflow.lc b/ghc/runtime/main/StgOverflow.lc index aac16e5..a5f4e61 100644 --- a/ghc/runtime/main/StgOverflow.lc +++ b/ghc/runtime/main/StgOverflow.lc @@ -158,7 +158,7 @@ P_ frame; /* 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); @@ -285,18 +285,22 @@ W_ args2; 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) { @@ -306,14 +310,18 @@ W_ args2; 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; @@ -324,7 +332,9 @@ W_ args2; 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) { @@ -337,7 +347,11 @@ W_ args2; 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 @@ -355,7 +369,7 @@ W_ args2; 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; @@ -363,7 +377,7 @@ W_ args2; 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; diff --git a/ghc/runtime/main/StgStartup.lhc b/ghc/runtime/main/StgStartup.lhc index 3bd53e8..bc2c352 100644 --- a/ghc/runtime/main/StgStartup.lhc +++ b/ghc/runtime/main/StgStartup.lhc @@ -106,27 +106,27 @@ IMMUTUPLE_ITBL(ImMutArrayOfPtrs_info,ImMutArrayOfPtrs_entry,UpdErr,0,INFO_OTHER_ 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] */ @@ -198,8 +198,9 @@ SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED /* 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 }; @@ -326,6 +327,12 @@ STGFUN(ErrorIO_innards) #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; @@ -356,7 +363,7 @@ STGFUN(ErrorIO_innards) *SpA = (P_) WorldStateToken_closure; - STKO_LINK(StkOReg) = Nil_closure; + STKO_LINK(StkOReg) = Prelude_Z91Z93_closure; STKO_RETURN(StkOReg) = NULL; #ifdef TICKY_TICKY @@ -416,7 +423,7 @@ ErrorIO_innards(STG_NO_ARGS) \end{code} \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) STATICFUN(RBH_Save_0_entry) { @@ -446,7 +453,7 @@ SPEC_N_ITBL(RBH_Save_0_info,RBH_Save_0_entry,UpdErr,0,INFO_OTHER_TAG,2,0,,IF_,IN 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} @@ -491,26 +498,6 @@ SET_STATIC_HDR(STK_STUB_closure,STK_STUB_info,CC_SUBSUMED,,EXTDATA_RO) }; \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 * @@ -542,7 +529,7 @@ STGFUN(Forward_Ref_New_entry) { /* 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); @@ -552,7 +539,7 @@ STGFUN(Forward_Ref_Old_entry) { /* 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); @@ -562,7 +549,7 @@ STGFUN(OldRoot_Forward_Ref_entry) { /* 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); @@ -573,7 +560,7 @@ STGFUN(Forward_Ref_entry) { /* 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); diff --git a/ghc/runtime/main/StgThreads.lhc b/ghc/runtime/main/StgThreads.lhc index ab63382..c75eaaf 100644 --- a/ghc/runtime/main/StgThreads.lhc +++ b/ghc/runtime/main/StgThreads.lhc @@ -97,7 +97,8 @@ STGFUN(BQ_entry) 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); @@ -122,7 +123,7 @@ STGFUN(BQ_entry) } #endif #if defined(GRAN) - ReSchedule(NEW_THREAD); + ReSchedule(SAME_THREAD); /* NB: GranSimBlock activated next thread */ #else ReSchedule(0); #endif @@ -149,15 +150,16 @@ checked, yet. -- HWL \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: @@ -182,6 +184,7 @@ STGFUN(RBH_entry) QP_Event1("GR", CurrentTSO); } +# ifdef PAR if(RTSflags.ParFlags.granSimStats) { /* Note that CURRENT_TIME may perform an unsafe call */ TIME now = CURRENT_TIME; @@ -191,12 +194,12 @@ STGFUN(RBH_entry) 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_ } @@ -281,7 +284,6 @@ STGFUN(EnterNodeCode) FB_ ENT_VIA_NODE(); InfoPtr=(D_)(INFO_PTR(Node)); - GRAN_EXEC(5,1,2,0,0); JMP_(ENTRY_CODE(InfoPtr)); FE_ } @@ -468,8 +470,7 @@ IFN_(seqDirectReturn) { 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_ } diff --git a/ghc/runtime/main/StgUpdate.lhc b/ghc/runtime/main/StgUpdate.lhc index e0cb245..5a229ec 100644 --- a/ghc/runtime/main/StgUpdate.lhc +++ b/ghc/runtime/main/StgUpdate.lhc @@ -7,10 +7,6 @@ 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. @@ -31,7 +27,7 @@ System-wide constants need to be included: #endif #endif -EXTDATA(Nil_closure); +EXTDATA(Prelude_Z91Z93_closure); #if defined(TICKY_TICKY) void PrintTickyInfo(STG_NO_ARGS); @@ -130,15 +126,16 @@ STGFUN(BH_UPD_entry) 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; @@ -173,8 +170,8 @@ STGFUN(BH_UPD_entry) # endif # if defined(GRAN) - /* CurrentTSO = Nil_closure; */ - ReSchedule(NEW_THREAD); + /* CurrentTSO = Prelude_Z91Z93_closure; */ + ReSchedule(SAME_THREAD); # else ReSchedule(0); # endif @@ -405,9 +402,6 @@ STGFUN(Perm_Ind_entry) InfoPtr=(D_)(INFO_PTR(Node)); -# if defined(GRAN) - GRAN_EXEC(1,1,2,0,0); -# endif JMP_(ENTRY_CODE(InfoPtr)); FE_ } @@ -469,7 +463,7 @@ STGFUN(UpdatePAP) FB_ -#if defined(COUNT) +#if defined(GRAN_COUNT) ++nPAPs; #endif @@ -602,7 +596,7 @@ STGFUN(UpdatePAP) * 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)); diff --git a/ghc/runtime/main/Threads.lc b/ghc/runtime/main/Threads.lc index 4df5c8e..eba881d 100644 --- a/ghc/runtime/main/Threads.lc +++ b/ghc/runtime/main/Threads.lc @@ -24,7 +24,7 @@ \begin{code} -#if defined(CONCURRENT) +#if defined(CONCURRENT) /* the whole module! */ # define NON_POSIX_SOURCE /* so says Solaris */ @@ -44,57 +44,19 @@ chunk of a thread, the one that's got @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= 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; @@ -397,13 +138,30 @@ I_ advisory_thread_count = 0; 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]; @@ -411,21 +169,21 @@ 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; @@ -454,34 +212,38 @@ P_ topClosure; } 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 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; @@ -538,43 +314,44 @@ P_ topClosure; 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])) { @@ -610,29 +387,57 @@ P_ topClosure; } #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 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_nextCHANGE_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_nextEND_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 */ @@ -760,9 +606,12 @@ int what_next; /* Run the current thread again? */ /* 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; } /* ----------------------------------------------------------------- */ @@ -771,161 +620,121 @@ int what_next; /* Run the current thread again? */ 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') */ @@ -935,182 +744,562 @@ int what_next; /* Run the current thread again? */ 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? */ @@ -1132,7 +1321,7 @@ 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; @@ -1147,7 +1336,7 @@ int again; /* Run the current thread again? */ */ if (again) { - if(RunnableThreadsHd == Nil_closure) { + if(RunnableThreadsHd == Prelude_Z91Z93_closure) { RunnableThreadsHd = CurrentTSO; } else { TSO_LINK(RunnableThreadsTl) = CurrentTSO; @@ -1165,7 +1354,7 @@ int again; /* Run the current thread again? */ * 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 @@ -1177,7 +1366,7 @@ int again; /* Run the current thread again? */ 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) { @@ -1194,11 +1383,13 @@ int again; /* Run the current thread again? */ } 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 } } @@ -1215,14 +1406,14 @@ int again; /* Run the current thread again? */ /* 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) { @@ -1241,9 +1432,11 @@ int again; /* Run the current thread again? */ } 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 } } @@ -1273,47 +1466,312 @@ processors). \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]= 4 || OutstandingFetches[proc] == 0)) { if (SurplusThreads > 0l) /* Steal a thread */ StealThread(proc); @@ -1323,11 +1781,11 @@ HandleIdlePEs() } 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); } } @@ -1338,18 +1796,29 @@ clock order -- most retarded first. Currently sparks are only stolen from 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]) @@ -1365,17 +1834,50 @@ PROC proc; 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 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); } @@ -1416,11 +1930,35 @@ PROC proc; 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+10) && + (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} @@ -1431,15 +1969,24 @@ StealThread(proc) 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; @@ -1453,63 +2000,114 @@ PROC proc; 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 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> 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); @@ -1613,7 +2413,10 @@ W_ type; 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 @@ -1621,7 +2424,7 @@ W_ type; 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 @@ -1631,11 +2434,11 @@ W_ type; #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; @@ -1647,7 +2450,13 @@ W_ type; 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 */ @@ -1657,18 +2466,19 @@ W_ type; # 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; @@ -1677,7 +2487,7 @@ W_ type; 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 } @@ -1695,23 +2505,31 @@ W_ type; 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, @@ -1729,72 +2547,71 @@ EndThread(STG_NO_ARGS) #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 @@ -1807,20 +2624,16 @@ EndThread(STG_NO_ARGS) 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--; @@ -1835,29 +2648,30 @@ EndThread(STG_NO_ARGS) 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} %**************************************************************************** @@ -1868,7 +2682,8 @@ EndThread(STG_NO_ARGS) \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; } @@ -1884,7 +2699,7 @@ EXTDATA_RO(BQ_info); * AwakenBlockingQueue awakens a list of TSOs and FBQs. */ -P_ PendingFetches = Nil_closure; +P_ PendingFetches = Prelude_Z91Z93_closure; void AwakenBlockingQueue(bqe) @@ -1899,7 +2714,7 @@ 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))) { @@ -1926,7 +2741,7 @@ AwakenBlockingQueue(bqe) } # endif if (last_tso == NULL) { - if (RunnableThreadsHd == Nil_closure) { + if (RunnableThreadsHd == Prelude_Z91Z93_closure) { RunnableThreadsHd = bqe; } else { TSO_LINK(RunnableThreadsTl) = bqe; @@ -1950,13 +2765,13 @@ AwakenBlockingQueue(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 } } @@ -1964,88 +2779,313 @@ AwakenBlockingQueue(bqe) #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 (notifytimerR[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; @@ -2064,8 +3104,10 @@ W_ args; ReSchedule(args & 1); } +#endif /* GRAN */ \end{code} + %**************************************************************************** % \subsection[gr-fetch]{Fetching Nodes (GrAnSim only)} @@ -2083,11 +3125,10 @@ moved from a processor B to a processor C between sending out a @FETCH@ (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" */ @@ -2096,23 +3137,34 @@ FetchNode(node,from,to) 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; } @@ -2123,180 +3175,287 @@ PROC from, to; [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} %**************************************************************************** % @@ -2305,12 +3464,13 @@ void end_gr_simulation() { %**************************************************************************** \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) { @@ -2318,6 +3478,13 @@ 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) @@ -2371,301 +3538,135 @@ P_ tso1, tso2; 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]; ires) ? 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) @@ -2676,6 +3677,8 @@ I_ 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); @@ -2686,14 +3689,37 @@ I_ num_ptr_roots; 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; @@ -2701,13 +3727,10 @@ 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; @@ -2715,16 +3738,16 @@ I_ num_ptr_roots; { 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; /* @@ -2734,7 +3757,7 @@ I_ num_ptr_roots; 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]) @@ -2748,9 +3771,152 @@ I_ num_ptr_roots; } /* forall i ... */ } /*forall proc .. */ + if ( RTSflags.GcFlags.giveStats ) { + fprintf(RTSflags.GcFlags.statsFile, + "Spark statistics (after pruning) (total sparks = %d):",tot); + for (proc=0; proc "); + 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 "); + 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 @@ -2768,6 +3934,8 @@ I_ num_ptr_roots; 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]; @@ -2777,11 +3945,28 @@ I_ 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); } @@ -2792,6 +3977,8 @@ I_ num_ptr_roots; return(RestoreEvtRoots(EventHd,num_ptr_roots)); } +#if defined(DEPTH_FIRST_PRUNING) + static I_ RestoreSpkRoots(spark,num_ptr_roots,sparkroots) sparkq spark; @@ -2804,21 +3991,23 @@ I_ num_ptr_roots, sparkroots; { 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); } @@ -2829,12 +4018,17 @@ I_ 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); } @@ -2842,900 +4036,71 @@ I_ num_ptr_roots; 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; imax_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"); - } -#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} diff --git a/ghc/runtime/main/TopClosure.lc b/ghc/runtime/main/TopClosure.lc index e2d670c..14d6e05 100644 --- a/ghc/runtime/main/TopClosure.lc +++ b/ghc/runtime/main/TopClosure.lc @@ -1,8 +1,8 @@ -/* 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} diff --git a/ghc/runtime/main/TopClosure13.lc b/ghc/runtime/main/TopClosure13.lc deleted file mode 100644 index 07792c2..0000000 --- a/ghc/runtime/main/TopClosure13.lc +++ /dev/null @@ -1,8 +0,0 @@ -/* 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} diff --git a/ghc/runtime/main/main.lc b/ghc/runtime/main/main.lc index 8d6d8dc..b2e5e97 100644 --- a/ghc/runtime/main/main.lc +++ b/ghc/runtime/main/main.lc @@ -24,7 +24,7 @@ /* 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 ? */ @@ -55,7 +55,7 @@ extern void checkAStack(STG_NO_ARGS); /* 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 */ @@ -73,12 +73,6 @@ extern void SynchroniseSystem(STG_NO_ARGS); 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)); @@ -106,6 +100,9 @@ int nPEs = 0; /* Number of PEs */ 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 @@ -122,7 +119,7 @@ Manager's requirements. \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"); */ @@ -134,10 +131,11 @@ Manager's requirements. 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 @@ -175,10 +173,11 @@ Manager's requirements. } #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 @@ -228,7 +227,7 @@ Manager's requirements. /* 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. @@ -264,29 +263,33 @@ Manager's requirements. #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 char * @@ -400,7 +393,7 @@ getErrorHandler(STG_NO_ARGS) return (StgInt) errorHandler; } -#ifndef PAR +#if !defined(PAR) void raiseError( handler ) diff --git a/ghc/runtime/prims/ByteOps.lc b/ghc/runtime/prims/ByteOps.lc index 85d949b..594210a 100644 --- a/ghc/runtime/prims/ByteOps.lc +++ b/ghc/runtime/prims/ByteOps.lc @@ -73,7 +73,7 @@ CAT3(bytes2,ctype,__)(P_ in, htype *out) \ 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++) \ @@ -112,7 +112,7 @@ CAT3(bytes2,ctype,__)(P_ in, htype *out) \ 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++) \ diff --git a/ghc/runtime/prims/PrimArith.lc b/ghc/runtime/prims/PrimArith.lc index 7683ed8..0e134e0 100644 --- a/ghc/runtime/prims/PrimArith.lc +++ b/ghc/runtime/prims/PrimArith.lc @@ -389,7 +389,7 @@ stgReallocForGMP (ptr, old_size, new_size) 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; diff --git a/ghc/runtime/prims/PrimMisc.lc b/ghc/runtime/prims/PrimMisc.lc index 4c29994..142bab6 100644 --- a/ghc/runtime/prims/PrimMisc.lc +++ b/ghc/runtime/prims/PrimMisc.lc @@ -86,12 +86,11 @@ Phantom info table vectors for multiple constructor primitive types that 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} diff --git a/ghc/runtime/profiling/CostCentre.lc b/ghc/runtime/profiling/CostCentre.lc index 01a801d..2d084c2 100644 --- a/ghc/runtime/profiling/CostCentre.lc +++ b/ghc/runtime/profiling/CostCentre.lc @@ -18,10 +18,6 @@ CC_DECLARE(CC_IDLE, "IDLE", "IDLE", "IDLE", CC_IS_BORING,/*not static*/); # 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 */ @@ -43,9 +39,9 @@ Cost centres which are always required: \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} @@ -79,15 +75,6 @@ init_cc_profiling(rts_argc, rts_argv, prog_argv) 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; @@ -150,9 +137,7 @@ init_cc_profiling(rts_argc, rts_argv, prog_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 @@ -185,9 +170,7 @@ cc_register() 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) */ @@ -228,6 +211,23 @@ cc_to_ignore (CostCentre cc) # 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; @@ -236,16 +236,24 @@ report_cc_profiling(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; @@ -301,12 +309,12 @@ report_cc_profiling(final) 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 } } @@ -343,21 +351,33 @@ report_cc_profiling(final) 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) { @@ -368,28 +388,33 @@ report_cc_profiling(final) 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"); } } @@ -452,11 +477,6 @@ cc_gt_time(CostCentre cc1, CostCentre cc2) 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 */ } @@ -480,11 +500,6 @@ cc_gt_alloc(CostCentre cc1, CostCentre cc2) 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 */ } diff --git a/ghc/runtime/profiling/HeapProfile.lc b/ghc/runtime/profiling/HeapProfile.lc index 514e815..373e9ff 100644 --- a/ghc/runtime/profiling/HeapProfile.lc +++ b/ghc/runtime/profiling/HeapProfile.lc @@ -109,17 +109,16 @@ static char heap_filename[STATS_FILENAME_MAXLEN]; /* heap log file name = 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 */ @@ -151,7 +163,7 @@ collectHeap(reqsize, sm, do_full_collection) compactingInfo.bits, compactingInfo.bit_words #if ! defined(PAR) - , &(sm->MallocPtrList) + , &(sm->ForeignObjList) #endif ) - 1; diff --git a/ghc/runtime/storage/SM2s.lc b/ghc/runtime/storage/SM2s.lc index bdfa415..7ad2e97 100644 --- a/ghc/runtime/storage/SM2s.lc +++ b/ghc/runtime/storage/SM2s.lc @@ -138,13 +138,16 @@ collectHeap(reqsize, sm, do_full_collection) #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 */ @@ -156,7 +159,7 @@ collectHeap(reqsize, sm, do_full_collection) #ifdef PAR RebuildGAtables(rtsTrue); #else - reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); + reportDeadForeignObjs(sm->ForeignObjList, NULL, &(sm->ForeignObjList) ); #endif /* PAR */ /* TIDY UP AND RETURN */ diff --git a/ghc/runtime/storage/SMap.lc b/ghc/runtime/storage/SMap.lc index 27ec2be..392caab 100644 --- a/ghc/runtime/storage/SMap.lc +++ b/ghc/runtime/storage/SMap.lc @@ -147,7 +147,7 @@ initHeap(smInfo * sm) 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; @@ -239,13 +239,16 @@ collect2s(W_ reqsize, smInfo *sm) #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 */ @@ -257,7 +260,7 @@ collect2s(W_ reqsize, smInfo *sm) #ifdef PAR RebuildGAtables(rtsTrue); #else - reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); + reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList) ); #endif /* PAR */ /* TIDY UP AND RETURN */ @@ -286,7 +289,7 @@ collect2s(W_ reqsize, smInfo *sm) 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, @@ -419,7 +422,6 @@ collectHeap(reqsize, sm, do_full_collection) while ( mutptr ) { /* Scavenge the OldMutable */ - P_ orig_mutptr = mutptr; P_ info = (P_) INFO_PTR(mutptr); StgScavPtr scav_code = SCAV_CODE(info); Scav = mutptr; @@ -442,7 +444,7 @@ collectHeap(reqsize, sm, do_full_collection) #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:"); @@ -463,10 +465,13 @@ collectHeap(reqsize, sm, do_full_collection) 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 */ @@ -490,10 +495,10 @@ collectHeap(reqsize, sm, do_full_collection) #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; @@ -501,7 +506,7 @@ collectHeap(reqsize, sm, do_full_collection) 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 */ @@ -597,9 +602,9 @@ collectHeap(reqsize, sm, do_full_collection) /* end of bracket */ #ifndef PAR - sweepUpDeadMallocPtrs(sm->OldMallocPtrList, - appelInfo.oldbase, - appelInfo.bits + sweepUpDeadForeignObjs(sm->OldForeignObjList, + appelInfo.oldbase, + appelInfo.bits ); #endif /* !PAR */ @@ -609,17 +614,24 @@ collectHeap(reqsize, sm, do_full_collection) 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 */ @@ -630,7 +642,7 @@ collectHeap(reqsize, sm, do_full_collection) appelInfo.bits, appelInfo.bit_words #ifndef PAR - ,&(sm->OldMallocPtrList) + ,&(sm->OldForeignObjList) #endif ) - 1; @@ -667,7 +679,7 @@ collectHeap(reqsize, sm, do_full_collection) 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, diff --git a/ghc/runtime/storage/SMcompacting.lc b/ghc/runtime/storage/SMcompacting.lc index 96c7c0e..bf78189 100644 --- a/ghc/runtime/storage/SMcompacting.lc +++ b/ghc/runtime/storage/SMcompacting.lc @@ -52,8 +52,97 @@ I_ rootno; \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) { @@ -68,7 +157,8 @@ LinkSparks(STG_NO_ARGS) } } } -#endif +#endif /* GRAN */ +#endif /* CONCURRENT */ \end{code} @@ -140,7 +230,7 @@ LinkLiveGAs(P_ base, BitWord *bits) sendFreeMessages(); } -#else +#endif \end{code} @@ -148,6 +238,7 @@ Note: no \tr{Link[AB]Stack} for ``parallel'' systems, because they don't have a single main stack. \begin{code} +#if !defined(PAR) /* && !defined(GRAN) */ /* HWL */ void LinkAStack(stackA, botA) @@ -169,7 +260,8 @@ PP_ 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; diff --git a/ghc/runtime/storage/SMcompacting.lh b/ghc/runtime/storage/SMcompacting.lh index fdb5b55..602740c 100644 --- a/ghc/runtime/storage/SMcompacting.lh +++ b/ghc/runtime/storage/SMcompacting.lh @@ -7,6 +7,9 @@ void LinkBStack PROTO((P_ stackB, P_ botB)); 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 diff --git a/ghc/runtime/storage/SMcopying.lc b/ghc/runtime/storage/SMcopying.lc index 736663a..77fbd8b 100644 --- a/ghc/runtime/storage/SMcopying.lc +++ b/ghc/runtime/storage/SMcopying.lc @@ -80,8 +80,110 @@ EvacuateRoots(P_ roots[], I_ rootno) } \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) { @@ -97,14 +199,15 @@ 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 */) { @@ -132,7 +235,7 @@ EVACUATED_INFOPTR) 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; diff --git a/ghc/runtime/storage/SMcopying.lh b/ghc/runtime/storage/SMcopying.lh index 9587f72..26d801b 100644 --- a/ghc/runtime/storage/SMcopying.lh +++ b/ghc/runtime/storage/SMcopying.lh @@ -7,6 +7,9 @@ void EvacuateAStack PROTO(( PP_ stackA, PP_ botA )); 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 diff --git a/ghc/runtime/storage/SMdu.lc b/ghc/runtime/storage/SMdu.lc index 3dbbd39..151d447 100644 --- a/ghc/runtime/storage/SMdu.lc +++ b/ghc/runtime/storage/SMdu.lc @@ -157,9 +157,9 @@ collectHeap(reqsize, sm, do_full_collection) /* 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); @@ -170,11 +170,15 @@ collectHeap(reqsize, sm, do_full_collection) #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 */ @@ -185,7 +189,7 @@ collectHeap(reqsize, sm, do_full_collection) dualmodeInfo.bits, dualmodeInfo.bit_words #ifndef PAR - ,&(sm->MallocPtrList) + ,&(sm->ForeignObjList) #endif ) - 1; @@ -203,13 +207,13 @@ collectHeap(reqsize, sm, do_full_collection) #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 */ @@ -219,7 +223,7 @@ collectHeap(reqsize, sm, do_full_collection) #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 */ diff --git a/ghc/runtime/storage/SMevac.lc b/ghc/runtime/storage/SMevac.lc index 6cf5e80..dce5642 100644 --- a/ghc/runtime/storage/SMevac.lc +++ b/ghc/runtime/storage/SMevac.lc @@ -272,10 +272,10 @@ extern P_ _Evacuate_Old_to_New(); 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] */ @@ -517,7 +517,7 @@ turns you on. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) #define SPEC_RBH_EVAC_FN(n) \ EVAC_FN(CAT2(RBH_,n)) \ @@ -555,31 +555,36 @@ SPEC_RBH_EVAC_FN(12) #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 @@ -617,7 +622,7 @@ as the underlying @GEN@ closure. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) EVAC_FN(RBH_S) { I_ count = GEN_RBH_HS - 1; diff --git a/ghc/runtime/storage/SMextn.lc b/ghc/runtime/storage/SMextn.lc index 48e024d..67020a8 100644 --- a/ghc/runtime/storage/SMextn.lc +++ b/ghc/runtime/storage/SMextn.lc @@ -5,7 +5,7 @@ SMcompacting.lc? 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: @@ -75,7 +75,7 @@ TrashMem(from, to) \begin{code} -#ifndef PAR /* To end of the file */ +#if !defined(PAR) /* To end of the file */ \end{code} @@ -88,55 +88,54 @@ EXTDATA(EmptySPTable_closure); 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} @@ -144,7 +143,7 @@ Validate_MallocPtrList( MallocPtrList ) \begin{code} #else /* !DEBUG */ -#define TRASH_MallocPtr_CLOSURE( mp ) /* nothing */ +#define TRASH_ForeignObj_CLOSURE( mp ) /* nothing */ #endif /* !DEBUG */ \end{code} @@ -152,53 +151,55 @@ Validate_MallocPtrList( MallocPtrList ) \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} @@ -210,51 +211,51 @@ Trace_MPforwarded( MPPtr, newAddress ) \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); } } } @@ -284,7 +285,7 @@ smInfo *sm; -/* 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) @@ -302,61 +303,61 @@ EXTDATA_RO(Forward_Ref_info); #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} diff --git a/ghc/runtime/storage/SMextn.lh b/ghc/runtime/storage/SMextn.lh index 4c096a0..4bac2bc 100644 --- a/ghc/runtime/storage/SMextn.lh +++ b/ghc/runtime/storage/SMextn.lh @@ -8,15 +8,15 @@ void initExtensions PROTO((smInfo *sm)); # 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 */ @@ -25,12 +25,12 @@ void TrashMem PROTO(( P_ from, P_ to )); # 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 */ diff --git a/ghc/runtime/storage/SMgen.lc b/ghc/runtime/storage/SMgen.lc index d539149..0556e1d 100644 --- a/ghc/runtime/storage/SMgen.lc +++ b/ghc/runtime/storage/SMgen.lc @@ -272,7 +272,7 @@ collect2s(reqsize, sm) #ifdef PAR EvacuateLocalGAs(rtsTrue); #else - evacSPTable( sm ); + /* evacSPTable( sm ); stable pointers now reachable via sm->roots */ #endif /* PAR */ DEBUG_STRING("Evacuate Roots:"); @@ -281,7 +281,18 @@ collect2s(reqsize, sm) 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; @@ -331,7 +342,7 @@ collect2s(reqsize, sm) #ifdef PAR RebuildGAtables(rtsTrue); #else - reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); + reportDeadForeignObjs( sm->ForeignObjList, NULL, &(sm->ForeignObjList) ); #endif /* PAR */ /* TIDY UP AND RETURN */ @@ -467,6 +478,17 @@ collectHeap(reqsize, sm) } } +#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; @@ -526,7 +548,9 @@ collectHeap(reqsize, sm) #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)) { @@ -626,10 +650,10 @@ collectHeap(reqsize, sm) #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) { @@ -720,7 +744,7 @@ collectHeap(reqsize, sm) /* end of bracket */ #ifndef PAR - sweepUpDeadMallocPtrs(sm->OldMallocPtrList, + sweepUpDeadForeignObjs(sm->OldForeignObjList, appelInfo.oldbase, appelInfo.bits ); @@ -746,8 +770,10 @@ collectHeap(reqsize, sm) #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; diff --git a/ghc/runtime/storage/SMinternal.lh b/ghc/runtime/storage/SMinternal.lh index ddbb20c..f21671f 100644 --- a/ghc/runtime/storage/SMinternal.lh +++ b/ghc/runtime/storage/SMinternal.lh @@ -330,6 +330,11 @@ EXTFUN(_PRMarking_MarkNextCAF); EXTFUN(_PRMarking_MarkNextSpark); #endif +#if defined(GRAN) +EXTFUN(_PRMarking_MarkNextEvent); +EXTFUN(_PRMarking_MarkNextClosureInFetchBuffer); +#endif + #ifdef PAR EXTFUN(_PRMarking_MarkNextGA); MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextGA,) @@ -347,6 +352,11 @@ MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextBStack,) 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,) diff --git a/ghc/runtime/storage/SMmark.lhc b/ghc/runtime/storage/SMmark.lhc index 13b55c9..72ea1d3 100644 --- a/ghc/runtime/storage/SMmark.lhc +++ b/ghc/runtime/storage/SMmark.lhc @@ -194,6 +194,10 @@ First the necessary forward declarations. /* #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. @@ -292,7 +296,7 @@ Start code for revertible black holes with underlying @SPEC@ types. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) #define SPEC_RBH_PRStart_N_CODE(ptrs) \ STGFUN(CAT2(_PRStart_RBH_,ptrs)) \ { \ @@ -389,7 +393,7 @@ SPEC_PRIn_N_CODE(12) 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)) \ { \ @@ -428,19 +432,19 @@ SPEC_RBH_PRIn_N_CODE(12) \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; } @@ -500,7 +504,7 @@ And the start/in code for a revertible black hole with an underlying @GEN@ closu \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) STGFUN(_PRStart_RBH_N) { @@ -950,7 +954,9 @@ closure. \begin{code} STGFUN(_PRStart_CharLike) { +#ifdef TICKY_TICKY I_ val; +#endif FUNBEGIN; @@ -1380,10 +1386,17 @@ INTFUN(_PRMarking_MarkNextSpark_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; #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); @@ -1396,8 +1409,10 @@ EXTFUN(_PRMarking_MarkNextSpark); #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") @@ -1415,12 +1430,24 @@ DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure, _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, @@ -1430,7 +1457,7 @@ DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure, _PRMarking_MarkNextBStack_info, _PRMarking_MarkNextBStack, _PRMarking_MarkNextBStack_entry); - +# endif #endif /* PAR */ DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure, @@ -1455,7 +1482,8 @@ STGFUN(_PRMarking_MarkNextRoot) FUNEND; } -#ifdef CONCURRENT +#if defined(CONCURRENT) +# if !defined(GRAN) extern P_ sm_roots_end; /* PendingSparksTl[pool] */ STGFUN(_PRMarking_MarkNextSpark) @@ -1472,6 +1500,221 @@ 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 @@ -1495,7 +1738,7 @@ STGFUN(_PRMarking_MarkNextGA) } #else - +#if 1 /* !defined(CONCURRENT) */ /* HWL */ STGFUN(_PRMarking_MarkNextAStack) { FUNBEGIN; @@ -1528,6 +1771,7 @@ STGFUN(_PRMarking_MarkNextBStack) JUMP_MARK; FUNEND; } +#endif /* !CONCURRENT */ #endif /* PAR */ \end{code} diff --git a/ghc/runtime/storage/SMmarking.lc b/ghc/runtime/storage/SMmarking.lc index 592cd35..d1eb76e 100644 --- a/ghc/runtime/storage/SMmarking.lc +++ b/ghc/runtime/storage/SMmarking.lc @@ -36,17 +36,29 @@ EXTFUN(_PRMarking_MarkNextSpark); 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) @@ -59,6 +71,12 @@ 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; @@ -74,7 +92,85 @@ markHeapRoots(sm, cafs1, cafs2, base, lim, bit_array) 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]; @@ -99,7 +195,7 @@ markHeapRoots(sm, cafs1, cafs2, base, lim, bit_array) miniInterpret((StgFunPtr) _startMarkWorld); } #else -# ifndef CONCURRENT +# if 1 /* !defined(GRAN) */ /* HWL */ /* Note: no *external* stacks in parallel/concurrent world */ DEBUG_STRING("Marking A Stack:"); diff --git a/ghc/runtime/storage/SMscan.lc b/ghc/runtime/storage/SMscan.lc index 35534bb..5c6b489 100644 --- a/ghc/runtime/storage/SMscan.lc +++ b/ghc/runtime/storage/SMscan.lc @@ -39,15 +39,15 @@ are placed in the info tables of the appropriate closures. 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; @@ -57,7 +57,7 @@ Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words BitWord *bit_array; I_ bit_array_words; #ifndef PAR - StgPtr *MallocPtrList; + StgPtr *ForeignObjList; #endif { BitWord *bit_array_ptr, *bit_array_end; @@ -94,8 +94,8 @@ Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words 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) { @@ -127,7 +127,7 @@ Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words 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! */ @@ -185,7 +185,7 @@ Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words 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! */ @@ -203,8 +203,8 @@ Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words #ifdef PAR RebuildLAGAtable(); #else - VALIDATE_MallocPtrList( NewMallocPtrList ); - *MallocPtrList = NewMallocPtrList; + VALIDATE_ForeignObjList( NewForeignObjList ); + *ForeignObjList = NewForeignObjList; #endif /* PAR */ return(New); @@ -310,15 +310,16 @@ LinkLim -- The limit of the heap requiring to be linked & moved #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 */ @@ -578,7 +579,7 @@ Scan-linking revertible black holes with underlying @SPEC@ closures. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) I_ _ScanLink_RBH_2_1(STG_NO_ARGS) { @@ -749,15 +750,15 @@ _ScanLink_RBH_12_12(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 */ @@ -941,7 +942,7 @@ _ScanMove_12(STG_NO_ARGS) { 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; @@ -1143,35 +1144,39 @@ _ScanMove_RBH_12(STG_NO_ARGS) { #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 @@ -1220,7 +1225,7 @@ _ScanMove_S(STG_NO_ARGS) { 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) diff --git a/ghc/runtime/storage/SMscav.lc b/ghc/runtime/storage/SMscav.lc index 118a8a0..6e400b9 100644 --- a/ghc/runtime/storage/SMscav.lc +++ b/ghc/runtime/storage/SMscav.lc @@ -193,7 +193,7 @@ RegisterTable ScavRegTable; 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", \ @@ -223,7 +223,7 @@ RegisterTable ScavRegTable; # 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 @@ -496,7 +496,7 @@ closures. \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) # if defined(GCgn) @@ -588,16 +588,16 @@ SCAVENGE_SPEC_RBH_N_N(12) \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); @@ -632,7 +632,7 @@ The scavenge code for revertible black holes with underlying @GEN@ closures \begin{code} -#ifdef PAR +#if defined(PAR) || defined(GRAN) void _Scavenge_RBH_N(STG_NO_ARGS) diff --git a/ghc/runtime/storage/SMstacks.lc b/ghc/runtime/storage/SMstacks.lc index 4428b9c..1ac07b9 100644 --- a/ghc/runtime/storage/SMstacks.lc +++ b/ghc/runtime/storage/SMstacks.lc @@ -7,7 +7,7 @@ Routine that allocates the A and B stack (sequential only). # define NULL_REG_MAP # include "SMinternal.h" -#ifndef CONCURRENT +#if 1 /* ndef CONCURRENT */ /* HWL */ stackData stackInfo; #endif @@ -35,10 +35,14 @@ initStacks(smInfo *sm) 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 } @@ -47,7 +51,7 @@ initStacks(smInfo *sm) # 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); diff --git a/ghc/runtime/storage/SMstatic.lc b/ghc/runtime/storage/SMstatic.lc index 7355893..96400af 100644 --- a/ghc/runtime/storage/SMstatic.lc +++ b/ghc/runtime/storage/SMstatic.lc @@ -4,21 +4,22 @@ *************************************************************************** -@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), @@ -279,8 +280,6 @@ const W_ CHARLIKE_closures[] = { CHARLIKE_HDR(255) }; -EXTDATA_RO(IZh_static_info); - static const W_ INTLIKE_closures_def[] = { INTLIKE_HDR(-16), /* MIN_INTLIKE == -16 */ INTLIKE_HDR(-15), diff --git a/ghc/runtime/storage/SMstats.lc b/ghc/runtime/storage/SMstats.lc index 37e4895..3083e04 100644 --- a/ghc/runtime/storage/SMstats.lc +++ b/ghc/runtime/storage/SMstats.lc @@ -13,6 +13,9 @@ stat_exit ********************************************************************* \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 @@ -41,6 +44,11 @@ stat_exit #include #endif +/* Needed for Solaris2 */ +#if /* defined(HAVE_SYS_RUSAGE_H) && */ defined(solaris2_TARGET_OS) +#include +#endif + #ifdef HAVE_SYS_TIMEB_H #include #endif diff --git a/ghc/runtime/storage/mprotect.lc b/ghc/runtime/storage/mprotect.lc index a27199f..dabf3c4 100644 --- a/ghc/runtime/storage/mprotect.lc +++ b/ghc/runtime/storage/mprotect.lc @@ -10,7 +10,6 @@ Is @mprotect@ POSIX now? \begin{code} - #if STACK_CHECK_BY_PAGE_FAULT /* #define STK_CHK_DEBUG */ @@ -36,7 +35,12 @@ Is @mprotect@ POSIX now? # 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 @@ -45,6 +49,11 @@ extern int getpagesize PROTO((void)); 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_; @@ -74,5 +83,4 @@ int size; } #endif /* STACK_CHECK_BY_PAGE_FAULT */ - \end{code} diff --git a/ghc/runtime/threadroot.lit b/ghc/runtime/threadroot.lit deleted file mode 100644 index 77d3492..0000000 --- a/ghc/runtime/threadroot.lit +++ /dev/null @@ -1,24 +0,0 @@ -\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} diff --git a/ghc/utils/hp2ps/Curves.c b/ghc/utils/hp2ps/Curves.c index b7de061..c4f173e 100644 --- a/ghc/utils/hp2ps/Curves.c +++ b/ghc/utils/hp2ps/Curves.c @@ -100,7 +100,7 @@ ShadeCurve(x, y, py, shade) fprintf(psfp, "gsave\n"); - fprintf(psfp, "%f setgray\n", shade); + SetPSColour(shade); fprintf(psfp, "fill\n"); fprintf(psfp, "grestore\n"); diff --git a/ghc/utils/hp2ps/Error.c b/ghc/utils/hp2ps/Error.c index 4361e0b..bdbb43d 100644 --- a/ghc/utils/hp2ps/Error.c +++ b/ghc/utils/hp2ps/Error.c @@ -49,6 +49,7 @@ Usage(str) 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); } diff --git a/ghc/utils/hp2ps/Key.c b/ghc/utils/hp2ps/Key.c index cafb19e..a8a761d 100644 --- a/ghc/utils/hp2ps/Key.c +++ b/ghc/utils/hp2ps/Key.c @@ -51,7 +51,7 @@ KeyEntry(centreline, name, colour) 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"); diff --git a/ghc/utils/hp2ps/Main.c b/ghc/utils/hp2ps/Main.c index 7e93541..099b081 100644 --- a/ghc/utils/hp2ps/Main.c +++ b/ghc/utils/hp2ps/Main.c @@ -29,6 +29,7 @@ boolish bflag = 0; /* use a big title box */ 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 */ @@ -118,6 +119,9 @@ char* argv[]; if (THRESHOLD_PERCENT < 0 || THRESHOLD_PERCENT > 5) Usage(*argv-1); goto nextarg; + case 'c': + cflag++; + goto nextarg; case '?': default: Usage(*argv-1); diff --git a/ghc/utils/hp2ps/Main.h b/ghc/utils/hp2ps/Main.h index 3ae1dba..b0d4bf4 100644 --- a/ghc/utils/hp2ps/Main.h +++ b/ghc/utils/hp2ps/Main.h @@ -51,6 +51,7 @@ extern boolish bflag; extern boolish sflag; extern int mflag; extern boolish tflag; +extern boolish cflag; extern char *programname; diff --git a/ghc/utils/hp2ps/Shade.c b/ghc/utils/hp2ps/Shade.c index 0a03dec..f7e517b 100644 --- a/ghc/utils/hp2ps/Shade.c +++ b/ghc/utils/hp2ps/Shade.c @@ -72,21 +72,61 @@ ShadeOf(ident) -#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); + } } diff --git a/ghc/utils/hp2ps/Shade.h b/ghc/utils/hp2ps/Shade.h index b6dd271..951b723 100644 --- a/ghc/utils/hp2ps/Shade.h +++ b/ghc/utils/hp2ps/Shade.h @@ -3,5 +3,6 @@ extern floatish ShadeOf PROTO((char *)); extern void ShadeFor PROTO((char *, floatish)); +extern void SetPSColour PROTO((floatish)); #endif /* SHADE_H */ diff --git a/ghc/utils/hscpp/hscpp.prl b/ghc/utils/hscpp/hscpp.prl index f46b374..74de86c 100644 --- a/ghc/utils/hscpp/hscpp.prl +++ b/ghc/utils/hscpp/hscpp.prl @@ -175,14 +175,14 @@ while () { 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; diff --git a/ghc/utils/mkdependHS/mkdependHS.prl b/ghc/utils/mkdependHS/mkdependHS.prl index e4a11c8..c216394 100644 --- a/ghc/utils/mkdependHS/mkdependHS.prl +++ b/ghc/utils/mkdependHS/mkdependHS.prl @@ -6,14 +6,48 @@ # ToDo: strip out all the .h junk # ($Pgm = $0) =~ s/.*\/([^\/]+)$/\1/; -$Usage = "usage: $Pgm: not done yet\n"; +$Usage = < A cpp #define; usual meaning + -i Add (colon-separated) to list of directories + to search for "import"ed modules + -I Add to list of directories to search for + .h files (i.e., usual meaning) + -syslib 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 + +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 Use as the "object file" suffix ( default: .o) + -s Make extra dependencies for files with + suffix ; thus, "-o .hc -s _a" will + make dependencies both for .hc files and for _a.hc + files. (Useful in conjunction with NoFib "ways".) + -x Regard 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 @@ -26,8 +60,6 @@ if ( $OrigCpp =~ /(\S+)\s+(.*)/ ) { die "hscpp: don't know how to run cpp: $OrigCpp\n"; } } -} else { - $Cpp = $OrigCpp; } if ( $ENV{'TMPDIR'} ) { # where to make tmp file names @@ -73,16 +105,26 @@ $Begin_magic_str = "# DO NOT DELETE: Beginning of Haskell dependencies\n"; $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) @@ -121,27 +163,41 @@ $Import_dirs = '.'; '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 @@ -195,7 +251,6 @@ while () { # copy the rest through } close(NMKF) || exit(1); close(OMKF) || exit(1); -chmod 0444, 'Makefile'; exit 0; sub mangle_command_line_args { @@ -213,39 +268,33 @@ 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 { @@ -262,6 +311,29 @@ 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); @@ -279,38 +351,52 @@ sub slurp_file_for_imports { || die "$Pgm: Can't open $file_to_read: $!\n"; while () { - 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); @@ -326,8 +412,8 @@ sub find_in_Import_dirs { 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) @@ -336,7 +422,7 @@ sub find_in_Import_dirs { $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'; @@ -347,18 +433,18 @@ sub find_in_Import_dirs { } $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'; @@ -369,36 +455,31 @@ sub find_in_Import_dirs { } $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"; } @@ -411,7 +492,7 @@ sub find_in_Include_dirs { # 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 @@ -419,13 +500,13 @@ sub find_in_Include_dirs { # 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"); } diff --git a/ghc/utils/stat2resid/parse-gcstats.prl b/ghc/utils/stat2resid/parse-gcstats.prl index b6e80fd..3b5dab5 100644 --- a/ghc/utils/stat2resid/parse-gcstats.prl +++ b/ghc/utils/stat2resid/parse-gcstats.prl @@ -161,14 +161,16 @@ arg: while($_ = $stats[0]) { $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; }; diff --git a/ghc/utils/ugen/Jmakefile b/ghc/utils/ugen/Jmakefile index e221781..55fc953 100644 --- a/ghc/utils/ugen/Jmakefile +++ b/ghc/utils/ugen/Jmakefile @@ -19,7 +19,7 @@ BuildPgmFromCFiles(ugen,$(OBJS_C),,) YaccRunWithExpectMsg(syntax,no,no) -UgenTarget(tree) +UgenTarget(.,tree) CDependTarget( $(SRCS_C) ) diff --git a/ghc/utils/ugen/gen.c b/ghc/utils/ugen/gen.c index f57489d..5dc76a4 100644 --- a/ghc/utils/ugen/gen.c +++ b/ghc/utils/ugen/gen.c @@ -33,6 +33,9 @@ ge_typdef(t) 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));