Merge in new code generator branch.

[ghc-hetmet.git] / compiler / codeGen / StgCmmCon.hs

diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index de1d77a..633d577 100644 (file)
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -25,10 +25,12 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmProf
 
-import Cmm
+import CmmExpr
 import CLabel
+import MkGraph
 import SMRep
 import CostCentre
+import Module
 import Constants
 import DataCon
 import FastString
@@ -37,7 +39,12 @@ import Literal
 import PrelInfo
 import Outputable
 import Util             ( lengthIs )
-import Char            ( ord )
+
+import Data.Char
+
+#if defined(mingw32_TARGET_OS)
+import StaticFlags     ( opt_PIC )
+#endif
 
 
 ---------------------------------------------------------------
@@ -47,7 +54,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 +74,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 +90,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 +103,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 +129,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
@@ -143,38 +152,48 @@ work with any old argument, but for @Int@-like ones the argument has
 to be a literal.  Reason: @Char@ like closures have an argument type
 which is guaranteed in range.
 
-Because of this, we use can safely return an addressing mode. -}
+Because of this, we use can safely return an addressing mode. 
+
+We don't support this optimisation when compiling into Windows DLLs yet
+because they don't support cross package data references well.
+-}
 
 buildDynCon binder _cc con [arg]
   | maybeIntLikeCon con 
+#if defined(mingw32_TARGET_OS)
+  , not opt_PIC
+#endif
   , 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   = mkCmmGcPtrLabel rtsPackageId (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 
+  | maybeCharLikeCon con
+#if defined(mingw32_TARGET_OS)
+  , not opt_PIC
+#endif
   , StgLitArg (MachChar val) <- 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   = mkCmmGcPtrLabel rtsPackageId (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 +223,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 }