summaryrefslogtreecommitdiff
path: root/ghc/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler')
-rw-r--r--ghc/compiler/absCSyn/AbsCSyn.lhs3
-rw-r--r--ghc/compiler/absCSyn/CLabel.lhs4
-rw-r--r--ghc/compiler/absCSyn/PprAbsC.lhs4
-rw-r--r--ghc/compiler/codeGen/CgClosure.lhs13
-rw-r--r--ghc/compiler/codeGen/CgTailCall.lhs29
-rw-r--r--ghc/compiler/codeGen/ClosureInfo.lhs8
-rw-r--r--ghc/compiler/main/CmdLineOpts.lhs2
7 files changed, 49 insertions, 14 deletions
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index cb65a7f239..6caa9c50be 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.25 1999/10/31 15:35:32 sof Exp $
+% $Id: AbsCSyn.lhs,v 1.26 1999/11/02 15:05:39 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
@@ -473,6 +473,7 @@ data MagicId
node = VanillaReg PtrRep ILIT(1) -- A convenient alias for Node
tagreg = VanillaReg WordRep ILIT(2) -- A convenient alias for TagReg
+nodeReg = CReg node
\end{code}
We need magical @Eq@ because @VanillaReg@s come in multiple flavors.
diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 636a2f3f99..644a13d364 100644
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.28 1999/10/13 16:39:10 simonmar Exp $
+% $Id: CLabel.lhs,v 1.29 1999/11/02 15:05:40 simonmar Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
@@ -37,6 +37,7 @@ module CLabel (
mkErrorStdEntryLabel,
mkUpdInfoLabel,
mkTopTickyCtrLabel,
+ mkBlackHoleInfoTableLabel,
mkCAFBlackHoleInfoTableLabel,
mkSECAFBlackHoleInfoTableLabel,
mkRtsPrimOpLabel,
@@ -215,6 +216,7 @@ mkAsmTempLabel = AsmTempLabel
mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode
mkUpdInfoLabel = RtsLabel RtsUpdInfo
mkTopTickyCtrLabel = RtsLabel RtsTopTickyCtr
+mkBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("BLACKHOLE_info"))
mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsBlackHoleInfoTbl SLIT("CAF_BLACKHOLE_info"))
mkSECAFBlackHoleInfoTableLabel = if opt_DoTickyProfiling then
RtsLabel (RtsBlackHoleInfoTbl SLIT("SE_CAF_BLACKHOLE_info"))
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index b708742ad1..ae61d06fd6 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -787,8 +787,8 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
(pp_save_context, pp_restore_context)
- | may_gc = ( text "do { SaveThreadState();"
- , text "LoadThreadState();} while(0);"
+ | may_gc = ( text "do { I_ id; SaveThreadState(); id = suspendThread(BaseReg);"
+ , text "BaseReg = resumeThread(id); LoadThreadState();} while(0);"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index dc326087c9..38c88dd999 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.36 1999/11/01 17:10:07 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.37 1999/11/02 15:05:43 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
@@ -269,6 +269,7 @@ closureCodeBody binder_info closure_info cc [] body
cl_descr mod_name = closureDescription mod_name (closureName closure_info)
body_label = entryLabelFromCI closure_info
+
is_box = case body of { StgApp fun [] -> True; _ -> False }
body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
@@ -577,7 +578,7 @@ thunkWrapper closure_info lbl thunk_code
thunkChecks lbl node_points (
-- Overwrite with black hole if necessary
- blackHoleIt closure_info node_points `thenC`
+ blackHoleIt closure_info node_points `thenC`
setupUpdate closure_info ( -- setupUpdate *encloses* the rest
@@ -624,10 +625,14 @@ blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no a
blackHoleIt closure_info node_points
= if blackHoleOnEntry closure_info && node_points
then
+ let
+ info_label = infoTableLabelFromCI closure_info
+ args = [ CLbl info_label DataPtrRep ]
+ in
absC (if closureSingleEntry(closure_info) then
- CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
+ CMacroStmt UPD_BH_SINGLE_ENTRY args
else
- CMacroStmt UPD_BH_UPDATABLE [CReg node])
+ CMacroStmt UPD_BH_UPDATABLE args)
else
nopC
\end{code}
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index c33c649d92..46e3b0219f 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.22 1999/06/22 08:00:00 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.23 1999/11/02 15:05:43 simonmar Exp $
%
%********************************************************
%* *
@@ -39,7 +39,8 @@ import CgRetConv ( dataReturnConvPrim,
import CgStackery ( mkTaggedStkAmodes, adjustStackHW )
import CgUsages ( getSpRelOffset, adjustSpAndHp )
import CgUpdate ( pushSeqFrame )
-import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel )
+import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel,
+ mkBlackHoleInfoTableLabel )
import ClosureInfo ( nodeMustPointToIt,
getEntryConvention, EntryConvention(..),
LambdaFormInfo
@@ -55,6 +56,7 @@ import Type ( isUnLiftedType )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
import Util ( zipWithEqual )
+import Unique ( mkPseudoUnique1 )
import Outputable
import Panic ( panic, assertPanic )
\end{code}
@@ -425,6 +427,23 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
(fast_stk_amodes, tagged_stk_amodes) =
splitAt arity stk_arg_amodes
+
+ -- eager blackholing, at the end of the basic block.
+ node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
+ (r1_tmp_asst, bh_asst)
+ = case sequel of
+#if 0
+ -- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
+ -- we might be in a case continuation later down the line. Also,
+ -- we might have pushed a return address on the stack, if we're in
+ -- a case scrut, and still be in the thunk's entry code.
+ UpdateCode ->
+ (CAssign node_save nodeReg,
+ CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep)
+ PtrRep)
+ (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
+#endif
+ _ -> (AbsCNop, AbsCNop)
in
-- We can omit tags on the arguments passed to the fast entry point,
-- but we have to be careful to fill in the tags on any *extra*
@@ -442,12 +461,14 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
-- The stack space for the pushed return addess,
-- with any args pushed on top, is recorded in final_sp.
- -- Do the simultaneous assignments,
- doSimAssts (mkAbstractCs [pending_assts,
+ -- Do the simultaneous assignments,
+ doSimAssts (mkAbstractCs [r1_tmp_asst,
+ pending_assts,
reg_arg_assts,
fast_arg_assts,
tagged_arg_assts,
tag_assts]) `thenC`
+ absC bh_asst `thenC`
-- push a return address if necessary
-- (after the assignments above, in case we clobber a live
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 3b7b5a1b1b..157a6b70e2 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.38 1999/05/18 15:03:50 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.39 1999/11/02 15:05:44 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
@@ -77,7 +77,8 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
mkReturnPtLabel
)
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
- opt_Parallel, opt_DoTickyProfiling )
+ opt_Parallel, opt_DoTickyProfiling,
+ opt_SMP )
import Id ( Id, idType, getIdArity )
import DataCon ( DataCon, dataConTag, fIRST_TAG,
isNullaryDataCon, isTupleCon, dataConName
@@ -679,6 +680,9 @@ getEntryConvention name lf_info arg_kinds
LFThunk _ _ _ updatable std_form_info _ _
-> if updatable || opt_DoTickyProfiling -- to catch double entry
+ || opt_SMP -- always enter via node on SMP, since the
+ -- thunk might have been blackholed in the
+ -- meantime.
then ViaNode
else StdEntry (thunkEntryLabel name std_form_info updatable)
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 3101d027ec..e3a5f22672 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -87,6 +87,7 @@ module CmdLineOpts (
opt_IrrefutableTuples,
opt_NumbersStrict,
opt_Parallel,
+ opt_SMP,
-- optimisation opts
opt_DoEtaReduction,
@@ -375,6 +376,7 @@ opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples")
opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
opt_NumbersStrict = lookUp SLIT("-fnumbers-strict")
opt_Parallel = lookUp SLIT("-fparallel")
+opt_SMP = lookUp SLIT("-fsmp")
-- optimisation opts
opt_DoEtaReduction = lookUp SLIT("-fdo-eta-reduction")
View Lorry Controller Status