diff options
| author | Nicolas Frisby <nicolas.frisby@gmail.com> | 2013-05-01 08:45:52 -0500 |
|---|---|---|
| committer | Nicolas Frisby <nicolas.frisby@gmail.com> | 2013-05-02 10:27:50 -0500 |
| commit | 11a85cc7ea50d4b7c12ea2cc3c0ce39734dc4217 (patch) | |
| tree | bf04983c464496e93c4a855c831f6c839c523bbc /compiler/codeGen/StgCmmCon.hs | |
| parent | ade1ae97ed52c493ec415c1601dace39b64071dd (diff) | |
| download | haskell-11a85cc7ea50d4b7c12ea2cc3c0ce39734dc4217.tar.gz | |
extended ticky to also track "let"s that are not conventional closures
This includes selector, ap, and constructor thunks. They are still
guarded by the -ticky-dyn-thk flag.
(This is 024df664b600a with a small bug fix.)
Diffstat (limited to 'compiler/codeGen/StgCmmCon.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 21 |
1 files changed, 13 insertions, 8 deletions
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 3e95c59d12..d2a25ebd6c 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -109,19 +109,21 @@ cgTopRhsCon id con args buildDynCon :: Id -- Name of the thing to which this constr will -- be bound + -> Bool -- is it genuinely bound to that name, or just for profiling? -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [StgArg] -- Its args -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code -buildDynCon binder cc con args +buildDynCon binder actually_bound cc con args = do dflags <- getDynFlags - buildDynCon' dflags (targetPlatform dflags) binder cc con args + buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args + buildDynCon' :: DynFlags -> Platform - -> Id + -> Id -> Bool -> CostCentreStack -> DataCon -> [StgArg] @@ -148,7 +150,7 @@ premature looking at the args will cause the compiler to black-hole! -- which have exclusively size-zero (VoidRep) args, we generate no code -- at all. -buildDynCon' dflags _ binder _cc con [] +buildDynCon' dflags _ binder _ _cc con [] = return (litIdInfo dflags binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), return mkNop) @@ -179,7 +181,7 @@ We don't support this optimisation when compiling into Windows DLLs yet because they don't support cross package data references well. -} -buildDynCon' dflags platform binder _cc con [arg] +buildDynCon' dflags platform binder _ _cc con [arg] | maybeIntLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) , StgLitArg (MachInt val) <- arg @@ -193,7 +195,7 @@ buildDynCon' dflags platform binder _cc con [arg] ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } -buildDynCon' dflags platform binder _cc con [arg] +buildDynCon' dflags platform binder _ _cc con [arg] | maybeCharLikeCon con , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags) , StgLitArg (MachChar val) <- arg @@ -208,7 +210,7 @@ buildDynCon' dflags platform binder _cc con [arg] , return mkNop) } -------- buildDynCon': the general case ----------- -buildDynCon' dflags _ binder ccs con args +buildDynCon' dflags _ binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -222,7 +224,10 @@ buildDynCon' dflags _ binder ccs con args nonptr_wds = tot_wds - ptr_wds info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds - ; hp_plus_n <- allocDynClosure info_tbl lf_info + ; let ticky_name | actually_bound = Just binder + | otherwise = Nothing + + ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info use_cc blame_cc args_w_offsets ; return (mkRhsInit dflags reg lf_info hp_plus_n) } where |