[project @ 1998-08-14 11:50:58 by sof]

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

diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 6c378a9..ea44e5c 100644 (file)
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -8,15 +8,13 @@ with {\em constructors} on the RHSs of let(rec)s.  See also
 @CgClosure@, which deals with closures.
 
 \begin{code}
-#include "HsVersions.h"
-
 module CgCon (
        cgTopRhsCon, buildDynCon,
        bindConArgs,
        cgReturnDataCon
     ) where
 
-import Ubiq{-uitous-}
+#include "HsVersions.h"
 
 import CgMonad
 import AbsCSyn
@@ -26,35 +24,33 @@ import AbsCUtils    ( mkAbstractCs, getAmodeRep )
 import CgBindery       ( getArgAmodes, bindNewToNode,
                          bindArgsToRegs, newTempAmodeAndIdInfo,
                          idInfoToAmode, stableAmodeIdInfo,
-                         heapIdInfo
+                         heapIdInfo, CgIdInfo
                        )
 import CgClosure       ( cgTopRhsClosure )
-import CgCompInfo      ( mAX_INTLIKE, mIN_INTLIKE )
+import Constants       ( mAX_INTLIKE, mIN_INTLIKE )
 import CgHeapery       ( allocDynClosure )
 import CgRetConv       ( dataReturnConvAlg, DataReturnConvention(..) )
 import CgTailCall      ( performReturn, mkStaticAlgReturnCode )
-import CLabel          ( mkClosureLabel, mkInfoTableLabel,
-                         mkPhantomInfoTableLabel,
-                         mkConEntryLabel, mkStdEntryLabel
+import CLabel          ( mkClosureLabel, mkStaticClosureLabel,
+                         mkConInfoTableLabel, mkPhantomInfoTableLabel
                        )
 import ClosureInfo     ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
                          layOutDynCon, layOutDynClosure,
                          layOutStaticClosure
                        )
 import CostCentre      ( currentOrSubsumedCosts, useCurrentCostCentre,
-                         dontCareCostCentre
+                         dontCareCostCentre, CostCentre
                        )
 import Id              ( idPrimRep, dataConTag, dataConTyCon,
-                         isDataCon, DataCon(..),
-                         emptyIdSet
+                         isDataCon, DataCon,
+                         emptyIdSet, Id
                        )
 import Literal         ( Literal(..) )
 import Maybes          ( maybeToBool )
+import PrelInfo                ( maybeCharLikeCon, maybeIntLikeCon )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
+import TyCon           ( TyCon{-instance Uniquable-} )
 import Util            ( isIn, zipWithEqual, panic, assertPanic )
-
-maybeCharLikeTyCon = panic "CgCon.maybeCharLikeTyCon (ToDo)"
-maybeIntLikeTyCon  = panic "CgCon.maybeIntLikeTyCon  (ToDo)"
 \end{code}
 
 %************************************************************************
@@ -126,7 +122,7 @@ cgTopRhsCon name con args all_zero_size_args
   = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
   where
     body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
-    lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
+    lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant []
 \end{code}
 
 OK, so now we have the general case.
@@ -158,13 +154,9 @@ cgTopRhsCon name con args all_zero_size_args
        -- RETURN
     returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
   where
-    con_tycon      = dataConTyCon con
-    lf_info        = mkConLFInfo     con
-
-    closure_label   = mkClosureLabel   name
-    info_label      = mkInfoTableLabel con
-    con_entry_label = mkConEntryLabel  con
-    entry_label            = mkStdEntryLabel  name
+    con_tycon      = dataConTyCon   con
+    lf_info        = mkConLFInfo    con
+    closure_label   = mkClosureLabel name
 \end{code}
 
 The general case is:
@@ -278,7 +270,7 @@ at all.
 buildDynCon binder cc con args all_zero_size_args@True
   = ASSERT(isDataCon con)
     returnFC (stableAmodeIdInfo binder
-                               (CLbl (mkClosureLabel con) PtrRep)
+                               (CLbl (mkStaticClosureLabel con) PtrRep)
                                (mkConLFInfo con))
 \end{code}
 
@@ -300,19 +292,19 @@ Because of this, we use can safely return an addressing mode.
 \begin{code}
 buildDynCon binder cc con [arg_amode] all_zero_size_args@False
 
-  | maybeToBool (maybeCharLikeTyCon tycon)
+  | maybeCharLikeCon con
   = ASSERT(isDataCon con)
     absC (CAssign temp_amode (CCharLike arg_amode))    `thenC`
     returnFC temp_id_info
 
-  | maybeToBool (maybeIntLikeTyCon tycon) && in_range_int_lit arg_amode
+  | maybeIntLikeCon con && in_range_int_lit arg_amode
   = ASSERT(isDataCon con)
     returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
   where
-    tycon = dataConTyCon con
     (temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
 
-    in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
+    in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && 
+                                             val >= mIN_INTLIKE
     in_range_int_lit other_amode           = False
 \end{code}
 
@@ -428,7 +420,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 
                        -- MAKE NODE POINT TO IT
                  let reg_assts = move_to_reg amode node
-                     info_lbl  = mkInfoTableLabel con
+                     info_lbl  = mkConInfoTableLabel con
                  in
 
                        -- RETURN
@@ -438,7 +430,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 
              ReturnInRegs regs  ->
                  let
-                     reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs)
+                     reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs)
                      info_lbl  = mkPhantomInfoTableLabel con
                  in
                  profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`