[project @ 2000-03-23 17:45:17 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 e98f66b..82c64a4 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.21 1999/06/08 15:56:48 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.24 2000/03/23 17:45:19 simonpj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -28,6 +28,7 @@ module CgTailCall (
 
 import CgMonad
 import AbsCSyn
+import PprAbsC         ( pprAmode )
 
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
 import CgBindery       ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
@@ -38,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
@@ -46,7 +48,7 @@ import ClosureInfo    ( nodeMustPointToIt,
 import CmdLineOpts     ( opt_DoSemiTagging )
 import Id              ( Id, idType, idName )
 import DataCon         ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Const           ( mkMachInt )
+import Literal         ( mkMachInt )
 import Maybes          ( assocMaybe, maybeToBool )
 import PrimRep         ( PrimRep(..) )
 import StgSyn          ( StgArg, GenStgArg(..) )
@@ -54,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}
@@ -118,7 +121,8 @@ performPrimReturn :: SDoc   -- Just for debugging (sigh)
 performPrimReturn doc amode
   = let
        kind = getAmodeRep amode
-       ret_reg = dataReturnConvPrim kind
+       ret_reg = WARN( case kind of { PtrRep -> True; other -> False }, text "primRet" <+> doc <+> pprAmode amode )
+                 dataReturnConvPrim kind
 
        assign_possibly = case kind of
          VoidRep -> AbsCNop
@@ -423,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*
@@ -440,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