diff options
Diffstat (limited to 'compiler/codeGen/StgCmmCon.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 71 |
1 files changed, 41 insertions, 30 deletions
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 23226bb45e..083e615b78 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -54,10 +54,18 @@ import Data.Char cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> FCode CgIdInfo + -> FCode (CgIdInfo, FCode ()) cgTopRhsCon id con args - = do { - dflags <- getDynFlags + = return ( id_info, gen_code ) + where + name = idName id + caffy = idCafInfo id -- any stgArgHasCafRefs args + closure_label = mkClosureLabel name caffy + + id_info = litIdInfo id (mkConLFInfo con) (CmmLabel closure_label) + + gen_code = + do { dflags <- getDynFlags ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () @@ -65,10 +73,6 @@ cgTopRhsCon id con args -- LAY IT OUT ; let - name = idName id - caffy = idCafInfo id -- any stgArgHasCafRefs args - closure_label = mkClosureLabel name caffy - (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args) @@ -97,8 +101,7 @@ cgTopRhsCon id con args -- BUILD THE OBJECT ; emitDataLits closure_label closure_rep - -- RETURN - ; return $ litIdInfo id (mkConLFInfo con) (CmmLabel closure_label) } + ; return () } --------------------------------------------------------------- @@ -111,7 +114,7 @@ buildDynCon :: Id -- Name of the thing to which this constr will -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [StgArg] -- Its args - -> FCode (CgIdInfo, CmmAGraph) + -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code buildDynCon binder cc con args = do dflags <- getDynFlags @@ -123,7 +126,7 @@ buildDynCon' :: DynFlags -> CostCentreStack -> DataCon -> [StgArg] - -> FCode (CgIdInfo, CmmAGraph) + -> FCode (CgIdInfo, FCode CmmAGraph) {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static @@ -149,7 +152,7 @@ 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))), - mkNop) + return mkNop) -------- buildDynCon': Charlike and Intlike constructors ----------- {- The following three paragraphs about @Char@-like and @Int@-like @@ -188,7 +191,8 @@ buildDynCon' dflags platform binder _cc con [arg] offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = cmmLabelOffW intlike_lbl offsetW - ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) } + ; return ( litIdInfo binder (mkConLFInfo con) intlike_amode + , return mkNop) } buildDynCon' dflags platform binder _cc con [arg] | maybeCharLikeCon con @@ -201,26 +205,33 @@ buildDynCon' dflags platform binder _cc con [arg] offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW charlike_lbl offsetW - ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) } + ; return ( litIdInfo binder (mkConLFInfo con) charlike_amode + , return mkNop) } -------- buildDynCon': the general case ----------- buildDynCon' dflags _ binder ccs con args - = do { let (tot_wds, ptr_wds, args_w_offsets) - = mkVirtConstrOffsets dflags (addArgReps args) - -- No void args in args_w_offsets - nonptr_wds = tot_wds - ptr_wds - info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds - ; hp_plus_n <- allocDynClosure info_tbl lf_info - use_cc blame_cc args_w_offsets - ; regIdInfo binder lf_info hp_plus_n } - where - lf_info = mkConLFInfo con - - use_cc -- cost-centre to stick in the object - | isCurrentCCS ccs = curCCS - | otherwise = panic "buildDynCon: non-current CCS not implemented" - - blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + = do { (id_info, reg) <- rhsIdInfo binder lf_info + ; return (id_info, gen_code reg) + } + where + lf_info = mkConLFInfo con + + gen_code reg + = do { let (tot_wds, ptr_wds, args_w_offsets) + = mkVirtConstrOffsets dflags (addArgReps args) + -- No void args in args_w_offsets + nonptr_wds = tot_wds - ptr_wds + info_tbl = mkDataConInfoTable dflags con False + ptr_wds nonptr_wds + ; hp_plus_n <- allocDynClosure info_tbl lf_info + use_cc blame_cc args_w_offsets + ; return (mkRhsInit reg lf_info hp_plus_n) } + where + use_cc -- cost-centre to stick in the object + | isCurrentCCS ccs = curCCS + | otherwise = panic "buildDynCon: non-current CCS not implemented" + + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) --------------------------------------------------------------- |