[project @ 2002-02-14 13:59:22 by simonpj]

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

diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 954dca8..3b91214 100644 (file)
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -40,7 +40,7 @@ import CgTailCall     ( performReturn, mkStaticAlgReturnCode, doTailCall,
 import CLabel          ( mkClosureLabel )
 import ClosureInfo     ( mkConLFInfo, mkLFArgument, closureLFInfo,
                          layOutDynConstr, layOutDynClosure,
-                         layOutStaticConstr, closureSize
+                         layOutStaticConstr, closureSize, mkStaticClosure
                        )
 import CostCentre      ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
                          currentCCS )
@@ -67,29 +67,34 @@ import Outputable
 cgTopRhsCon :: Id              -- Name of thing bound to this RHS
            -> DataCon          -- Id
            -> [StgArg]         -- Args
+           -> SRT
            -> FCode (Id, CgIdInfo)
-cgTopRhsCon id con args
-  = ASSERT(not (isDllConApp con args)) -- checks for litlit args too
-    ASSERT(length args == dataConRepArity con)
+cgTopRhsCon id con args srt
+  = ASSERT( not (isDllConApp con args) )       -- checks for litlit args too
+    ASSERT( args `lengthIs` dataConRepArity con )
 
        -- LAY IT OUT
     getArgAmodes args          `thenFC` \ amodes ->
 
     let
        name          = idName id
-       closure_label = mkClosureLabel name
        lf_info       = closureLFInfo closure_info
-       (closure_info, amodes_w_offsets) = layOutStaticConstr name con getAmodeRep amodes
+       closure_label = mkClosureLabel name
+       (closure_info, amodes_w_offsets) 
+               = layOutStaticConstr name con getAmodeRep amodes
     in
 
        -- BUILD THE OBJECT
-    absC (CStaticClosure
-           closure_label               -- Labelled with the name on lhs of defn
-           closure_info                -- Closure is static
-           (mkCCostCentreStack dontCareCCS) -- because it's static data
-           (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
-
-                                                       `thenC`
+    absC (mkStaticClosure
+           closure_info
+           dontCareCCS                 -- because it's static data
+           (map fst amodes_w_offsets)  -- Sorted into ptrs first, then nonptrs
+           (nonEmptySRT srt)           -- has CAF refs
+         )                                     `thenC`
+               -- NOTE: can't use idCafInfo instead of nonEmptySRT above,
+               -- because top-level constructors that were floated by
+               -- CorePrep don't have CafInfo attached.  The SRT is more
+               -- reliable.
 
        -- RETURN
     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
@@ -234,7 +239,7 @@ bindUnboxedTupleComponents
 bindUnboxedTupleComponents args
  =  -- Assign as many components as possible to registers
     let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
-       (reg_args, stk_args)   = splitAt (length arg_regs) args
+       (reg_args, stk_args)   = splitAtList arg_regs args
     in
 
     -- Allocate the rest on the stack (ToDo: separate out pointers)
@@ -268,7 +273,7 @@ sure the @amodes@ passed don't conflict with each other.
 cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
 
 cgReturnDataCon con amodes
-  = ASSERT(length amodes == dataConRepArity con)
+  = ASSERT( amodes `lengthIs` dataConRepArity con )
     getEndOfBlockInfo  `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
 
     case sequel of