[project @ 2000-12-06 13:19:49 by simonmar]

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

diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index c1a6ec3..06e7ff5 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.25 2000/07/11 16:03:37 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.29 2000/12/06 13:19:49 simonmar Exp $
 %
 %********************************************************
 %*                                                     *
@@ -42,20 +42,19 @@ import CgUpdate             ( pushSeqFrame )
 import CLabel          ( mkUpdInfoLabel, mkRtsPrimOpLabel, 
                          mkBlackHoleInfoTableLabel )
 import ClosureInfo     ( nodeMustPointToIt,
-                         getEntryConvention, EntryConvention(..),
-                         LambdaFormInfo
+                         getEntryConvention, EntryConvention(..), LambdaFormInfo
                        )
 import CmdLineOpts     ( opt_DoSemiTagging )
 import Id              ( Id, idType, idName )
 import DataCon         ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Maybes          ( assocMaybe, maybeToBool )
+import Maybes          ( maybeToBool )
 import PrimRep         ( PrimRep(..) )
-import StgSyn          ( StgArg, GenStgArg(..) )
+import StgSyn          ( StgArg )
 import Type            ( isUnLiftedType )
 import TyCon            ( TyCon )
 import PrimOp          ( PrimOp )
 import Util            ( zipWithEqual )
-import Unique          ( mkPseudoUnique1 )
+import ListSetOps      ( assocMaybe )
 import Outputable
 import Panic           ( panic, assertPanic )
 \end{code}
@@ -322,38 +321,33 @@ returnUnboxedTuple amodes before_jump
 \end{code}
 
 \begin{code}
-performTailCall :: Id          -- Function
-               -> [StgArg]     -- Args
-               -> Code
-
+performTailCall :: Id -> [StgArg] -> Code
 performTailCall fun args
-  =    -- Get all the info we have about the function and args and go on to
-       -- the business end
-    getCAddrModeAndInfo fun    `thenFC` \ (fun_amode, lf_info) ->
-    getArgAmodes args          `thenFC` \ arg_amodes ->
-
-    tailCallFun
-               fun fun_amode lf_info arg_amodes
-               AbsCNop {- No pending assignments -}
-
-
--- generating code for a tail call to a function (or closure)
-
-tailCallFun :: Id -> CAddrMode -- Function and its amode
-                -> LambdaFormInfo      -- Info about the function
-                -> [CAddrMode]         -- Arguments
+  = getCAddrModeAndInfo fun                    `thenFC` \ (fun', fun_amode, lf_info) ->
+    getArgAmodes args                          `thenFC` \ arg_amodes ->
+    tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -}
+\end{code}
 
-                -> AbstractC           -- Pending simultaneous assignments
-                                       -- *** GUARANTEED to contain only stack 
-                                       -- assignments.
+Generating code for a tail call to a function (or closure)
 
+\begin{code}
+tailCallFun
+        :: Id                          -- Function
+        -> CAddrMode
+        -> LambdaFormInfo
+        -> [CAddrMode]                 -- Arguments
+        -> AbstractC                   -- Pending simultaneous assignments
+                                         -- *** GUARANTEED to contain only stack 
+                                         -- assignments.
                                        -- In ptic, we don't need to look in 
                                        -- here to discover all live regs
-
-                -> Code
+        -> Code
 
 tailCallFun fun fun_amode lf_info arg_amodes pending_assts
   = nodeMustPointToIt lf_info                  `thenFC` \ node_points ->
+       -- we use the name of fun', the Id from the environment, rather than
+       -- fun from the STG tree, in case it is a top-level name that we globalised
+       -- (see cgTopRhsClosure).
     getEntryConvention (idName fun) lf_info
        (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
     let
@@ -403,8 +397,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
@@ -428,7 +420,6 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
                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
@@ -441,6 +432,8 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
                    CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep) 
                                  PtrRep)
                            (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
+                  where
+                    node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
 #endif
                _ -> (AbsCNop, AbsCNop)
     in