[project @ 1998-08-14 12:08:25 by sof]

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

diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index c35219e..801ad82 100644 (file)
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -4,49 +4,46 @@
 \section[CgConTbls]{Info tables and update bits for constructors}
 
 \begin{code}
-#include "HsVersions.h"
-
 module CgConTbls ( genStaticConBits ) where
 
-import Ubiq{-uitous-}
+#include "HsVersions.h"
 
 import AbsCSyn
 import CgMonad
 
 import AbsCUtils       ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
-import CgCompInfo      ( uF_UPDATEE )
+import Constants       ( uF_UPDATEE )
 import CgHeapery       ( heapCheck, allocDynClosure )
-import CgRetConv       ( mkLiveRegsMask,
-                         dataReturnConvAlg, ctrlReturnConvAlg,
+import CgRetConv       ( dataReturnConvAlg, ctrlReturnConvAlg,
                          CtrlReturnConvention(..),
                          DataReturnConvention(..)
                        )
 import CgTailCall      ( performReturn, mkStaticAlgReturnCode )
 import CgUsages                ( getHpRelOffset )
-import CLabel          ( mkConEntryLabel, mkClosureLabel,
+import CLabel          ( mkConEntryLabel, mkStaticClosureLabel,
                          mkConUpdCodePtrVecLabel,
                          mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel
                        )
 import ClosureInfo     ( layOutStaticClosure, layOutDynCon,
                          layOutPhantomClosure, closurePtrsSize,
                          fitsMinUpdSize, mkConLFInfo,
-                         infoTableLabelFromCI, dataConLiveness
+                         infoTableLabelFromCI, dataConLiveness,
+                         ClosureInfo
                        )
-import CostCentre      ( dontCareCostCentre )
-import FiniteMap       ( fmToList )
-import HeapOffs                ( zeroOff, VirtualHeapOffset(..) )
-import Id              ( dataConTag, dataConSig,
-                         dataConArity, fIRST_TAG,
+import CostCentre      ( dontCareCostCentre, CostCentre )
+import FiniteMap       ( fmToList, FiniteMap )
+import HeapOffs                ( zeroOff, VirtualHeapOffset )
+import Id              ( dataConTag, dataConRawArgTys,
+                         dataConNumFields, fIRST_TAG,
                          emptyIdSet,
-                         GenId{-instance NamedThing-}
+                         GenId{-instance NamedThing-}, Id
                        )
-import Name            ( getLocalName )
+import Name            ( getOccString )
 import PrimRep         ( getPrimRepSize, PrimRep(..) )
-import TyCon           ( tyConDataCons, mkSpecTyCon )
-import Type            ( typePrimRep )
+import TyCon           ( tyConDataCons, mkSpecTyCon, TyCon )
+import Type            ( typePrimRep, Type )
 import Util            ( panic )
 
-maybeIntLikeTyCon = panic "CgConTbls.maybeIntLikeTyCon (ToDo)"
 mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)"
 \end{code}
 
@@ -209,7 +206,7 @@ genConInfo comp_info tycon data_con
                      body_code))
 
     entry_addr = CLbl entry_label CodePtrRep
-    con_descr  = _UNPK_ (getLocalName data_con)
+    con_descr  = getOccString data_con
 
     closure_code        = CClosureInfoAndCode closure_info body Nothing
                                              stdUpd con_descr
@@ -240,12 +237,30 @@ genConInfo comp_info tycon data_con
 
     zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
 
-    (_,_,arg_tys,_) = dataConSig   data_con
-    con_arity      = dataConArity data_con
-    entry_label     = mkConEntryLabel data_con
-    closure_label   = mkClosureLabel  data_con
+    arg_tys        = dataConRawArgTys     data_con
+    entry_label     = mkConEntryLabel      data_con
+    closure_label   = mkStaticClosureLabel data_con
 \end{code}
 
+The entry code for a constructor now loads the info ptr by indirecting
+node.  The alternative is to load the info ptr in the enter-via-node
+sequence.  There's is a trade-off here:
+
+       * If the architecture can perform an indirect jump through a
+         register in one instruction, or if the info ptr is not a
+         real register, then *not* loading the info ptr on an enter
+         is a win.
+
+       * If the enter-via-node code is identical whether we load the
+         info ptr or not, then doing it is a win (it means we don't
+         have to do it here).
+
+However, the gratuitous load here is miniscule compared to the
+gratuitous loads of the info ptr on each enter, so we go for the first
+option.
+
+-- Simon M. (6/5/96)
+
 \begin{code}
 mkConCodeAndInfo :: Id                         -- Data constructor
                 -> (ClosureInfo, Code) -- The info table
@@ -261,7 +276,7 @@ mkConCodeAndInfo con
            body_code
              = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
 
-               performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
+               performReturn (mkAbstractCs (load_infoptr : map move_to_reg regs_w_offsets))
                              (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
                              emptyIdSet{-no live vars-}
        in
@@ -269,7 +284,7 @@ mkConCodeAndInfo con
 
     ReturnInHeap ->
        let
-           (_, _, arg_tys, _) = dataConSig con
+           arg_tys = dataConRawArgTys con
 
            (closure_info, arg_things)
                = layOutDynCon con typePrimRep arg_tys
@@ -278,7 +293,7 @@ mkConCodeAndInfo con
                = -- NB: We don't set CC when entering data (WDP 94/06)
                  profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
 
-                 performReturn AbsCNop -- Ptr to thing already in Node
+                 performReturn (mkAbstractCs [load_infoptr])   -- Ptr to thing already in Node
                                (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
                                emptyIdSet{-no live vars-}
        in
@@ -288,6 +303,9 @@ mkConCodeAndInfo con
     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
     move_to_reg (reg, offset)
       = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
+
+    load_infoptr 
+      = CAssign (CReg infoptr) (CMacroExpr DataPtrRep INFO_PTR [CReg node])
 \end{code}
 
 %************************************************************************
@@ -315,9 +333,9 @@ genPhantomUpdInfo comp_info tycon data_con
 
            phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
 
-           con_descr = _UNPK_ (getLocalName data_con)
+           con_descr = getOccString data_con
 
-           con_arity = dataConArity data_con
+           con_arity = dataConNumFields data_con
 
            upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
            upd_label = mkConUpdCodePtrVecLabel tycon tag