import Cmm
import CLabel
+import MkZipCfgCmm (CmmAGraph, mkNop)
import SMRep
import CostCentre
+import Module
import Constants
import DataCon
import FastString
import PrelInfo
import Outputable
import Util ( lengthIs )
-import Char ( ord )
+
+import Data.Char
+
+#if defined(mingw32_TARGET_OS)
+import StaticFlags ( opt_PIC )
+#endif
---------------------------------------------------------------
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
= 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
; emitDataLits closure_label closure_rep
-- RETURN
- ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) }
+ ; return $ litIdInfo id lf_info (CmmLabel closure_label) }
---------------------------------------------------------------
-- 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
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
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
-- 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 }