[project @ 2001-08-04 06:11:24 by ken]

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

diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index f771fdb..aa2aec3 100644 (file)
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -22,7 +22,7 @@ import StgSyn
 
 import AbsCUtils       ( getAmodeRep )
 import CgBindery       ( getArgAmodes, bindNewToNode,
-                         bindArgsToRegs, newTempAmodeAndIdInfo,
+                         bindArgsToRegs, 
                          idInfoToAmode, stableAmodeIdInfo,
                          heapIdInfo, CgIdInfo, bindNewToStack
                        )
@@ -31,31 +31,30 @@ import CgStackery   ( mkTaggedVirtStkOffsets, freeStackSlots,
                        )
 import CgUsages                ( getRealSp, getVirtSp, setRealAndVirtualSp,
                          getSpRelOffset )
-import CgClosure       ( cgTopRhsClosure )
 import CgRetConv       ( assignRegs )
-import Constants       ( mAX_INTLIKE, mIN_INTLIKE, mIN_UPD_SIZE )
+import Constants       ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE,
+                         mIN_UPD_SIZE )
 import CgHeapery       ( allocDynClosure, inPlaceAllocDynClosure )
 import CgTailCall      ( performReturn, mkStaticAlgReturnCode, doTailCall,
                          mkUnboxedTupleReturnCode )
 import CLabel          ( mkClosureLabel )
-import ClosureInfo     ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
+import ClosureInfo     ( mkConLFInfo, mkLFArgument,
                          layOutDynCon, layOutDynClosure,
                          layOutStaticClosure, closureSize
                        )
 import CostCentre      ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
                          currentCCS )
-import DataCon         ( DataCon, dataConName, dataConTag, dataConTyCon,
-                         isUnboxedTupleCon, isNullaryDataCon, isDynDataCon, dataConId, dataConWrapId
+import DataCon         ( DataCon, dataConName, dataConTag, 
+                         isUnboxedTupleCon, isNullaryDataCon, dataConId, 
+                         dataConWrapId, dataConRepArity
                        )
-import Id              ( Id, idName, idType, idPrimRep )
-import Name            ( nameModule, isLocallyDefinedName )
-import Module          ( isDynamicModule )
+import Id              ( Id, idName, idPrimRep )
 import Literal         ( Literal(..) )
 import PrelInfo                ( maybeCharLikeCon, maybeIntLikeCon )
 import PrimRep         ( PrimRep(..), isFollowableRep )
 import Unique          ( Uniquable(..) )
 import Util
-import Panic           ( assertPanic, trace )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -70,7 +69,14 @@ cgTopRhsCon :: Id            -- Name of thing bound to this RHS
            -> [StgArg]         -- Args
            -> FCode (Id, CgIdInfo)
 cgTopRhsCon id con args
-  = ASSERT(not dynamic_con_or_args)    -- checks for litlit args too
+  = ASSERT(not (isDllConApp con args)) -- checks for litlit args too
+    ASSERT(length args == dataConRepArity con)
+    let
+       name          = idName id
+       closure_label = mkClosureLabel name
+       lf_info       = mkConLFInfo con
+    in
+
     (
        -- LAY IT OUT
     getArgAmodes args          `thenFC` \ amodes ->
@@ -84,23 +90,13 @@ cgTopRhsCon id con args
     absC (CStaticClosure
            closure_label               -- Labelled with the name on lhs of defn
            closure_info                -- Closure is static
-           top_ccc
+           (mkCCostCentreStack dontCareCCS) -- because it's static data
            (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
 
     ) `thenC`
 
        -- RETURN
     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
-  where
-    con_tycon      = dataConTyCon   con
-    lf_info        = mkConLFInfo    con
-    closure_label   = mkClosureLabel name
-    name            = idName id
-
-    top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
-
-    -- stuff needed by the assert pred only.
-    dynamic_con_or_args = isDynDataCon con || any isDynArg args
 \end{code}
 
 %************************************************************************
@@ -145,6 +141,12 @@ buildDynCon binder cc con []
                                (mkConLFInfo con))
 \end{code}
 
+The following three paragraphs about @Char@-like and @Int@-like
+closures are obsolete, but I don't understand the details well enough
+to properly word them, sorry. I've changed the treatment of @Char@s to
+be analogous to @Int@s: only a subset is preallocated, because @Char@
+has now 31 bits. Only literals are handled here. -- Qrczak
+
 Now for @Char@-like closures.  We generate an assignment of the
 address of the closure to a temporary.  It would be possible simply to
 generate no code, and record the addressing mode in the environment,
@@ -162,20 +164,18 @@ Because of this, we use can safely return an addressing mode.
 
 \begin{code}
 buildDynCon binder cc con [arg_amode]
-
-  | maybeCharLikeCon con
-  = absC (CAssign temp_amode (CCharLike arg_amode))    `thenC`
-    returnFC temp_id_info
-
   | maybeIntLikeCon con && in_range_int_lit arg_amode
   = returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
   where
-    (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 other_amode         = False
+    in_range_int_lit _other_amode        = False
 
-    tycon = dataConTyCon con
+buildDynCon binder cc con [arg_amode]
+  | maybeCharLikeCon con && in_range_char_lit arg_amode
+  = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
+  where
+    in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
+    in_range_char_lit _other_amode         = False
 \end{code}
 
 Now the general case.
@@ -270,7 +270,8 @@ sure the @amodes@ passed don't conflict with each other.
 cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 
 cgReturnDataCon con amodes
-  = getEndOfBlockInfo  `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
+  = ASSERT(length amodes == dataConRepArity con)
+    getEndOfBlockInfo  `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
 
     case sequel of
 
@@ -300,7 +301,6 @@ cgReturnDataCon con amodes
        -- do update in place...
       UpdateCode
        |  not (isNullaryDataCon con)  -- no nullary constructors, please
-       && not (maybeCharLikeCon con)  -- no chars please (these are all static)
        && not (any isFollowableRep (map getAmodeRep amodes))
                                        -- no ptrs please (generational gc...)
        && closureSize closure_info <= mIN_UPD_SIZE
@@ -365,8 +365,6 @@ cgReturnDataCon con amodes
                build_it_then (mkStaticAlgReturnCode con)
 
   where
-    con_name = dataConName con
-
     move_to_reg :: CAddrMode -> MagicId -> AbstractC
     move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode