From b44b0befe2b60cc9c4e4f8313bbb8b6207ad047c Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Thu, 5 Jul 2007 14:48:20 +0000 Subject: [PATCH] Added support for GC block declaration to the Cmm syntax --- compiler/cmm/Cmm.hs | 2 +- compiler/cmm/CmmCPS.hs | 81 +++++++++++++++++---------------------------- compiler/cmm/CmmCPSGen.hs | 27 +++++---------- compiler/cmm/CmmParse.y | 25 +++++++++----- compiler/cmm/PprCmm.hs | 2 +- 5 files changed, 57 insertions(+), 80 deletions(-) diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 8fef400..27bf8d6 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -113,7 +113,7 @@ mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) data CmmInfo = CmmInfo - (Maybe BlockId) -- GC target + (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check (Maybe UpdateFrame) -- Update frame CmmInfoTable -- Info table diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index feabb7f..53f54bf 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -15,7 +15,6 @@ import CmmBrokenBlock import CmmProcPoint import CmmCallConv import CmmCPSGen -import CmmInfo import CmmUtils import ClosureInfo @@ -69,37 +68,23 @@ cmmCPS dflags abstractC = do return continuationC -stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc" -make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts +make_stack_check stack_check_block_id info stack_use next_block_id = + BasicBlock stack_check_block_id $ + check_stmts ++ [CmmBranch next_block_id] where - stmts = [CmmCall stg_gc_gen_target [] [] safety, - CmmJump fun_expr actuals] - stg_gc_gen_target = - CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv - actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals - fun_expr = CmmLit (CmmLabel fun_label) - -make_gc_check stack_use gc_block = - [CmmCondBranch - (CmmMachOp (MO_U_Lt $ cmmRegRep spReg) - [CmmReg stack_use, CmmReg spLimReg]) - gc_block] - -force_gc_block old_info stack_use block_id fun_label formals = - case old_info of - 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) - -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 + check_stmts = + case info of + -- If we are given a stack check handler, + -- then great, well check the stack. + CmmInfo (Just gc_block) _ _ + -> [CmmCondBranch + (CmmMachOp (MO_U_Lt $ cmmRegRep spReg) + [CmmReg stack_use, CmmReg spLimReg]) + gc_block] + -- If we aren't given a stack check handler, + -- then humph! we just won't check the stack for them. + CmmInfo Nothing _ _ + -> [] ----------------------------------------------------------------------------- -- |CPS a single CmmTop (proceedure) @@ -120,39 +105,35 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc] -- CPS transform for those procs that actually need it cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs where + -- We need to be generating uniques for several things. + -- We could make this function monadic to handle that + -- but since there is no other reason to make it monadic, + -- we instead will just split them all up right here. (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply uniques :: [[Unique]] uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1 - (gc_unique:gc_block_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques + (stack_check_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) + stack_check_block_id = BlockId stack_check_block_unique + stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks) - -- TODO: doc - 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 = stack_check_block : blocks - forced_blocks = - BasicBlock gc_block_id - (check_stmts++[CmmBranch $ blockId $ head blocks]) : - blocks ++ gc_blocks - - forced_gc_id = case forced_info of - CmmInfo (Just x) _ _ -> x - - update_frame = case info of CmmInfo _ u _ -> u + CmmInfo maybe_gc_block_id update_frame _ = info -- Break the block at each function call. -- The part after the function call will have to become a continuation. broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock]) broken_blocks = (\x -> (concatMap fst x, concatMap snd x)) $ - zipWith3 (breakBlock [forced_gc_id]) + zipWith3 (breakBlock (maybeToList maybe_gc_block_id)) block_uniques forced_blocks - (FunctionEntry forced_info ident params : + (FunctionEntry info ident params : repeat ControlEntry) f' = selectContinuations (fst broken_blocks) @@ -243,9 +224,9 @@ gatherBlocksIntoContinuation live proc_points blocks start = Continuation info_table clabel params is_gc_cont body where children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start) - start_block = lookupWithDefaultUFM blocks (panic "TODO") start + start_block = lookupWithDefaultUFM blocks unknown_block start + children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children) unknown_block = panic "unknown block in gatherBlocksIntoContinuation" - children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children) body = start_block : children_blocks -- We can't properly annotate the continuation's stack parameters diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index 49ac9ab..4b8f83b 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -97,11 +97,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques gc_stmts :: [CmmStmt] gc_stmts = - case info of - CmmInfo (Just gc_block) _ _ -> - gc_stack_check' stack_use arg_stack (max_stack - curr_stack) - CmmInfo Nothing _ _ -> - panic "continuationToProc: missing GC block" + assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack) update_stmts :: [CmmStmt] update_stmts = @@ -124,10 +120,11 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques prefix_blocks ++ [main_block] where prefix_blocks = - case gc_prefix ++ param_prefix of - [] -> [] - entry_stmts -> [BasicBlock prefix_id - (entry_stmts ++ [CmmBranch ident])] + if is_entry + then [BasicBlock + (BlockId prefix_unique) + (param_stmts ++ [CmmBranch ident])] + else [] prefix_unique : call_uniques = uniques toCLabel = mkReturnPtLabel . getUnique @@ -161,17 +158,9 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques -- 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) + BasicBlock ident (gc_stmts ++ 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 - ControlEntry -> [] - ContinuationEntry _ _ _ -> [] - param_prefix = if is_entry - then param_stmts - else [] postfix_stmts = case exit of FinalBranch next -> if (mkReturnPtLabel $ getUnique next) == label @@ -366,7 +355,7 @@ adjust_sp_reg spRel = then [] else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] -gc_stack_check' stack_use arg_stack max_frame_size = +assign_gc_stack_use stack_use arg_stack max_frame_size = if max_frame_size > arg_stack then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))] else [CmmAssign stack_use (CmmReg spLimReg)] diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 32512fe..da80702 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -200,14 +200,15 @@ lits :: { [ExtFCode CmmExpr] } cmmproc :: { ExtCode } -- TODO: add real SRT/info tables to parsed Cmm - : info maybe_formals maybe_frame '{' body '}' - { do ((info_lbl, info, live, formals, frame), stmts) <- + : info maybe_formals maybe_frame maybe_gc_block '{' body '}' + { do ((info_lbl, info, live, formals, frame, gc_block), stmts) <- getCgStmtsEC' $ loopDecls $ do { (info_lbl, info, live) <- $1; formals <- sequence $2; frame <- $3; - $5; - return (info_lbl, info, live, formals, frame) } + gc_block <- $4; + $6; + return (info_lbl, info, live, formals, frame, gc_block) } blks <- code (cgStmtsToBlocks stmts) code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) } @@ -216,15 +217,16 @@ cmmproc :: { ExtCode } formals <- sequence $2; code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) } - | NAME maybe_formals maybe_frame '{' body '}' - { do ((formals, frame), stmts) <- + | NAME maybe_formals maybe_frame maybe_gc_block '{' body '}' + { do ((formals, frame, gc_block), stmts) <- getCgStmtsEC' $ loopDecls $ do { formals <- sequence $2; frame <- $3; - $5; - return (formals, frame) } + gc_block <- $4; + $6; + return (formals, frame, gc_block) } blks <- code (cgStmtsToBlocks stmts) - code (emitProc (CmmInfo Nothing frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) } + code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) } info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' @@ -511,6 +513,11 @@ maybe_frame :: { ExtFCode (Maybe UpdateFrame) } args <- sequence $4; return $ Just (UpdateFrame target args) } } +maybe_gc_block :: { ExtFCode (Maybe BlockId) } + : {- empty -} { return Nothing } + | 'goto' NAME + { do l <- lookupLabel $2; return (Just l) } + type :: { MachRep } : 'bits8' { I8 } | typenot8 { $1 } diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 602f51c..5ce008d 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -156,7 +156,7 @@ pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) = ptext SLIT("srt: ") <> ppr srt, ptext SLIT("fun_type: ") <> integer (toInteger fun_type), ptext SLIT("arity: ") <> integer (toInteger arity), - --ppr args, -- TODO: needs to be printed + --ptext SLIT("args: ") <> ppr args, -- TODO: needs to be printed ptext SLIT("slow: ") <> pprLit slow_entry ] pprTypeInfo (ThunkInfo layout srt) = -- 1.7.10.4