[project @ 2000-07-14 08:14:53 by simonpj]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgTailCall.lhs

diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index c33c649..7428e5e 100644 (file)
--- 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.26 2000/07/14 08:14:53 simonpj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -30,7 +30,7 @@ import CgMonad
 import AbsCSyn
 import PprAbsC         ( pprAmode )
 
-import AbsCUtils       ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import AbsCUtils       ( mkAbstractCs, getAmodeRep )
 import CgBindery       ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
 import CgRetConv       ( dataReturnConvPrim,
                          ctrlReturnConvAlg, CtrlReturnConvention(..),
@@ -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
@@ -47,7 +48,6 @@ import ClosureInfo    ( nodeMustPointToIt,
 import CmdLineOpts     ( opt_DoSemiTagging )
 import Id              ( Id, idType, idName )
 import DataCon         ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Const           ( mkMachInt )
 import Maybes          ( assocMaybe, maybeToBool )
 import PrimRep         ( PrimRep(..) )
 import StgSyn          ( StgArg, GenStgArg(..) )
@@ -55,6 +55,7 @@ import Type           ( isUnLiftedType )
 import TyCon            ( TyCon )
 import PrimOp          ( PrimOp )
 import Util            ( zipWithEqual )
+import Unique          ( mkPseudoUnique1 )
 import Outputable
 import Panic           ( panic, assertPanic )
 \end{code}
@@ -402,8 +403,6 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
   = getEndOfBlockInfo  `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
 
     let
-       no_of_args = length arg_amodes
-
        (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
            -- We get some stk_arg_amodes if (a) no regs, or 
            --                               (b) args beyond arity
@@ -425,6 +424,24 @@ 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.
+       (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))
+                  where
+                    node_save = CTemp (mkPseudoUnique1 2) 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 +459,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