diff options
Diffstat (limited to 'compiler/codeGen/CgInfoTbls.hs')
| -rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 76 |
1 files changed, 17 insertions, 59 deletions
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index dbd22f3906..92db95eba8 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -9,7 +9,6 @@ module CgInfoTbls ( emitClosureCodeAndInfoTable, emitInfoTableAndCode, - dataConTagZ, emitReturnTarget, emitAlgReturnTarget, emitReturnInstr, stdInfoTableSizeB, @@ -30,12 +29,11 @@ import CgBindery import CgCallConv import CgUtils import CgMonad +import CmmBuildInfoTables -import OldCmmUtils import OldCmm import CLabel import Name -import DataCon import Unique import StaticFlags @@ -59,58 +57,20 @@ emitClosureCodeAndInfoTable cl_info args body ; info <- mkCmmInfo cl_info ; emitInfoTableAndCode (entryLabelFromCI cl_info) info args blks } --- We keep the *zero-indexed* tag in the srt_len field of the info --- table of a data constructor. -dataConTagZ :: DataCon -> ConTagZ -dataConTagZ con = dataConTag con - fIRST_TAG - -- Convert from 'ClosureInfo' to 'CmmInfo'. -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) mkCmmInfo :: ClosureInfo -> FCode CmmInfo -mkCmmInfo cl_info = do - prof <- - if opt_SccProfilingOn - then do ty_descr_lit <- mkStringCLit (closureTypeDescr cl_info) - cl_descr_lit <- mkStringCLit (closureValDescr cl_info) - return $ ProfilingInfo ty_descr_lit cl_descr_lit - else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - - case cl_info of - ConInfo { closureCon = con } -> do - cstr <- mkByteStringCLit $ dataConIdentity con - let conName = makeRelativeRefTo info_lbl cstr - info = ConstrInfo (ptrs, nptrs) - (fromIntegral (dataConTagZ con)) - conName - return $ CmmInfo gc_target Nothing (CmmInfoTable (infoTableLabelFromCI cl_info) False prof cl_type info) - - ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable (infoTableLabelFromCI cl_info) False prof cl_type info) - where - info = - case lf_info of - LFReEntrant _ arity _ arg_descr -> - FunInfo (ptrs, nptrs) - srt - (fromIntegral arity) - arg_descr - (CmmLabel (mkSlowEntryLabel name has_caf_refs)) - LFThunk _ _ _ (SelectorThunk offset) _ -> - ThunkSelectorInfo (fromIntegral offset) srt - LFThunk _ _ _ _ _ -> - ThunkInfo (ptrs, nptrs) srt - _ -> panic "unexpected lambda form in mkCmmInfo" +mkCmmInfo cl_info + = return (CmmInfo gc_target Nothing $ + CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info, + cit_rep = closureSMRep cl_info, + cit_prof = prof, + cit_srt = closureSRT cl_info }) where - info_lbl = infoTableLabelFromCI cl_info - has_caf_refs = clHasCafRefs cl_info - - cl_type = smRepClosureTypeInt (closureSMRep cl_info) - - ptrs = fromIntegral $ closurePtrsSize cl_info - size = fromIntegral $ closureNonHdrSize cl_info - nptrs = size - ptrs + prof | not opt_SccProfilingOn = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8 + ty_descr_w8 = stringToWord8s (closureTypeDescr cl_info) + val_descr_w8 = stringToWord8s (closureValDescr cl_info) -- The gc_target is to inform the CPS pass when it inserts a stack check. -- Since that pass isn't used yet we'll punt for now. @@ -137,13 +97,12 @@ emitReturnTarget name stmts = do { srt_info <- getSRTInfo ; blks <- cgStmtsToBlocks stmts ; frame <- mkStackLayout - ; let info = CmmInfo - gc_target - Nothing - (CmmInfoTable info_lbl False - (ProfilingInfo zeroCLit zeroCLit) - rET_SMALL -- cmmToRawCmm may convert it to rET_BIG - (ContInfo frame srt_info)) + ; let smrep = mkStackRep (mkLiveness frame) + info = CmmInfo gc_target Nothing info_tbl + info_tbl = CmmInfoTable { cit_lbl = info_lbl + , cit_prof = NoProfilingInfo + , cit_rep = smrep + , cit_srt = srt_info } ; emitInfoTableAndCode entry_lbl info args blks ; return info_lbl } where @@ -160,7 +119,6 @@ emitReturnTarget name stmts -- and stack checks (from the CPS pass). gc_target = panic "TODO: gc_target" - -- Build stack layout information from the state of the 'FCode' monad. -- Should go away once 'codeGen' starts using the CPS conversion -- pass to handle the stack. Until then, this is really just |