[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 b6953b1..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.18 1999/01/21 10:31:57 simonm 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 )
@@ -35,10 +36,11 @@ import CgRetConv    ( dataReturnConvPrim,
                          ctrlReturnConvAlg, CtrlReturnConvention(..),
                          assignAllRegs, assignRegs
                        )
-import CgStackery      ( adjustRealSp, mkTaggedStkAmodes, adjustStackHW )
-import CgUsages                ( getSpRelOffset )
+import CgStackery      ( mkTaggedStkAmodes, adjustStackHW )
+import CgUsages                ( getSpRelOffset, adjustSpAndHp )
 import CgUpdate                ( pushSeqFrame )
-import CLabel          ( mkUpdEntryLabel, mkRtsPrimOpLabel )
+import CLabel          ( mkUpdInfoLabel, mkRtsPrimOpLabel, 
+                         mkBlackHoleInfoTableLabel )
 import ClosureInfo     ( nodeMustPointToIt,
                          getEntryConvention, EntryConvention(..),
                          LambdaFormInfo
@@ -46,14 +48,15 @@ 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 )
+import Literal         ( mkMachInt )
+import Maybes          ( assocMaybe, maybeToBool )
 import PrimRep         ( PrimRep(..) )
 import StgSyn          ( StgArg, GenStgArg(..) )
 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
@@ -168,7 +172,7 @@ mkStaticAlgReturnCode con sequel
        UpdateCode ->   -- Ha!  We can go direct to the update code,
                        -- (making sure to jump to the *correct* update
                        --  code.)
-                       absC (CReturn (CLbl mkUpdEntryLabel CodePtrRep)
+                       absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep)
                                      return_info)
 
        CaseAlts _ (Just (alts, _)) ->  -- Ho! We know the constructor so
@@ -266,8 +270,8 @@ performReturn sim_assts finish_code
        --  stack location)
     pushReturnAddress eob              `thenC`
 
-       -- Adjust stack pointer
-    adjustRealSp args_sp               `thenC`
+       -- Adjust Sp/Hp
+    adjustSpAndHp args_sp              `thenC`
 
        -- Do the return
     finish_code sequel         -- "sequel" is `robust' in that it doesn't
@@ -299,8 +303,8 @@ returnUnboxedTuple amodes before_jump
     pushReturnAddress eob              `thenC`
     setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
 
-       -- Adjust stack pointer
-    adjustRealSp args_sp               `thenC`
+       -- Adjust Sp/Hp
+    adjustSpAndHp args_sp              `thenC`
 
     before_jump                                `thenC`
 
@@ -390,7 +394,8 @@ doTailCall
        -> (Sequel->Code)               -- code to perform jump
        -> Int                          -- number of "fast" stack arguments
        -> AbstractC                    -- pending assignments
-       -> Maybe VirtualSpOffset        -- sp offset to trim stack to
+       -> Maybe VirtualSpOffset        -- sp offset to trim stack to: 
+                                       -- USED iff destination is a let-no-escape
        -> Bool                         -- node points to the closure to enter
        -> Code
 
@@ -422,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*
@@ -439,20 +461,28 @@ 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
                --  stack location)
-       pushReturnAddress eob           `thenC`
 
-               -- Final adjustment of stack pointer
-       adjustRealSp final_sp           `thenC`
+               -- DONT push the return address when we're about
+               -- to jump to a let-no-escape: the final tail call
+               -- in the let-no-escape will do this.
+       (if (maybeToBool maybe_join_sp)
+               then nopC
+               else pushReturnAddress eob)             `thenC`
+
+               -- Final adjustment of Sp/Hp
+       adjustSpAndHp final_sp          `thenC`
        
                -- Now decide about semi-tagging
        let