diff options
| -rw-r--r-- | compiler/cmm/Cmm.hs | 22 | ||||
| -rw-r--r-- | compiler/cmm/CmmCPS.hs | 78 | ||||
| -rw-r--r-- | compiler/cmm/CmmCPSGen.hs | 97 | ||||
| -rw-r--r-- | compiler/cmm/CmmInfo.hs | 25 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 60 | ||||
| -rw-r--r-- | compiler/cmm/PprCmm.hs | 35 | ||||
| -rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 12 | ||||
| -rw-r--r-- | compiler/codeGen/CgMonad.lhs | 2 |
8 files changed, 204 insertions, 127 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 1f7161bae6..8fef4009c6 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -9,7 +9,8 @@ module Cmm ( GenCmm(..), Cmm, RawCmm, GenCmmTop(..), CmmTop, RawCmmTop, - CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, + CmmInfo(..), UpdateFrame(..), + CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals, CmmSafety(..), @@ -110,15 +111,19 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) -- Info Tables ----------------------------------------------------------------------------- --- Info table as a haskell data type data CmmInfo = CmmInfo - ProfilingInfo (Maybe BlockId) -- GC target + (Maybe UpdateFrame) -- Update frame + CmmInfoTable -- Info table + +-- Info table as a haskell data type +data CmmInfoTable + = CmmInfoTable + ProfilingInfo ClosureTypeTag -- Int ClosureTypeInfo - | CmmNonInfo -- Procedure doesn't need an info table - (Maybe BlockId) -- But we still need a GC target for it + | CmmNonInfoTable -- Procedure doesn't need an info table -- TODO: The GC target shouldn't really be part of CmmInfo -- as it doesn't appear in the resulting info table. @@ -146,6 +151,13 @@ type SlowEntry = CmmLit -- for now the parser sets this to zero on an INFO_TABLE_FUN. type SelectorOffset = StgWord +-- | A frame that is to be pushed before entry to the function. +-- Used to handle 'update' frames. +data UpdateFrame = + UpdateFrame + CmmExpr -- Frame header. Behaves like the target of a 'jump'. + [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'. + ----------------------------------------------------------------------------- -- CmmStmt -- A "statement". Note that all branches are explicit: there are no diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index cb36de48d9..feabb7f1fc 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -87,23 +87,19 @@ make_gc_check stack_use gc_block = force_gc_block old_info stack_use block_id fun_label formals = case old_info of - CmmNonInfo (Just existing) -> (old_info, [], make_gc_check stack_use existing) - CmmInfo _ (Just existing) _ _ -> (old_info, [], make_gc_check stack_use existing) - CmmNonInfo Nothing - -> (CmmNonInfo (Just block_id), - [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)], + CmmInfo (Just existing) _ _ + -> (old_info, [], make_gc_check stack_use existing) + CmmInfo Nothing update_frame info_table + -> (CmmInfo (Just block_id) update_frame info_table, + [make_gc_block block_id fun_label formals (CmmSafe $ cmmInfoTableSRT info_table)], make_gc_check stack_use block_id) - CmmInfo prof Nothing type_tag type_info - -> (CmmInfo prof (Just block_id) type_tag type_info, - [make_gc_block block_id fun_label formals (CmmSafe srt)], - make_gc_check stack_use block_id) - where - srt = case type_info of - ConstrInfo _ _ _ -> NoC_SRT - FunInfo _ srt' _ _ _ _ -> srt' - ThunkInfo _ srt' -> srt' - ThunkSelectorInfo _ srt' -> srt' - ContInfo _ srt' -> srt' + +cmmInfoTableSRT CmmNonInfoTable = NoC_SRT +cmmInfoTableSRT (CmmInfoTable _ _ (ConstrInfo _ _ _)) = NoC_SRT +cmmInfoTableSRT (CmmInfoTable _ _ (FunInfo _ srt _ _ _ _)) = srt +cmmInfoTableSRT (CmmInfoTable _ _ (ThunkInfo _ srt)) = srt +cmmInfoTableSRT (CmmInfoTable _ _ (ThunkSelectorInfo _ srt)) = srt +cmmInfoTableSRT (CmmInfoTable _ _ (ContInfo _ srt)) = srt ----------------------------------------------------------------------------- -- |CPS a single CmmTop (proceedure) @@ -127,7 +123,7 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply uniques :: [[Unique]] uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1 - (gc_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques + (gc_unique:gc_block_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques proc_uniques = map (map uniqsFromSupply . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2 stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr) @@ -136,16 +132,17 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt]) forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params (forced_info, gc_blocks, check_stmts) = forced_gc + gc_block_id = BlockId gc_block_unique - forced_blocks = - case blocks of - (BasicBlock id stmts) : bs -> - (BasicBlock id (check_stmts ++ stmts)) : (bs ++ gc_blocks) - [] -> [] -- If there is no code then we don't need a stack check + forced_blocks = + BasicBlock gc_block_id + (check_stmts++[CmmBranch $ blockId $ head blocks]) : + blocks ++ gc_blocks forced_gc_id = case forced_info of - CmmNonInfo (Just x) -> x - CmmInfo _ (Just x) _ _ -> x + CmmInfo (Just x) _ _ -> x + + update_frame = case info of CmmInfo _ u _ -> u -- Break the block at each function call. -- The part after the function call will have to become a continuation. @@ -199,13 +196,13 @@ cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs -- Do a little meta-processing on the stack formats such as -- getting the individual frame sizes and the maximum frame size - formats' :: (WordOff, [(CLabel, ContinuationFormat)]) - formats' = processFormats formats continuations + formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) + formats'@(_, _, format_list) = processFormats formats update_frame continuations -- Update the info table data on the continuations with -- the selected stack formats. continuations' :: [Continuation CmmInfo] - continuations' = map (applyContinuationFormat (snd formats')) continuations + continuations' = map (applyContinuationFormat format_list) continuations -- Do the actual CPS transform. cps_procs :: [CmmTop] @@ -257,7 +254,7 @@ gatherBlocksIntoContinuation live proc_points blocks start = info_table = case start_block_entry of FunctionEntry info _ _ -> Right info ContinuationEntry _ srt _ -> Left srt - ControlEntry -> Right (CmmNonInfo Nothing) + ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable) is_gc_cont = case start_block_entry of FunctionEntry _ _ _ -> False @@ -287,7 +284,7 @@ selectContinuationFormat live continuations = where -- User written continuations selectContinuationFormat' (Continuation - (Right (CmmInfo _ _ _ (ContInfo format srt))) + (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt)))) label formals _ _) = (formals, Just label, format) -- Either user written non-continuation code @@ -306,9 +303,11 @@ selectContinuationFormat live continuations = unknown_block = panic "unknown BlockId in selectContinuationFormat" processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))] + -> Maybe UpdateFrame -> [Continuation (Either C_SRT CmmInfo)] - -> (WordOff, [(CLabel, ContinuationFormat)]) -processFormats formats continuations = (max_size, formats') + -> (WordOff, WordOff, [(CLabel, ContinuationFormat)]) +processFormats formats update_frame continuations = + (max_size + update_frame_size, update_frame_size, formats') where max_size = maximum $ 0 : map (continuationMaxStack formats') continuations @@ -324,6 +323,17 @@ processFormats formats continuations = (max_size, formats') else 0, continuation_stack = stack }) + update_frame_size = case update_frame of + Nothing -> 0 + (Just (UpdateFrame _ args)) + -> label_size + update_size args + + update_size [] = 0 + update_size (expr:exprs) = width + update_size exprs + where + width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE + -- TODO: it would be better if we had a machRepWordWidth + -- TODO: get rid of "+ 1" etc. label_size = 1 :: WordOff @@ -381,9 +391,9 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)] -- User written continuations applyContinuationFormat formats (Continuation - (Right (CmmInfo prof gc tag (ContInfo _ srt))) + (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt)))) label formals is_gc blocks) = - Continuation (CmmInfo prof gc tag (ContInfo format srt)) + Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt))) label formals is_gc blocks where format = continuation_stack $ maybe unknown_block id $ lookup label formats @@ -397,7 +407,7 @@ applyContinuationFormat formats (Continuation -- CPS generated continuations applyContinuationFormat formats (Continuation (Left srt) label formals is_gc blocks) = - Continuation (CmmInfo prof gc tag (ContInfo (continuation_stack $ format) srt)) + Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt))) label formals is_gc blocks where gc = Nothing -- Generated continuations never need a stack check diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index b2c4305274..49ac9ab73e 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -78,12 +78,12 @@ data ContinuationFormat -- A block can be an entry to a function ----------------------------------------------------------------------------- -continuationToProc :: (WordOff, [(CLabel, ContinuationFormat)]) +continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) -> CmmReg -> [[Unique]] -> Continuation CmmInfo -> CmmTop -continuationToProc (max_stack, formats) stack_use uniques +continuationToProc (max_stack, update_frame_size, formats) stack_use uniques (Continuation info label formals _ blocks) = CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False)) where @@ -98,14 +98,18 @@ continuationToProc (max_stack, formats) stack_use uniques gc_stmts :: [CmmStmt] gc_stmts = case info of - CmmInfo _ (Just gc_block) _ _ -> + CmmInfo (Just gc_block) _ _ -> gc_stack_check' stack_use arg_stack (max_stack - curr_stack) - CmmInfo _ Nothing _ _ -> + CmmInfo Nothing _ _ -> panic "continuationToProc: missing GC block" - CmmNonInfo (Just gc_block) -> - gc_stack_check' stack_use arg_stack (max_stack - curr_stack) - CmmNonInfo Nothing -> - panic "continuationToProc: missing non-info GC block" + + update_stmts :: [CmmStmt] + update_stmts = + case info of + CmmInfo _ (Just (UpdateFrame target args)) _ -> + pack_frame curr_stack update_frame_size (Just target) (map Just args) ++ + adjust_sp_reg (curr_stack - update_frame_size) + CmmInfo _ Nothing _ -> [] -- At present neither the Cmm parser nor the code generator -- produce code that will allow the target of a CmmCondBranch @@ -148,7 +152,18 @@ continuationToProc (max_stack, formats) stack_use uniques block_for_branch' unique (Just next) = (Just new_next, new_blocks) where (new_next, new_blocks) = block_for_branch unique next - main_block = BasicBlock ident (stmts ++ postfix_stmts) + main_block = + case entry of + FunctionEntry _ _ _ -> + -- Ugh, the statements for an update frame must come + -- *after* the GC check that was added at the beginning + -- of the CPS pass. So we have do edit the statements + -- a bit. This depends on the knowledge that the + -- statements in the first block are only the GC check. + -- That's fragile but it works for now. + BasicBlock ident (stmts ++ update_stmts ++ postfix_stmts) + ControlEntry -> BasicBlock ident (stmts ++ postfix_stmts) + ContinuationEntry _ _ _ -> BasicBlock ident (stmts ++ postfix_stmts) prefix_id = BlockId prefix_unique gc_prefix = case entry of FunctionEntry _ _ _ -> gc_stmts @@ -336,20 +351,21 @@ currentNursery = CmmGlobal CurrentNursery tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt] tail_call spRel target arguments - = store_arguments ++ adjust_spReg ++ jump where + = store_arguments ++ adjust_sp_reg spRel ++ jump where store_arguments = [stack_put spRel expr offset | ((expr, _), StackParam offset) <- argument_formats] ++ [global_put expr global | ((expr, _), RegisterParam global) <- argument_formats] - adjust_spReg = - if spRel == 0 - then [] - else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] jump = [CmmJump target arguments] argument_formats = assignArguments (cmmExprRep . fst) arguments +adjust_sp_reg spRel = + if spRel == 0 + then [] + else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] + gc_stack_check' stack_use arg_stack max_frame_size = if max_frame_size > arg_stack then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))] @@ -367,10 +383,6 @@ gc_stack_check gc_block max_frame_size gc_block] --- TODO: fix branches to proc point --- (we have to insert a new block to marshel the continuation) - - pack_continuation :: Bool -- ^ Whether to set the top/header -- of the stack. We only need to -- set it if we are calling down @@ -382,35 +394,52 @@ pack_continuation :: Bool -- ^ Whether to set the top/header pack_continuation allow_header_set (ContinuationFormat _ curr_id curr_frame_size _) (ContinuationFormat _ cont_id cont_frame_size live_regs) - = store_live_values ++ set_stack_header where + = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args + where + continuation_function = CmmLit $ CmmLabel $ fromJust cont_id + continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal)) + live_regs + needs_header_set = + case (curr_id, cont_id) of + (Just x, Just y) -> x /= y + _ -> isJust cont_id + + maybe_header = if allow_header_set && needs_header_set + then Just continuation_function + else Nothing + +pack_frame :: WordOff -- ^ Current frame size + -> WordOff -- ^ Next frame size + -> Maybe CmmExpr -- ^ Next frame header if any + -> [Maybe CmmExpr] -- ^ Next frame data + -> [CmmStmt] +pack_frame curr_frame_size next_frame_size next_frame_header frame_args = + store_live_values ++ set_stack_header + where -- TODO: only save variables when actually needed -- (may be handled by latter pass) store_live_values = - [stack_put spRel (CmmReg (CmmLocal reg)) offset - | (reg, offset) <- cont_offsets] + [stack_put spRel expr offset + | (expr, offset) <- cont_offsets] set_stack_header = - if needs_header_set && allow_header_set - then [stack_put spRel continuation_function 0] - else [] + case next_frame_header of + Nothing -> [] + Just expr -> [stack_put spRel expr 0] -- TODO: factor with function_entry and CmmInfo.hs(?) - cont_offsets = mkOffsets label_size live_regs + cont_offsets = mkOffsets label_size frame_args label_size = 1 :: WordOff mkOffsets size [] = [] - mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs - mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs + mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs + mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs where - width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE + width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE -- TODO: it would be better if we had a machRepWordWidth - spRel = curr_frame_size - cont_frame_size - continuation_function = CmmLit $ CmmLabel $ fromJust cont_id - needs_header_set = - case (curr_id, cont_id) of - (Just x, Just y) -> x /= y - _ -> isJust cont_id + spRel = curr_frame_size - next_frame_size + -- Lazy adjustment of stack headers assumes all blocks -- that could branch to eachother (i.e. control blocks) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 3f458b5351..78ff5af0ca 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -71,15 +71,15 @@ cmmToRawCmm cmm = do mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat] -mkInfoTable uniq (CmmProc info entry_label arguments blocks) = +mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = case info of -- | Code without an info table. Easy. - CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks] + CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] -- | A function entry point. - CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag - (FunInfo (ptrs, nptrs) srt fun_type fun_arity - pap_bitmap slow_entry) -> + CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag + (FunInfo (ptrs, nptrs) srt fun_type fun_arity + pap_bitmap slow_entry) -> mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks where @@ -97,8 +97,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) = layout = packHalfWordsCLit ptrs nptrs -- | A constructor. - CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag - (ConstrInfo (ptrs, nptrs) con_tag descr) -> + CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag + (ConstrInfo (ptrs, nptrs) con_tag descr) -> mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks where @@ -108,8 +108,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) = layout = packHalfWordsCLit ptrs nptrs -- | A thunk. - CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag - (ThunkInfo (ptrs, nptrs) srt) -> + CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag + (ThunkInfo (ptrs, nptrs) srt) -> mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks where @@ -119,8 +119,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) = layout = packHalfWordsCLit ptrs nptrs -- | A selector thunk. - CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag - (ThunkSelectorInfo offset srt) -> + CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag + (ThunkSelectorInfo offset srt) -> mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label arguments blocks where @@ -128,7 +128,8 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) = info_label = entryLblToInfoLbl entry_label -- A continuation/return-point. - CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) -> + CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag + (ContInfo stack_layout srt) -> liveness_data ++ mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 27fce3bf88..32512fe047 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -200,47 +200,49 @@ lits :: { [ExtFCode CmmExpr] } cmmproc :: { ExtCode } -- TODO: add real SRT/info tables to parsed Cmm - : info maybe_formals '{' body '}' - { do ((info_lbl, info, live, formals), stmts) <- + : info maybe_formals maybe_frame '{' body '}' + { do ((info_lbl, info, live, formals, frame), stmts) <- getCgStmtsEC' $ loopDecls $ do { (info_lbl, info, live) <- $1; formals <- sequence $2; - $4; - return (info_lbl, info, live, formals) } + frame <- $3; + $5; + return (info_lbl, info, live, formals, frame) } blks <- code (cgStmtsToBlocks stmts) - code (emitInfoTableAndCode info_lbl info formals blks) } + code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) } | info maybe_formals ';' { do (info_lbl, info, live) <- $1; formals <- sequence $2; - code (emitInfoTableAndCode info_lbl info formals []) } + code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) } - | NAME maybe_formals '{' body '}' - { do (formals, stmts) <- + | NAME maybe_formals maybe_frame '{' body '}' + { do ((formals, frame), stmts) <- getCgStmtsEC' $ loopDecls $ do { formals <- sequence $2; - $4; - return formals } + frame <- $3; + $5; + return (formals, frame) } blks <- code (cgStmtsToBlocks stmts) - code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) } + code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) } -info :: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) } +info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type { do prof <- profilingInfo $11 $13 return (mkRtsInfoLabelFS $3, - CmmInfo prof Nothing (fromIntegral $9) - (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), + CmmInfoTable prof (fromIntegral $9) + (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type { do prof <- profilingInfo $11 $13 return (mkRtsInfoLabelFS $3, - CmmInfo prof Nothing (fromIntegral $9) - (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 - (ArgSpec 0) - zeroCLit), + CmmInfoTable prof (fromIntegral $9) + (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 + (ArgSpec 0) + zeroCLit), []) } -- we leave most of the fields zero here. This is only used -- to generate the BCO info table in the RTS at the moment. @@ -252,31 +254,31 @@ info :: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) } -- but that's the way the old code did it we can fix it some other time. desc_lit <- code $ mkStringCLit $13 return (mkRtsInfoLabelFS $3, - CmmInfo prof Nothing (fromIntegral $11) - (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), + CmmInfoTable prof (fromIntegral $11) + (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type { do prof <- profilingInfo $9 $11 return (mkRtsInfoLabelFS $3, - CmmInfo prof Nothing (fromIntegral $7) - (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), + CmmInfoTable prof (fromIntegral $7) + (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ')' -- closure type (no live regs) { return (mkRtsInfoLabelFS $3, - CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5) - (ContInfo [] NoC_SRT), + CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + (ContInfo [] NoC_SRT), []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' -- closure type, live regs { do live <- sequence (map (liftM Just) $7) return (mkRtsInfoLabelFS $3, - CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5) - (ContInfo live NoC_SRT), + CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + (ContInfo live NoC_SRT), live) } body :: { ExtCode } @@ -503,6 +505,12 @@ formal :: { ExtFCode LocalReg } | STRING type NAME {% do k <- parseKind $1; return $ newLocal k $2 $3 } +maybe_frame :: { ExtFCode (Maybe UpdateFrame) } + : {- empty -} { return Nothing } + | 'jump' expr '(' exprs0 ')' { do { target <- $2; + args <- sequence $4; + return $ Just (UpdateFrame target args) } } + type :: { MachRep } : 'bits8' { I8 } | typenot8 { $1 } diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 866a1c92c5..602f51ce4d 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -129,17 +129,19 @@ instance Outputable CmmSafety where -- For ideas on how to refine it, they used to be printed in the -- style of C--'s 'stackdata' declaration, just inside the proc body, -- and were labelled with the procedure name ++ "_info". -pprInfo (CmmNonInfo gc_target) = - ptext SLIT("gc_target: ") <> - ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target - -- ^ gc_target is currently unused and wired to a panic -pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc) - gc_target tag info) = - vcat [ptext SLIT("type: ") <> pprLit closure_type, +pprInfo (CmmInfo gc_target update_frame CmmNonInfoTable) = + vcat [ptext SLIT("gc_target: ") <> + maybe (ptext SLIT("<none>")) pprBlockId gc_target, + ptext SLIT("update_frame: ") <> + maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame] +pprInfo (CmmInfo gc_target update_frame + (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) = + vcat [ptext SLIT("gc_target: ") <> + maybe (ptext SLIT("<none>")) pprBlockId gc_target, + ptext SLIT("update_frame: ") <> + maybe (ptext SLIT("<none>")) pprUpdateFrame update_frame, + ptext SLIT("type: ") <> pprLit closure_type, ptext SLIT("desc: ") <> pprLit closure_desc, - ptext SLIT("gc_target: ") <> - ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target, - -- ^ gc_target is currently unused and wired to a panic ptext SLIT("tag: ") <> integer (toInteger tag), pprTypeInfo info] @@ -168,6 +170,19 @@ pprTypeInfo (ContInfo stack srt) = vcat [ptext SLIT("stack: ") <> ppr stack, ptext SLIT("srt: ") <> ppr srt] +pprUpdateFrame :: UpdateFrame -> SDoc +pprUpdateFrame (UpdateFrame expr args) = + hcat [ ptext SLIT("jump") + , space + , if isTrivialCmmExpr expr + then pprExpr expr + else case expr of + CmmLoad (CmmReg _) _ -> pprExpr expr + _ -> parens (pprExpr expr) + , space + , parens ( commafy $ map ppr args ) ] + + -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 6d270aef16..f6277f1a71 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -89,12 +89,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo prof gc_target cl_type info + return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo prof gc_target cl_type info + return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info) where info = case lf_info of @@ -145,10 +145,12 @@ emitReturnTarget name stmts ; blks <- cgStmtsToBlocks stmts ; frame <- mkStackLayout ; let info = CmmInfo - (ProfilingInfo zeroCLit zeroCLit) gc_target - rET_SMALL -- cmmToRawCmm may convert it to rET_BIG - (ContInfo frame srt_info) + Nothing + (CmmInfoTable + (ProfilingInfo zeroCLit zeroCLit) + rET_SMALL -- cmmToRawCmm may convert it to rET_BIG + (ContInfo frame srt_info)) ; emitInfoTableAndCode info_lbl info args blks ; return info_lbl } where diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index d40c511327..688591292c 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code emitSimpleProc lbl code = do { stmts <- getCgStmts code ; blks <- cgStmtsToBlocks stmts - ; emitProc (CmmNonInfo Nothing) lbl [] blks } + ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks } getCmm :: Code -> FCode Cmm -- Get all the CmmTops (there should be no stmts) |