X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmCon.hs;h=cfac231eda8b2f05229b538cb67f1cfe3b5384fc;hb=984a288119983912d40a80845c674ee4b83a19ce;hp=de1d77ad20f3ebd78e71e2c6b36ba053c9a15ac4;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index de1d77a..cfac231 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -27,6 +27,7 @@ import StgCmmProf
 
 import Cmm
 import CLabel
+import MkZipCfgCmm (CmmAGraph, mkNop)
 import SMRep
 import CostCentre
 import Constants
@@ -37,7 +38,7 @@ import Literal
 import PrelInfo
 import Outputable
 import Util             ( lengthIs )
-import Char		( ord )
+import Data.Char
 
 
 ---------------------------------------------------------------
@@ -47,7 +48,7 @@ import Char		( ord )
 cgTopRhsCon :: Id		-- Name of thing bound to this RHS
 	    -> DataCon		-- Id
 	    -> [StgArg]		-- Args
-	    -> FCode (Id, CgIdInfo)
+	    -> FCode CgIdInfo
 cgTopRhsCon id con args
   = do { 
 #if mingw32_TARGET_OS
@@ -67,7 +68,7 @@ cgTopRhsCon id con args
 			= layOutStaticConstr con (addArgReps args)
 
 	    get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
-					; return lit }
+				        ; return lit }
 
 	; payload <- mapM get_lit nv_args_w_offsets
 		-- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
@@ -83,7 +84,7 @@ cgTopRhsCon id con args
 	; emitDataLits closure_label closure_rep
 
 		-- RETURN
-	; return (id, litIdInfo id lf_info (CmmLabel closure_label)) }
+	; return $ litIdInfo id lf_info (CmmLabel closure_label) }
 
 
 ---------------------------------------------------------------
@@ -96,7 +97,8 @@ buildDynCon :: Id		  -- Name of the thing to which this constr will
 				  -- current CCS if currentOrSubsumedCCS
 	    -> DataCon		  -- The data constructor
 	    -> [StgArg] 	  -- Its args
-	    -> FCode CgIdInfo	  -- Return details about how to find it
+	    -> FCode (CgIdInfo, CmmAGraph)
+               -- Return details about how to find it and initialization code
 
 {- We used to pass a boolean indicating whether all the
 args were of size zero, so we could use a static
@@ -121,7 +123,8 @@ premature looking at the args will cause the compiler to black-hole!
 
 buildDynCon binder _cc con []
   = return (litIdInfo binder (mkConLFInfo con)
-		(CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))))
+		(CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
+            mkNop)
 
 -------- buildDynCon: Charlike and Intlike constructors -----------
 {- The following three paragraphs about @Char@-like and @Int@-like
@@ -150,12 +153,12 @@ buildDynCon binder _cc con [arg]
   , StgLitArg (MachInt val) <- arg
   , val <= fromIntegral mAX_INTLIKE 	-- Comparisons at type Integer!
   , val >= fromIntegral mIN_INTLIKE	-- ...ditto...
-  = do 	{ let intlike_lbl   = mkRtsGcPtrLabel (sLit "stg_INTLIKE_closure")
+  = do 	{ let intlike_lbl   = mkRtsGcPtrLabel (fsLit "stg_INTLIKE_closure")
 	      val_int = fromIntegral val :: Int
 	      offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
 		-- INTLIKE closures consist of a header and one word payload
 	      intlike_amode = cmmLabelOffW intlike_lbl offsetW
-	; return (litIdInfo binder (mkConLFInfo con) intlike_amode) }
+	; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
 
 buildDynCon binder _cc con [arg]
   | maybeCharLikeCon con 
@@ -163,18 +166,18 @@ buildDynCon binder _cc con [arg]
   , let val_int = ord val :: Int
   , val_int <= mAX_CHARLIKE
   , val_int >= mIN_CHARLIKE
-  = do 	{ let charlike_lbl   = mkRtsGcPtrLabel (sLit "stg_CHARLIKE_closure")
+  = do 	{ let charlike_lbl   = mkRtsGcPtrLabel (fsLit "stg_CHARLIKE_closure")
 	      offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
 		-- CHARLIKE closures consist of a header and one word payload
 	      charlike_amode = cmmLabelOffW charlike_lbl offsetW
-	; return (litIdInfo binder (mkConLFInfo con) charlike_amode) }
+	; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
 
 -------- buildDynCon: the general case -----------
 buildDynCon binder ccs con args
   = do	{ let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
 		-- No void args in args_w_offsets
-	; tmp <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
- 	; return (regIdInfo binder lf_info tmp) }
+	; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
+ 	; return (regIdInfo binder lf_info tmp, init) }
   where
     lf_info = mkConLFInfo con
 
@@ -204,7 +207,7 @@ bindConArgs (DataAlt con) base args
 
           -- The binding below forces the masking out of the tag bits
           -- when accessing the constructor field.
-    bind_arg :: (Id, VirtualHpOffset) -> FCode LocalReg
+    bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
     bind_arg (arg, offset) 
 	= do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
 	     ; bindArgToReg arg }