Commit 1b28d4e1 authored by hwloidl's avatar hwloidl

[project @ 2000-01-13 14:33:57 by hwloidl]

Merged GUM-4-04 branch into the main trunk. In particular merged GUM and
SMP code. Most of the GranSim code in GUM-4-04 still has to be carried over.
parent d3d20ba7
%
% (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
% Hans Wolfgang Loidl
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: Costs.lhs,v 1.20 2000/01/13 14:33:57 hwloidl Exp $
%
% Only needed in a GranSim setup -- HWL
% ---------------------------------------------------------------------------
\section[Costs]{Evaluating the costs of computing some abstract C code}
......@@ -28,9 +30,11 @@ The meaning of the result tuple is:
instructions.
\end{itemize}
This function is needed in GrAnSim for parallelism.
This function is needed in GranSim for costing pieces of abstract C.
These are first suggestions for scaling the costs. But, this scaling should be done in the RTS rather than the compiler (this really should be tunable!):
These are first suggestions for scaling the costs. But, this scaling should
be done in the RTS rather than the compiler (this really should be
tunable!):
\begin{pseudocode}
......@@ -82,6 +86,7 @@ instance Num CostRes where
negate = mapOp negate
abs = mapOp abs
signum = mapOp signum
fromInteger _ = error "fromInteger not defined"
mapOp :: (Int -> Int) -> CostRes -> CostRes
mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f)
......@@ -202,7 +207,10 @@ costs absC =
CSimultaneous absC -> costs absC
CCheck _ amodes code -> Cost (2, 1, 0, 0, 0)
CCheck _ amodes code -> Cost (2, 1, 0, 0, 0) -- ToDo: refine this by
-- looking at the first arg
CRetDirect _ _ _ _ -> nullCosts
CMacroStmt macro modes -> stmtMacroCosts macro modes
......@@ -215,19 +223,28 @@ costs absC =
-- *** the next three [or so...] are DATA (those above are CODE) ***
-- as they are data rather than code they all have nullCosts -- HWL
CCallTypedef _ _ _ _ -> nullCosts
CStaticClosure _ _ _ _ -> nullCosts
CClosureInfoAndCode _ _ _ _ -> nullCosts
CSRT _ _ -> nullCosts
CRetDirect _ _ _ _ -> nullCosts
CBitmap _ _ -> nullCosts
CClosureInfoAndCode _ _ _ _ -> nullCosts
CRetVector _ _ _ _ -> nullCosts
CClosureTbl _ -> nullCosts
CCostCentreDecl _ _ -> nullCosts
CCostCentreStackDecl _ -> nullCosts
CSplitMarker -> nullCosts
_ -> trace ("Costs.costs") nullCosts
-- ---------------------------------------------------------------------------
addrModeCosts :: CAddrMode -> Side -> CostRes
......@@ -242,7 +259,11 @@ addrModeCosts addr_mode side =
CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0)
else Cost (0, 0, 1, 0, 0)
CReg _ -> nullCosts {- loading from, storing to reg is free ! -}
CAddr (CIndex _ n _ ) -> Cost (1, 0, 1, 0, 0) -- does pointer arithmetic
CAddr _ -> nullCosts
CReg _ -> nullCosts {- loading from, storing to reg is free ! -}
{- for costing CReg->Creg ops see special -}
{- case in costs fct -}
......@@ -277,6 +298,8 @@ addrModeCosts addr_mode side =
CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list
_ -> trace ("Costs.addrModeCosts") nullCosts
-- ---------------------------------------------------------------------------
exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes
......@@ -288,10 +311,11 @@ exprMacroCosts side macro mode_list =
in
arg_costs +
case macro of
ENTRY_CODE -> nullCosts
ARG_TAG -> nullCosts -- XXX
GET_TAG -> nullCosts -- XXX
ENTRY_CODE -> nullCosts -- nothing
ARG_TAG -> nullCosts -- nothing
GET_TAG -> Cost (0, 0, 1, 0, 0) -- indirect load
UPD_FRAME_UPDATEE -> Cost (0, 0, 1, 0, 0) -- indirect load
_ -> trace ("Costs.exprMacroCosts") nullCosts
-- ---------------------------------------------------------------------------
......@@ -309,7 +333,9 @@ stmtMacroCosts macro modes =
UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -}
UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
PUSH_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
PUSH_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- Updates.h -}
PUSH_SEQ_FRAME -> Cost (2, 0, 0, 3, 0) {- StgMacros.h !-}
UPDATE_SU_FROM_UPD_FRAME -> Cost (1, 0, 1, 0, 0) {- StgMacros.h !-}
SET_TAG -> nullCosts {- COptRegs.lh -}
GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
......
......@@ -285,7 +285,8 @@ getAllFilesMatching :: SearchPath
-> (ModuleHiMap, ModuleHiMap)
-> (FilePath, String)
-> IO (ModuleHiMap, ModuleHiMap)
getAllFilesMatching dirs hims (dir_path, suffix) = ( do
getAllFilesMatching dirs hims (dir_path, suffix) =
do
-- fpaths entries do not have dir_path prepended
fpaths <- getDirectoryContents dir_path
is_dll <- catch
......@@ -297,7 +298,7 @@ getAllFilesMatching dirs hims (dir_path, suffix) = ( do
)
(\ _ {-don't care-} -> return NotDll)
return (foldl (addModules is_dll) hims fpaths)
) -- soft failure
-- soft failure
`catch`
(\ err -> do
hPutStrLn stderr
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgCase.lhs,v 1.36 1999/11/01 17:10:06 simonpj Exp $
% $Id: CgCase.lhs,v 1.37 2000/01/13 14:33:57 hwloidl Exp $
%
%********************************************************
%* *
......@@ -602,9 +602,10 @@ cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
= -- We have arranged that Node points to the thing
restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
getAbsC (absC restore_cc `thenC`
(if opt_GranMacros && emit_yield
then yield [node] False
else absC AbsCNop) `thenC`
-- HWL: maybe need yield here
--(if emit_yield
-- then yield [node] True
-- else absC AbsCNop) `thenC`
possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
-- Node is live, but doesn't need to point at the thing itself;
-- it's ok for Node to point to an indirection or FETCH_ME
......@@ -633,9 +634,10 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch
=
restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
getAbsC (absC restore_cc `thenC`
(if opt_GranMacros && emit_yield
then yield [node] True -- XXX live regs wrong
else absC AbsCNop) `thenC`
-- HWL: maybe need yield here
-- (if emit_yield
-- then yield [node] True -- XXX live regs wrong
-- else absC AbsCNop) `thenC`
(case gc_flag of
NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
GCMayHappen -> bindConArgs con args
......@@ -667,9 +669,10 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
absC restore_cc `thenC`
(if opt_GranMacros && emit_yield
then yield live_regs True -- XXX live regs wrong?
else absC AbsCNop) `thenC`
-- HWL: maybe need yield here
-- (if emit_yield
-- then yield live_regs True -- XXX live regs wrong?
-- else absC AbsCNop) `thenC`
let
-- ToDo: could maybe use Nothing here if stack_res is False
-- since the heap-check can just return to the top of the
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgClosure.lhs,v 1.38 1999/11/11 17:50:49 simonpj Exp $
% $Id: CgClosure.lhs,v 1.39 2000/01/13 14:33:58 hwloidl Exp $
%
\section[CgClosure]{Code generation for closures}
......@@ -40,7 +40,8 @@ import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
getSpRelOffset, getHpRelOffset
)
import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
mkRednCountsLabel, mkInfoTableLabel
mkRednCountsLabel, mkInfoTableLabel,
pprCLabel
)
import ClosureInfo -- lots and lots of stuff
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
......@@ -325,7 +326,12 @@ closureCodeBody binder_info closure_info cc all_args body
--
arg_regs = case entry_conv of
DirectEntry lbl arity regs -> regs
other -> panic "closureCodeBody:arg_regs"
other -> trace ("*** closureCodeBody:arg_regs " ++ (pprHWL entry_conv) ++ "(HWL ignored; no args passed in regs)") []
pprHWL :: EntryConvention -> String
pprHWL (ViaNode) = "ViaNode"
pprHWL (StdEntry cl) = "StdEntry"
pprHWL (DirectEntry cl i l) = "DirectEntry"
num_arg_regs = length arg_regs
......@@ -350,7 +356,7 @@ closureCodeBody binder_info closure_info cc all_args body
mapCs bindNewToStack arg_offsets `thenC`
setRealAndVirtualSp sp_all_args `thenC`
argSatisfactionCheck closure_info `thenC`
argSatisfactionCheck closure_info arg_regs `thenC`
-- OK, so there are enough args. Now we need to stuff as
-- many of them in registers as the fast-entry code
......@@ -516,24 +522,24 @@ relative offset of this word tells how many words of arguments
are expected.
\begin{code}
argSatisfactionCheck :: ClosureInfo -> Code
argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
argSatisfactionCheck closure_info
argSatisfactionCheck closure_info arg_regs
= nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
let
emit_gran_macros = opt_GranMacros
in
-- let
-- emit_gran_macros = opt_GranMacros
-- in
-- HWL ngo' ngoq:
-- absC (CMacroStmt GRAN_FETCH []) `thenC`
-- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
(if emit_gran_macros
then if node_points
then fetchAndReschedule [] node_points
else yield [] node_points
else absC AbsCNop) `thenC`
--(if opt_GranMacros
-- then if node_points
-- then fetchAndReschedule arg_regs node_points
-- else yield arg_regs node_points
-- else absC AbsCNop) `thenC`
getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
let
......@@ -565,16 +571,13 @@ thunkWrapper closure_info lbl thunk_code
= -- Stack and heap overflow checks
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
let
emit_gran_macros = opt_GranMacros
in
-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-- (we prefer fetchAndReschedule-style context switches to yield ones)
(if emit_gran_macros
then if node_points
then fetchAndReschedule [] node_points
else yield [] node_points
else absC AbsCNop) `thenC`
-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-- (we prefer fetchAndReschedule-style context switches to yield ones)
(if opt_GranMacros
then if node_points
then fetchAndReschedule [] node_points
else yield [] node_points
else absC AbsCNop) `thenC`
-- stack and/or heap checks
thunkChecks lbl node_points (
......@@ -597,13 +600,10 @@ funWrapper :: ClosureInfo -- Closure whose code body this is
funWrapper closure_info arg_regs stk_tags info_label fun_body
= -- Stack overflow check
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
let
emit_gran_macros = opt_GranMacros
in
-- HWL chu' ngoq:
(if emit_gran_macros
then yield arg_regs node_points
else absC AbsCNop) `thenC`
(if opt_GranMacros
then yield arg_regs node_points
else absC AbsCNop) `thenC`
-- heap and/or stack checks
fastEntryChecks arg_regs stk_tags info_label node_points (
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgHeapery.lhs,v 1.19 1999/10/13 16:39:15 simonmar Exp $
% $Id: CgHeapery.lhs,v 1.20 2000/01/13 14:33:58 hwloidl Exp $
%
\section[CgHeapery]{Heap management functions}
......@@ -32,7 +32,7 @@ import ClosureInfo ( closureSize, closureGoodStuffSize,
)
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Unique )
import CmdLineOpts ( opt_SccProfilingOn )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import GlaExts
import Outputable
......@@ -78,6 +78,10 @@ fastEntryChecks regs tags ret node_points code
getTickyCtrLabel `thenFC` \ ticky_ctr ->
( if all_pointers then -- heap checks are quite easy
-- HWL: gran-yield immediately before heap check proper
--(if node `elem` regs
-- then yield regs True
-- else absC AbsCNop ) `thenC`
absC (checking_code stk_words hp_words tag_assts
free_reg (length regs) ticky_ctr)
......@@ -382,22 +386,22 @@ mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep
= ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
mkRegLiveness (_ : regs) = mkRegLiveness regs
-- The two functions below are only used in a GranSim setup
-- Emit macro for simulating a fetch and then reschedule
fetchAndReschedule :: [MagicId] -- Live registers
-> Bool -- Node reqd?
-> Code
fetchAndReschedule regs node_reqd =
fetchAndReschedule regs node_reqd =
if (node `elem` regs || node_reqd)
then fetch_code `thenC` reschedule_code
else absC AbsCNop
where
all_regs = if node_reqd then node:regs else regs
liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
liveness_mask = mkRegLiveness regs
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit liveness_mask,
mkIntCLit (IBOX(word2Int# liveness_mask)),
mkIntCLit (if node_reqd then 1 else 0)])
--HWL: generate GRAN_FETCH macro for GrAnSim
......@@ -423,15 +427,16 @@ yield :: [MagicId] -- Live registers
-> Bool -- Node reqd?
-> Code
yield regs node_reqd =
-- NB: node is not alive; that's why we use DO_YIELD rather than
-- GRAN_RESCHEDULE
yield_code
where
all_regs = if node_reqd then node:regs else regs
liveness_mask = 0 {-XXX: mkLiveRegsMask all_regs-}
yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
yield regs node_reqd =
if opt_GranMacros && node_reqd
then yield_code
else absC AbsCNop
where
-- all_regs = if node_reqd then node:regs else regs
liveness_mask = mkRegLiveness regs
yield_code =
absC (CMacroStmt GRAN_YIELD
[mkIntCLit (IBOX(word2Int# liveness_mask))])
\end{code}
%************************************************************************
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgStackery.lhs,v 1.12 1999/06/24 13:04:20 simonmar Exp $
% $Id: CgStackery.lhs,v 1.13 2000/01/13 14:33:58 hwloidl Exp $
%
\section[CgStackery]{Stack management functions}
......@@ -25,9 +25,10 @@ import AbsCSyn
import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
import CmdLineOpts ( opt_SccProfilingOn )
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import Panic ( panic )
import Constants ( uF_SIZE, sCC_UF_SIZE, sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE )
import Constants ( uF_SIZE, sCC_UF_SIZE, gRAN_UF_SIZE,
sEQ_FRAME_SIZE, sCC_SEQ_FRAME_SIZE, gRAN_SEQ_FRAME_SIZE )
import IOExts ( trace )
\end{code}
......@@ -224,11 +225,13 @@ getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1
\end{code}
\begin{code}
updateFrameSize | opt_SccProfilingOn = sCC_UF_SIZE
| otherwise = uF_SIZE
updateFrameSize | opt_SccProfilingOn = trace ("updateFrameSize = " ++ (show sCC_UF_SIZE)) sCC_UF_SIZE
| opt_GranMacros = trace ("updateFrameSize = " ++ (show gRAN_UF_SIZE))gRAN_UF_SIZE
| otherwise = trace ("updateFrameSize = " ++ (show uF_SIZE)) uF_SIZE
seqFrameSize | opt_SccProfilingOn = sCC_SEQ_FRAME_SIZE
| otherwise = sEQ_FRAME_SIZE
| opt_GranMacros = gRAN_SEQ_FRAME_SIZE
| otherwise = sEQ_FRAME_SIZE
\end{code}
%************************************************************************
......
......@@ -34,6 +34,7 @@ module Constants (
uF_SIZE,
sCC_UF_SIZE,
gRAN_UF_SIZE, -- HWL
uF_RET,
uF_SU,
uF_UPDATEE,
......@@ -41,6 +42,7 @@ module Constants (
sEQ_FRAME_SIZE,
sCC_SEQ_FRAME_SIZE,
gRAN_SEQ_FRAME_SIZE, -- HWL
mAX_Vanilla_REG,
mAX_Float_REG,
......@@ -157,6 +159,9 @@ uF_SIZE = (NOSCC_UF_SIZE::Int)
-- Same again, with profiling
sCC_UF_SIZE = (SCC_UF_SIZE::Int)
-- Same again, with gransim
gRAN_UF_SIZE = (GRAN_UF_SIZE::Int)
-- Offsets in an update frame. They don't change with profiling!
uF_RET = (UF_RET::Int)
uF_SU = (UF_SU::Int)
......@@ -169,6 +174,7 @@ Seq frame sizes.
\begin{code}
sEQ_FRAME_SIZE = (NOSCC_SEQ_FRAME_SIZE::Int)
sCC_SEQ_FRAME_SIZE = (SCC_SEQ_FRAME_SIZE::Int)
gRAN_SEQ_FRAME_SIZE = (GRAN_SEQ_FRAME_SIZE::Int)
\end{code}
\begin{code}
......
......@@ -122,6 +122,7 @@ macroCode PUSH_UPD_FRAME args
frame n = StInd PtrRep
(StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
-- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
a1 = StAssign PtrRep (frame uF_RET) upd_frame_info
a3 = StAssign PtrRep (frame uF_SU) stgSu
a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
......
......@@ -687,6 +687,9 @@ sub mangle_asm {
print STDERR "$Pgm: unknown prologue mangling? $TargetPlatform\n";
}
# HWL HACK: dont die, just print a warning
#print stderr "HWL: this should die! Prologue junk?: $p\n" if $p =~ /^\t[^\.]/
# && $TargetPlatform !~ /^powerpc-/; #ToDo: remove test
die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/
&& $TargetPlatform !~ /^powerpc-/; #ToDo: remove test
......@@ -727,6 +730,9 @@ sub mangle_asm {
} else {
print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n";
}
# HWL HACK: dont die, just print a warning
#print stderr "HWL: this should die! Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/
# && $TargetPlatform !~ /^powerpc-/; #ToDo: remove test
die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/
&& $TargetPlatform !~ /^powerpc-/; #ToDo: remove test
......
......@@ -1911,6 +1911,7 @@ eval 'exec perl -S \$0 \${1+"\$@"}'
# =!=!=!=!=!=!=!=!=!=!=!
# This script is automatically generated: DO NOT EDIT!!!
# Generated by Glasgow Haskell, version ${ProjectVersion}
# ngoqvam choHbogh vaj' vIHoHnISbej !!!!
#
\$pvm_executable = '$pvm_executable';
\$pvm_executable_base = '$pvm_executable_base';
......@@ -1942,7 +1943,9 @@ args: while ($a = shift(@ARGV)) {
}
if ( $a eq '-d' && $in_RTS_args ) {
$debug = '-';
} elsif ( $a =~ /^-N(\d+)/ && $in_RTS_args ) {
} elsif ( $a =~ /^-qN(\d+)/ && $in_RTS_args ) {
$nprocessors = $1;
} elsif ( $a =~ /^-qp(\d+)/ && $in_RTS_args ) {
$nprocessors = $1;
} else {
push(@nonPVM_args, $a);
......@@ -2817,9 +2820,24 @@ sub saveIntermediate {
local ($final,$suffix,$tmp)= @_ ;
local ($to_do);
local ($new_suffix);
# $final -- root of where to park ${final}.${suffix}
# $tmp -- temporary file where hsc put the intermediate file.
# HWL: use -odir for .hc and .s files, too
if ( $Specific_output_dir ne '' ) {
$final = "${Specific_output_dir}/${final}";
}
# HWL: use the same suffix as for $Osuffix in generating intermediate file,
# replacing o with hc or s, respectively.
if ( $Osuffix ne '' ) {
($new_suffix = $Osuffix) =~ s/o$/hc/ if $suffix eq "hc";
($new_suffix = $Osuffix) =~ s/o$/s/ if $suffix eq "s";
$suffix = $new_suffix;
print stderr "HWL says: suffix for intermediate file is $suffix; ${final}.${suffix} overall\n" if $Verbose;
}
# Delete the old file
$to_do = "$Rm ${final}.${suffix}"; &run_something($to_do, "Removing old .${suffix} file");
......
#! /usr/local/bin/perl
#! /usr/bin/perl
# a simple wrapper to test a .s-file mangler
# reads stdin, writes stdout
push(@INC,"/net/dazdak/BUILDS/gransim-4.04/i386-unknown-linux/ghc/driver");
$TargetPlatform = $ARGV[0]; shift; # nice error checking, Will
require("ghc-asm.prl") || die "require mangler failed!\n";
......
/* -----------------------------------------------------------------------------
* $Id: CCall.h,v 1.3 1999/02/05 16:02:19 simonm Exp $
* $Id: CCall.h,v 1.4 2000/01/13 14:34:00 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -55,6 +55,9 @@
#define STGCALL5(f,a,b,c,d,e) \
CALLER_SAVE_ALL (void) f(a,b,c,d,e); CALLER_RESTORE_ALL
#define STGCALL6(f,a,b,c,d,e,z) \
CALLER_SAVE_ALL (void) f(a,b,c,d,e,z); CALLER_RESTORE_ALL
#define RET_STGCALL0(t,f) \
({ t _r; CALLER_SAVE_ALL _r = f(); CALLER_RESTORE_ALL; _r; })
......@@ -74,6 +77,9 @@
#define RET_STGCALL5(t,f,a,b,c,d,e) \
({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d,e); CALLER_RESTORE_ALL; _r; })
#define RET_STGCALL6(t,f,a,b,c,d,e,z) \
({ t _r; CALLER_SAVE_ALL _r = f(a,b,c,d,e,z); CALLER_RESTORE_ALL; _r; })
/*
* A PRIM_STGCALL is used when we have arranged to save the R<n>,
......@@ -101,6 +107,9 @@
#define PRIM_STGCALL5(f,a,b,c,d,e) \
CALLER_SAVE_SYSTEM (void) f(a,b,c,d,e); CALLER_RESTORE_SYSTEM
#define PRIM_STGCALL6(f,a,b,c,d,e,z) \
CALLER_SAVE_SYSTEM (void) f(a,b,c,d,e,z); CALLER_RESTORE_SYSTEM
#define RET_PRIM_STGCALL0(t,f) \
({ t _r; CALLER_SAVE_SYSTEM _r = f(); CALLER_RESTORE_SYSTEM; _r; })
......@@ -120,6 +129,9 @@
#define RET_PRIM_STGCALL5(t,f,a,b,c,d,e) \
({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d,e); CALLER_RESTORE_SYSTEM; _r; })
#define RET_PRIM_STGCALL6(t,f,a,b,c,d,e,z) \
({ t _r; CALLER_SAVE_SYSTEM _r = f(a,b,c,d,e,z); CALLER_RESTORE_SYSTEM; _r; })
/* ToDo: ccalls that might garbage collect - do we need to return to
* the scheduler to perform these? Similarly, ccalls that might want
* to call Haskell right back, or start a new thread or something.
......
/* ----------------------------------------------------------------------------
* $Id: ClosureTypes.h,v 1.11 1999/05/11 16:47:40 keithw Exp $
* $Id: ClosureTypes.h,v 1.12 2000/01/13 14:34:00 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -72,10 +72,15 @@
#define WEAK 56
#define FOREIGN 57
#define STABLE_NAME 58
#define TSO 59
#define BLOCKED_FETCH 60
#define FETCH_ME 61
#define EVACUATED 62
#define N_CLOSURE_TYPES 63
#define FETCH_ME_BQ 62
#define RBH 63
#define EVACUATED 64
#define N_CLOSURE_TYPES 65
#endif CLOSURETYPES_H
/* ----------------------------------------------------------------------------
* $Id: Closures.h,v 1.14 1999/12/01 14:34:48 simonmar Exp $
* $Id: Closures.h,v 1.15 2000/01/13 14:34:00 hwloidl Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -37,20 +37,38 @@ typedef struct {
The parallel header
-------------------------------------------------------------------------- */
#ifdef GRAN
#ifdef PAR
typedef struct {
W_ procs;
} StgGranHeader;
/* StgWord ga; */ /* nope! global addresses are managed via a hash table */
} StgParHeader;
#else /* !PAR */
typedef struct {
/* empty */
} StgGranHeader;
} StgParHeader;
#endif /* PAR */
/* -----------------------------------------------------------------------------
The GranSim header
-------------------------------------------------------------------------- */
#if defined(GRAN)
typedef struct {
StgWord procs; /* bitmask indicating on which PEs this closure resides */
} StgGranHeader;
#else /* !GRAN */
typedef struct {
/* empty */
} StgGranHeader;
#endif /* GRAN */
/* -----------------------------------------------------------------------------
The ticky-ticky header
......@@ -96,8 +114,11 @@ typedef struct {
#ifdef PROFILING
StgProfHeader prof;
#endif
#ifdef GRAN
StgGranHeader par;
#ifdef PAR
StgParHeader par;
#endif
#if defined(GRAN)
StgGranHeader gran;
#endif
#ifdef TICKY_TICKY
StgTickyHeader ticky;
......@@ -187,12 +208,6 @@ typedef struct StgCAF_ {
struct StgCAF_ *link;
} StgCAF;
typedef struct {
StgHeader header;
struct StgTSO_ *blocking_queue;
StgMutClosure *mut_link;
} StgBlockingQueue;
typedef struct {
StgHeader header;
StgWord words;
......@@ -294,12 +309,71 @@ typedef struct {
StgClosure* value;
} StgMVar;
/* Parallel FETCH_ME closures */
#ifdef PAR
typedef struct {
#if defined(PAR) || defined(GRAN)
/*
StgBlockingQueueElement represents the types of closures that can be
found on a blocking queue: StgTSO, StgRBHSave, StgBlockedFetch.
(StgRBHSave can only appear at the end of a blocking queue).
Logically, this is a union type, but defining another struct with a common
layout is easier to handle in the code (same as for StgMutClosures).
*/
typedef struct StgBlockingQueueElement_ {
StgHeader header;
struct StgBlockingQueueElement_ *link;
StgMutClosure *mut_link;
struct StgClosure_ *payload[0];
} StgBlockingQueueElement;
typedef struct StgBlockingQueue_ {
StgHeader header;
struct StgBlockingQueueElement_ *blocking_queue;
StgMutClosure *mut_link;
} StgBlockingQueue;
/* this closure is hanging at the end of a blocking queue in (par setup only) */
typedef struct StgRBHSave_ {
StgHeader header;
void *ga; /* type globalAddr is abstract here */
StgPtr payload[0];
} StgRBHSave;
typedef struct StgRBH_ {
StgHeader header;
struct StgBlockingQueueElement_ *blocking_queue;
StgMutClosure *mut_link;
} StgRBH;
#else
/* old sequential version of a blocking queue, which can only hold TSOs */
typedef struct StgBlockingQueue_ {
StgHeader header;
struct StgTSO_ *blocking_queue;
StgMutClosure *mut_link;
} StgBlockingQueue;
#endif
#if defined(PAR)
/* global indirections aka FETCH_ME closures */
typedef struct StgFetchMe_ {
StgHeader header;
globalAddr *ga; /* type globalAddr is abstract here */
StgMutClosure *mut_link;
} StgFetchMe;
/* same contents as an ordinary StgBlockingQueue */
typedef struct StgFetchMeBlockingQueue_ {
StgHeader header;
struct StgBlockingQueueElement_ *blocking_queue;
StgMutClosure *