[project @ 1997-05-26 01:25:28 by sof]

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

diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 560adde..87cd59c 100644 (file)
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -19,7 +19,7 @@ module CgTailCall (
        tailCallBusiness
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import CgMonad
 import AbsCSyn
@@ -32,20 +32,22 @@ import CgRetConv    ( dataReturnConvPrim, dataReturnConvAlg,
                        )
 import CgStackery      ( adjustRealSps, mkStkAmodes )
 import CgUsages                ( getSpARelOffset )
-import CLabel          ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import CLabel          ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel, CLabel )
 import ClosureInfo     ( nodeMustPointToIt,
-                         getEntryConvention, EntryConvention(..)
+                         getEntryConvention, EntryConvention(..),
+                         LambdaFormInfo
                        )
-import CmdLineOpts     ( opt_EmitArityChecks, opt_DoSemiTagging )
-import HeapOffs                ( zeroOff, VirtualSpAOffset(..) )
+import CmdLineOpts     ( opt_DoSemiTagging )
+import HeapOffs                ( zeroOff, SYN_IE(VirtualSpAOffset) )
 import Id              ( idType, dataConTyCon, dataConTag,
-                         fIRST_TAG
+                         fIRST_TAG, SYN_IE(Id)
                        )
 import Literal         ( mkMachInt )
 import Maybes          ( assocMaybe )
 import PrimRep         ( PrimRep(..) )
-import StgSyn          ( StgArg(..), GenStgArg(..), StgLiveVars(..) )
+import StgSyn          ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) )
 import Type            ( isPrimType )
+import TyCon            ( TyCon )
 import Util            ( zipWithEqual, panic, assertPanic )
 \end{code}
 
@@ -79,6 +81,11 @@ Things to be careful about:
 \item  Adjust the stack high water mark appropriately.
 \end{itemize}
 
+\begin{code}
+cgTailCall (StgConArg con) args live_vars
+  = panic "cgTailCall StgConArg"       -- Only occur in argument positions
+\end{code}
+
 Literals are similar to constructors; they return by putting
 themselves in an appropriate register and returning to the address on
 top of the B stack.
@@ -314,10 +321,7 @@ tailCallBusiness :: Id -> CAddrMode        -- Function and its amode
                 -> Code
 
 tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
-  = let
-       do_arity_chks = opt_EmitArityChecks
-    in
-    nodeMustPointToIt lf_info                  `thenFC` \ node_points ->
+  = nodeMustPointToIt lf_info                  `thenFC` \ node_points ->
     getEntryConvention fun lf_info
        (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
 
@@ -336,27 +340,22 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
                ([],
                     mkAbstractCs [
                        CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
-                       CAssign (CReg infoptr)
-
-                               (CMacroExpr DataPtrRep INFO_PTR [CReg node]),
-                       CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr])
+                       CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
                     ])
              StdEntry lbl Nothing        -> ([], CJump (CLbl lbl CodePtrRep))
              StdEntry lbl (Just itbl)    -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep)
                                                     `mkAbsCStmts`
                                                  CJump (CLbl lbl CodePtrRep))
              DirectEntry lbl arity regs  ->
-               (regs,   (if do_arity_chks
-                         then CMacroStmt SET_ARITY [mkIntCLit arity]
-                         else AbsCNop)
-                        `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
+               (regs,   CJump (CLbl lbl CodePtrRep))
 
        no_of_args = length arg_amodes
 
-       (reg_arg_assts, stk_arg_amodes)
-           = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
-                       drop (length arg_regs) arg_amodes) -- No regs, or
-                                                          -- args beyond arity
+       (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
+
+       reg_arg_assts
+         = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
 
        assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
     in