From f96e9aa0444de0e673b3c4055c6e43299639bc5b Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Wed, 27 Jun 2007 15:12:57 +0000 Subject: [PATCH] First pass at implementing info tables for CPS This is a fairly complete implementation, however two 'panic's have been placed in the critical path where the implementation is still a bit lacking so do not expect it to run quite yet. One call to panic is because we still need to create a GC block for procedures that don't have them yet. (cmm/CmmCPS.hs:continuationToProc) The other is due to the need to convert from a ContinuationInfo to a CmmInfo. (codeGen/CgInfoTbls.hs:emitClosureCodeAndInfoTable) (codeGen/CgInfoTbls.hs:emitReturnTarget) --- compiler/cmm/CLabel.hs | 14 +- compiler/cmm/Cmm.hs | 53 ++++++-- compiler/cmm/CmmBrokenBlock.hs | 3 +- compiler/cmm/CmmCPS.hs | 254 +++++++++++++++++++++++++++---------- compiler/cmm/CmmLint.hs | 6 +- compiler/cmm/CmmOpt.hs | 2 +- compiler/cmm/CmmParse.y | 53 ++++---- compiler/cmm/CmmProcPoint.hs | 2 +- compiler/cmm/PprC.hs | 8 +- compiler/cmm/PprCmm.hs | 78 +++++++++--- compiler/codeGen/CgCallConv.hs | 3 +- compiler/codeGen/CgInfoTbls.hs | 23 +++- compiler/codeGen/CgMonad.lhs | 8 +- compiler/codeGen/CgUtils.hs | 18 ++- compiler/codeGen/SMRep.lhs | 6 +- compiler/main/CodeOutput.lhs | 4 +- compiler/main/HscMain.lhs | 4 +- compiler/nativeGen/AsmCodeGen.lhs | 12 +- compiler/nativeGen/MachCodeGen.hs | 2 +- compiler/nativeGen/MachInstrs.hs | 4 +- 20 files changed, 393 insertions(+), 164 deletions(-) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 0918cc8..94ae64a 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -213,6 +213,9 @@ data CLabel | LargeSRTLabel -- Label of an StgLargeSRT {-# UNPACK #-} !Unique + | LargeBitmapLabel -- A bitmap (function or case return) + {-# UNPACK #-} !Unique + deriving (Eq, Ord) data IdLabelInfo @@ -225,8 +228,6 @@ data IdLabelInfo | RednCounts -- Label of place to keep Ticky-ticky info for -- this Id - | Bitmap -- A bitmap (function or case return) - | ConEntry -- constructor entry point | ConInfoTable -- corresponding info table | StaticConEntry -- static constructor entry point @@ -290,7 +291,6 @@ data DynamicLinkerLabelInfo -- These are always local: mkSRTLabel name = IdLabel name SRT mkSlowEntryLabel name = IdLabel name Slow -mkBitmapLabel name = IdLabel name Bitmap mkRednCountsLabel name = IdLabel name RednCounts -- These have local & (possibly) external variants: @@ -335,6 +335,7 @@ mkStaticConEntryLabel this_pkg name | otherwise = IdLabel name StaticConEntry mkLargeSRTLabel uniq = LargeSRTLabel uniq +mkBitmapLabel uniq = LargeBitmapLabel uniq mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo @@ -470,7 +471,7 @@ needsCDecl :: CLabel -> Bool -- they are defined before use. needsCDecl (IdLabel _ SRT) = False needsCDecl (LargeSRTLabel _) = False -needsCDecl (IdLabel _ Bitmap) = False +needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _) = True needsCDecl (DynIdLabel _ _) = True needsCDecl (CaseLabel _ _) = True @@ -550,6 +551,8 @@ labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel labelType (ModuleInitLabel _ _ _) = CodeLabel labelType (PlainModuleInitLabel _ _) = CodeLabel +labelType (LargeSRTLabel _) = DataLabel +labelType (LargeBitmapLabel _) = DataLabel labelType (IdLabel _ info) = idInfoLabelType info labelType (DynIdLabel _ info) = idInfoLabelType info @@ -559,7 +562,6 @@ idInfoLabelType info = case info of InfoTable -> DataLabel Closure -> DataLabel - Bitmap -> DataLabel ConInfoTable -> DataLabel StaticInfoTable -> DataLabel ClosureTable -> DataLabel @@ -700,6 +702,7 @@ pprCLbl (CaseLabel u CaseDefault) = hcat [pprUnique u, ptext SLIT("_dflt")] pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("srtd") +pprCLbl (LargeBitmapLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("btm") pprCLbl (RtsLabel (RtsCode str)) = ptext str pprCLbl (RtsLabel (RtsData str)) = ptext str @@ -799,7 +802,6 @@ ppIdFlavor x = pp_cSEP <> Entry -> ptext SLIT("entry") Slow -> ptext SLIT("slow") RednCounts -> ptext SLIT("ct") - Bitmap -> ptext SLIT("btm") ConEntry -> ptext SLIT("con_entry") ConInfoTable -> ptext SLIT("con_info") StaticConEntry -> ptext SLIT("static_entry") diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 7ec5ad0..f5525a7 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -7,8 +7,9 @@ ----------------------------------------------------------------------------- module Cmm ( - GenCmm(..), Cmm, - GenCmmTop(..), CmmTop, + GenCmm(..), Cmm, RawCmm, + GenCmmTop(..), CmmTop, RawCmmTop, + CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals, CmmCallTarget(..), @@ -16,7 +17,7 @@ module Cmm ( CmmExpr(..), cmmExprRep, CmmReg(..), cmmRegRep, CmmLit(..), cmmLitRep, - LocalReg(..), localRegRep, Kind(..), + LocalReg(..), localRegRep, localRegGCFollow, Kind(..), BlockId(..), BlockEnv, GlobalReg(..), globalRegRep, @@ -28,6 +29,7 @@ module Cmm ( import MachOp import CLabel import ForeignCall +import SMRep import ClosureInfo import Unique import UniqFM @@ -49,15 +51,19 @@ import Data.Word -- (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively, -- (b) Native code, populated with instructions -- -newtype GenCmm d i = Cmm [GenCmmTop d i] +newtype GenCmm d h i = Cmm [GenCmmTop d h i] -type Cmm = GenCmm CmmStatic CmmStmt +-- | Cmm with the info table as a data type +type Cmm = GenCmm CmmStatic CmmInfo CmmStmt + +-- | Cmm with the info tables converted to a list of 'CmmStatic' +type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt -- A top-level chunk, abstracted over the type of the contents of -- the basic blocks (Cmm or instructions are the likely instantiations). -data GenCmmTop d i +data GenCmmTop d h i = CmmProc - [d] -- Info table, may be empty + h -- Extra header such as the info table CLabel -- Used to generate both info & entry labels CmmFormals -- Argument locals live on entry (C-- procedure params) [GenBasicBlock i] -- Code, may be empty. The first block is @@ -72,7 +78,8 @@ data GenCmmTop d i -- some static data. | CmmData Section [d] -- constant values only -type CmmTop = GenCmmTop CmmStatic CmmStmt +type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt +type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt -- A basic block containing a single label, at the beginning. -- The list of basic blocks in a top-level code block may be re-ordered. @@ -96,6 +103,36 @@ blockId (BasicBlock blk_id _ ) = blk_id blockStmts :: GenBasicBlock i -> [i] blockStmts (BasicBlock _ stmts) = stmts +----------------------------------------------------------------------------- +-- Info Tables +----------------------------------------------------------------------------- + +-- Info table as a haskell data type +data CmmInfo + = CmmInfo + ProfilingInfo + (Maybe BlockId) -- GC target + ClosureTypeTag -- Int + ClosureTypeInfo + | CmmNonInfo -- Procedure doesn't need an info table + +data ClosureTypeInfo + = ConstrInfo ClosureLayout ConstrTag ConstrDescription + | FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry + | ThunkInfo ClosureLayout C_SRT + | ContInfo + [Maybe LocalReg] -- Forced stack parameters + C_SRT + +-- TODO: These types may need refinement +data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc +type ClosureTypeTag = StgHalfWord +type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs +type ConstrTag = StgHalfWord +type ConstrDescription = CLabel +type FunType = StgHalfWord +type FunArity = StgHalfWord +type SlowEntry = CLabel ----------------------------------------------------------------------------- -- CmmStmt diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index 60cb3e5..b90b1a6 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -37,7 +37,7 @@ data BrokenBlock brokenBlockTargets :: [BlockId], -- ^ Blocks that this block could - -- branch to one either by conditional + -- branch to either by conditional -- branches or via the last statement brokenBlockExit :: FinalStmt @@ -47,6 +47,7 @@ data BrokenBlock -- | How a block could be entered data BlockEntryInfo = FunctionEntry -- ^ Block is the beginning of a function + CmmInfo -- ^ Function header info CLabel -- ^ The function name CmmFormals -- ^ Aguments to function diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 42dfdce..f26e55f 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -10,12 +10,15 @@ import Cmm import CmmLint import PprCmm -import Dataflow import CmmLive import CmmBrokenBlock import CmmProcPoint import CmmCallConv +import CmmInfo +import CmmUtils +import Bitmap +import ClosureInfo import MachOp import ForeignCall import CLabel @@ -39,8 +42,8 @@ import Data.List -- |Top level driver for the CPS pass ----------------------------------------------------------------------------- cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm - -> [Cmm] -- ^ Input C-- with Proceedures - -> IO [Cmm] -- ^ Output CPS transformed C-- + -> [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Input C-- with Proceedures + -> IO [GenCmm CmmStatic [CmmStatic] CmmStmt] -- ^ Output CPS transformed C-- cmmCPS dflags abstractC = do when (dopt Opt_DoCmmLinting dflags) $ do showPass dflags "CmmLint" @@ -72,20 +75,21 @@ cmmCPS dflags abstractC = do ----------------------------------------------------------------------------- cpsProc :: UniqSupply - -> CmmTop -- ^Input proceedure - -> [CmmTop] -- ^Output proceedure and continuations -cpsProc uniqSupply x@(CmmData _ _) = [x] -cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs + -> GenCmmTop CmmStatic CmmInfo CmmStmt -- ^Input proceedure + -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt] -- ^Output proceedure and continuations +cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat] +cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs where - uniqes :: [[Unique]] - uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply + uniques :: [[Unique]] + uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply + info_uniques:block_uniques = uniques -- Break the block at each function call. -- The part after the function call will have to become a continuation. broken_blocks :: [BrokenBlock] broken_blocks = - concat $ zipWith3 breakBlock uniqes blocks - (FunctionEntry ident params:repeat ControlEntry) + concat $ zipWith3 breakBlock block_uniques blocks + (FunctionEntry info ident params:repeat ControlEntry) -- Calculate live variables for each broken block. -- @@ -104,20 +108,40 @@ cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs block_env = blocksToBlockEnv broken_blocks -- Group the blocks into continuations based on the set of proc-points. - continuations :: [Continuation] + continuations :: [Continuation (Either C_SRT CmmInfo)] continuations = map (gatherBlocksIntoContinuation proc_points block_env) (uniqSetToList proc_points) -- Select the stack format on entry to each continuation. + -- Return the max stack offset and an association list -- -- This is an association list instead of a UniqFM because -- CLabel's don't have a 'Uniqueable' instance. - formats :: [(CLabel, StackFormat)] + formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))] formats = selectStackFormat live continuations + -- Do a little meta-processing on the stack formats such as + -- getting the individual frame sizes and the maximum frame size + formats' :: (WordOff, [(CLabel, StackFormat)]) + formats' = processFormats formats + + -- TODO FIXME NOW: calculate a real max stack (including function call args) + -- TODO: from the maximum frame size get the maximum stack size. + -- The difference is due to the size taken by function calls. + + -- Update the info table data on the continuations with + -- the selected stack formats. + continuations' :: [Continuation CmmInfo] + continuations' = map (applyStackFormat (snd formats')) continuations + -- Do the actual CPS transform. cps_procs :: [CmmTop] - cps_procs = map (continuationToProc formats) continuations + cps_procs = map (continuationToProc formats') continuations' + + -- Convert the info tables from CmmInfo to [CmmStatic] + -- We might want to put this in another pass eventually + info_procs :: [RawCmmTop] + info_procs = concat (zipWith mkInfoTable info_uniques cps_procs) -------------------------------------------------------------------------------- @@ -136,14 +160,14 @@ cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs -- and heap memory (not sure if that's usefull at all though, but it may -- be worth exploring the design space). -continuationLabel (Continuation _ _ l _ _) = l -data Continuation = +continuationLabel (Continuation _ l _ _) = l +data Continuation info = Continuation - Bool -- True => Function entry, False => Continuation/return point - [CmmStatic] -- Info table, may be empty + info --(Either C_SRT CmmInfo) -- Left <=> Continuation created by the CPS + -- Right <=> Function or Proc point CLabel -- Used to generate both info & entry labels CmmFormals -- Argument locals live on entry (C-- procedure params) - [BrokenBlock] -- Code, may be empty. The first block is + [BrokenBlock] -- Code, may be empty. The first block is -- the entry point. The order is otherwise initially -- unimportant, but at some point the code gen will -- fix the order. @@ -152,13 +176,11 @@ data Continuation = -- to a label. To jump to the first block in a Proc, -- use the appropriate CLabel. --- Describes the layout of a stack frame for a continuation data StackFormat = StackFormat { stack_label :: Maybe CLabel, -- The label occupying the top slot stack_frame_size :: WordOff, -- Total frame size in words (not including arguments) - stack_live :: [(LocalReg, WordOff)] -- local reg offsets from stack top - -- TODO: see if the above can be LocalReg + stack_live :: [Maybe LocalReg] -- local reg offsets from stack top } -- A block can be a continuation of a call @@ -191,70 +213,139 @@ collectNonProcPointTargets proc_points blocks current_targets block = gatherBlocksIntoContinuation :: UniqSet BlockId -> BlockEnv BrokenBlock - -> BlockId -> Continuation + -> BlockId -> Continuation (Either C_SRT CmmInfo) gatherBlocksIntoContinuation proc_points blocks start = - Continuation is_entry info_table clabel params body + Continuation info_table clabel params body where children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start start_block = lookupWithDefaultUFM blocks (panic "TODO") start children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children) body = start_block : children_blocks - info_table = [] -- TODO + + -- We can't properly annotate the continuation's stack parameters + -- at this point because this is before stack selection + -- but we want to keep the C_SRT around so we use 'Either'. + info_table = case start_block_entry of + FunctionEntry info _ _ -> Right info + ContinuationEntry _ srt -> Left srt + ControlEntry -> Right CmmNonInfo + start_block_entry = brokenBlockEntry start_block - is_entry = case start_block_entry of - FunctionEntry _ _ -> True - _ -> False clabel = case start_block_entry of - FunctionEntry label _ -> label + FunctionEntry _ label _ -> label _ -> mkReturnPtLabel $ getUnique start params = case start_block_entry of - FunctionEntry _ args -> args + FunctionEntry _ _ args -> args ContinuationEntry args _ -> args ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers -------------------------------------------------------------------------------- -- For now just select the continuation orders in the order they are in the set with no gaps -selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)] +selectStackFormat :: BlockEnv CmmLive + -> [Continuation (Either C_SRT CmmInfo)] + -> [(CLabel, (Maybe CLabel, [Maybe LocalReg]))] selectStackFormat live continuations = map (\c -> (continuationLabel c, selectStackFormat' c)) continuations where - selectStackFormat' (Continuation True info_table label formals blocks) = - StackFormat (Just label) 0 [] - selectStackFormat' (Continuation False info_table label formals blocks) = + selectStackFormat' (Continuation + (Right (CmmInfo _ _ _ (ContInfo format srt))) + label _ _) = (Just label, format) + selectStackFormat' (Continuation (Right _) _ _ _) = (Nothing, []) + selectStackFormat' (Continuation (Left srt) label _ blocks) = -- TODO: assumes the first block is the entry block let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this - in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident + in (Just label, + map Just $ uniqSetToList $ + lookupWithDefaultUFM live unknown_block ident) - live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat - live_to_format label formals live = - foldl extend_format - (StackFormat (Just label) retAddrSizeW []) - (uniqSetToList (live `minusUniqSet` mkUniqSet formals)) + unknown_block = panic "unknown BlockId in selectStackFormat" - extend_format :: StackFormat -> LocalReg -> StackFormat - extend_format (StackFormat label size offsets) reg = - StackFormat label (slot_size reg + size) ((reg, size) : offsets) +processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))] + -> (WordOff, [(CLabel, StackFormat)]) +processFormats formats = (max_size, formats') + where + max_size = foldl max 0 (map (stack_frame_size . snd) formats') + formats' = map make_format formats + make_format (label, format) = + (label, + StackFormat { + stack_label = fst format, + stack_frame_size = stack_size (snd format) + + if isJust (fst format) + then label_size + else 0, + stack_live = snd format }) + + -- TODO: get rid of "+ 1" etc. + label_size = 1 :: WordOff + + stack_size [] = 0 + stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word + stack_size (Just reg:formats) = width + stack_size formats + where + width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE + -- TODO: it would be better if we had a machRepWordWidth - slot_size :: LocalReg -> Int - slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1 +----------------------------------------------------------------------------- +applyStackFormat :: [(CLabel, StackFormat)] + -> Continuation (Either C_SRT CmmInfo) + -> Continuation CmmInfo + +-- User written continuations +applyStackFormat formats (Continuation + (Right (CmmInfo prof gc tag (ContInfo _ srt))) + label formals blocks) = + Continuation (CmmInfo prof gc tag (ContInfo format srt)) + label formals blocks + where + format = stack_live $ maybe unknown_block id $ lookup label formats + unknown_block = panic "unknown BlockId in applyStackFormat" - unknown_block = panic "unknown BlockId in selectStackFormat" +-- User written non-continuation code +applyStackFormat formats (Continuation (Right info) label formals blocks) = + Continuation info label formals blocks -continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop -continuationToProc formats (Continuation is_entry info label formals blocks) = - CmmProc info label formals (map (continuationToProc' label formats) blocks) +-- CPS generated continuations +applyStackFormat formats (Continuation (Left srt) label formals blocks) = + Continuation (CmmInfo prof gc tag (ContInfo (stack_live $ format) srt)) + label formals blocks where - continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock - -> CmmBasicBlock - continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) = + gc = Nothing -- Generated continuations never need a stack check + -- TODO prof: this is the same as the current implementation + -- but I think it could be improved + prof = ProfilingInfo zeroCLit zeroCLit + tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE + then rET_BIG + else rET_SMALL + format = maybe unknown_block id $ lookup label formats + unknown_block = panic "unknown BlockId in applyStackFormat" + +----------------------------------------------------------------------------- +continuationToProc :: (WordOff, [(CLabel, StackFormat)]) + -> Continuation CmmInfo + -> CmmTop +continuationToProc (max_stack, formats) + (Continuation info label formals blocks) = + CmmProc info label formals (map continuationToProc' blocks) + where + curr_format = maybe unknown_block id $ lookup label formats + unknown_block = panic "unknown BlockId in continuationToProc" + + continuationToProc' :: BrokenBlock -> CmmBasicBlock + continuationToProc' (BrokenBlock ident entry stmts _ exit) = BasicBlock ident (prefix++stmts++postfix) where - curr_format = maybe unknown_block id $ lookup curr_ident formats - unknown_block = panic "unknown BlockId in continuationToProc" prefix = case entry of ControlEntry -> [] - FunctionEntry _ formals -> -- TODO: gc_stack_check + FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals -> + gc_stack_check gc_block max_stack ++ + function_entry formals curr_format + FunctionEntry (CmmInfo _ Nothing _ _) _ formals -> + panic "continuationToProc: TODO generate GC block" ++ + function_entry formals curr_format + FunctionEntry CmmNonInfo _ formals -> + panic "TODO: gc_stack_check gc_block max_stack" ++ function_entry formals curr_format ContinuationEntry formals _ -> function_entry formals curr_format @@ -277,7 +368,7 @@ continuationToProc formats (Continuation is_entry info label formals blocks) = lookup (mkReturnPtLabel $ getUnique next) formats FinalCall next _ results arguments -> panic "unimplemented CmmCall" --------------------------------------------------------------------------------- +----------------------------------------------------------------------------- -- Functions that generate CmmStmt sequences -- for packing/unpacking continuations -- and entering/exiting functions @@ -298,33 +389,45 @@ tail_call spRel target arguments argument_formats = assignArguments (cmmExprRep . fst) arguments -gc_stack_check :: WordOff -> [CmmStmt] -gc_stack_check max_frame_size +gc_stack_check :: BlockId -> WordOff -> [CmmStmt] +gc_stack_check gc_block max_frame_size = check_stack_limit where check_stack_limit = [ CmmCondBranch (CmmMachOp (MO_U_Lt $ cmmRegRep spReg) [CmmRegOff spReg max_frame_size, CmmReg spLimReg]) gc_block] - gc_block = panic "gc_check not implemented" -- TODO: get stack and heap checks to go to same -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation) pack_continuation :: StackFormat -> StackFormat -> [CmmStmt] pack_continuation (StackFormat curr_id curr_frame_size _) - (StackFormat cont_id cont_frame_size cont_offsets) + (StackFormat cont_id cont_frame_size live_regs) = store_live_values ++ set_stack_header where - -- TODO: only save variables when actually needed (may be handled by latter pass) + -- 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] set_stack_header = - if not needs_header - then [] - else [stack_put spRel continuation_function 0] + if needs_header_set + then [stack_put spRel continuation_function 0] + else [] + + -- TODO: factor with function_entry and CmmInfo.hs(?) + cont_offsets = mkOffsets label_size live_regs + + 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 + where + width = machRepByteWidth (localRegRep reg) `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 = + needs_header_set = case (curr_id, cont_id) of (Just x, Just y) -> x /= y _ -> isJust cont_id @@ -334,9 +437,10 @@ pack_continuation (StackFormat curr_id curr_frame_size _) -- have the same stack format (this causes a problem -- only for proc-point). function_entry :: CmmFormals -> StackFormat -> [CmmStmt] -function_entry formals (StackFormat _ _ curr_offsets) +function_entry formals (StackFormat _ _ live_regs) = load_live_values ++ load_args where - -- TODO: only save variables when actually needed (may be handled by latter pass) + -- TODO: only save variables when actually needed + -- (may be handled by latter pass) load_live_values = [stack_get 0 reg offset | (reg, offset) <- curr_offsets] @@ -348,6 +452,18 @@ function_entry formals (StackFormat _ _ curr_offsets) argument_formats = assignArguments (localRegRep) formals + -- TODO: eliminate copy/paste with pack_continuation + curr_offsets = mkOffsets label_size live_regs + + 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 + where + width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE + -- TODO: it would be better if we had a machRepWordWidth + ----------------------------------------------------------------------------- -- Section: Stack and argument register puts and gets ----------------------------------------------------------------------------- @@ -370,7 +486,9 @@ stack_get :: WordOff -> WordOff -> CmmStmt stack_get spRel reg offset = - CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (localRegRep reg)) + CmmAssign (CmmLocal reg) + (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) + (localRegRep reg)) global_put :: CmmExpr -> GlobalReg -> CmmStmt global_put expr global = CmmAssign (CmmGlobal global) expr global_get :: LocalReg -> GlobalReg -> CmmStmt diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index fd4a99c..130dba0 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -25,10 +25,10 @@ import Control.Monad -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: Cmm -> Maybe SDoc +cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops -cmmLintTop :: CmmTop -> Maybe SDoc +cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc cmmLintTop top = runCmmLint $ lintCmmTop top runCmmLint :: CmmLint a -> Maybe SDoc @@ -37,7 +37,7 @@ runCmmLint l = Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err) Right _ -> Nothing -lintCmmTop (CmmProc _info lbl _args blocks) +lintCmmTop (CmmProc _ lbl _ blocks) = addLintInfo (text "in proc " <> pprCLabel lbl) $ mapM_ lintCmmBlock blocks lintCmmTop _other diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 76ed78e..4b2a488 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -531,7 +531,7 @@ narrowS _ _ = panic "narrowTo" except factorial, but what the hell. -} -cmmLoopifyForC :: CmmTop -> CmmTop +cmmLoopifyForC :: RawCmmTop -> RawCmmTop cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _)) | null info = p -- only if there's an info table, ignore case alts | otherwise = diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index dda1ca2..ab50799 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -199,23 +199,24 @@ lits :: { [ExtFCode CmmExpr] } | ',' expr lits { $2 : $3 } cmmproc :: { ExtCode } - : info maybe_formals '{' body '}' - { do (info_lbl, info1, info2) <- $1; - formals <- sequence $2; - stmts <- getCgStmtsEC (loopDecls $4) - blks <- code (cgStmtsToBlocks stmts) - code (emitInfoTableAndCode info_lbl info1 info2 formals blks) } - - | info maybe_formals ';' - { do (info_lbl, info1, info2) <- $1; - formals <- sequence $2; - code (emitInfoTableAndCode info_lbl info1 info2 formals []) } - - | NAME maybe_formals '{' body '}' +-- TODO: add real SRT/info tables to parsed Cmm +-- : info maybe_formals '{' body '}' +-- { do (info_lbl, info1, info2) <- $1; +-- formals <- sequence $2; +-- stmts <- getCgStmtsEC (loopDecls $4) +-- blks <- code (cgStmtsToBlocks stmts) +-- code (emitInfoTableAndCode info_lbl info1 info2 formals blks) } +-- +-- | info maybe_formals ';' +-- { do (info_lbl, info1, info2) <- $1; +-- formals <- sequence $2; +-- code (emitInfoTableAndCode info_lbl info1 info2 formals []) } + + : NAME maybe_formals '{' body '}' { do formals <- sequence $2; stmts <- getCgStmtsEC (loopDecls $4); blks <- code (cgStmtsToBlocks stmts); - code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) } + code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) } info :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) } : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' @@ -261,13 +262,17 @@ stmt :: { ExtCode } | NAME ':' { do l <- newLabel $1; code (labelC l) } --- HACK: this should just be lregs but that causes a shift/reduce conflict --- with foreign calls --- | hint_lregs '=' expr ';' --- { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) } + | lreg '=' expr ';' + { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) } | type '[' expr ']' '=' expr ';' { doStore $1 $3 $6 } --- TODO: add real SRT to parsed Cmm + + -- Gah! We really want to say "maybe_results" but that causes + -- a shift/reduce conflict with assignment. We either + -- we expand out the no-result and single result cases or + -- we tweak the syntax to avoid the conflict. The later + -- option is taken here because the other way would require + -- multiple levels of expanding and get unwieldy. | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';' {% foreignCall $3 $1 $4 $6 $8 NoC_SRT } | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';' @@ -407,15 +412,11 @@ reg :: { ExtFCode CmmExpr } maybe_results :: { [ExtFCode (CmmFormal, MachHint)] } : {- empty -} { [] } - | hint_lregs '=' { $1 } - -hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] } - : {- empty -} { [] } - | hint_lregs { $1 } + | '(' hint_lregs ')' '=' { $2 } hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] } - : hint_lreg ',' { [$1] } - | hint_lreg { [$1] } + : hint_lreg { [$1] } + | hint_lreg ',' { [$1] } | hint_lreg ',' hint_lregs { $1 : $3 } hint_lreg :: { ExtFCode (CmmFormal, MachHint) } diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 65b0816..2d48f76 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -45,7 +45,7 @@ calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks map brokenBlockId $ filter always_proc_point blocks always_proc_point BrokenBlock { - brokenBlockEntry = FunctionEntry _ _ } = True + brokenBlockEntry = FunctionEntry _ _ _ } = True always_proc_point BrokenBlock { brokenBlockEntry = ContinuationEntry _ _ } = True always_proc_point _ = False diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 817e82b..8726547 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -66,7 +66,7 @@ import StaticFlags ( opt_Unregisterised ) -- -------------------------------------------------------------------------- -- Top level -pprCs :: DynFlags -> [Cmm] -> SDoc +pprCs :: DynFlags -> [RawCmm] -> SDoc pprCs dflags cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms) where @@ -74,7 +74,7 @@ pprCs dflags cmms | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER") | otherwise = empty -writeCs :: DynFlags -> Handle -> [Cmm] -> IO () +writeCs :: DynFlags -> Handle -> [RawCmm] -> IO () writeCs dflags handle cmms = printForC handle (pprCs dflags cmms) @@ -84,13 +84,13 @@ writeCs dflags handle cmms -- for fun, we could call cmmToCmm over the tops... -- -pprC :: Cmm -> SDoc +pprC :: RawCmm -> SDoc pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops -- -- top level procs -- -pprTop :: CmmTop -> SDoc +pprTop :: RawCmmTop -> SDoc pprTop (CmmProc info clbl _params blocks) = (if not (null info) then pprDataExterns info $$ diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 3253915..55a8014 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -52,7 +52,7 @@ import Data.List import System.IO import Data.Maybe -pprCmms :: [Cmm] -> SDoc +pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ ptext SLIT("-------------------") $$ space @@ -62,10 +62,10 @@ writeCmms handle cmms = printForC handle (pprCmms cmms) ----------------------------------------------------------------------------- -instance Outputable Cmm where +instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where ppr c = pprCmm c -instance Outputable CmmTop where +instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where ppr t = pprTop t instance Outputable CmmBasicBlock where @@ -86,31 +86,28 @@ instance Outputable LocalReg where instance Outputable GlobalReg where ppr e = pprGlobalReg e +instance Outputable CmmStatic where + ppr e = pprStatic e + +instance Outputable CmmInfo where + ppr e = pprInfo e + ----------------------------------------------------------------------------- -pprCmm :: Cmm -> SDoc +pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops -- -------------------------------------------------------------------------- --- Top level `procedure' blocks. The info tables, if not null, are --- printed in the style of C--'s 'stackdata' declaration, just inside --- the proc body, and are labelled with the procedure name ++ "_info". +-- Top level `procedure' blocks. -- -pprTop :: CmmTop -> SDoc +pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc pprTop (CmmProc info lbl params blocks ) = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace - , nest 8 $ pprInfo info lbl + , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ vcat (map ppr blocks) , rbrace ] - where - pprInfo [] _ = empty - pprInfo i label = - (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace ) - 4 $ vcat (map pprStatic i)) - $$ rbrace - -- -------------------------------------------------------------------------- -- We follow [1], 4.5 -- @@ -121,6 +118,46 @@ pprTop (CmmData section ds) = $$ rbrace + +-- -------------------------------------------------------------------------- +-- Info tables. The current pretty printer needs refinement +-- but will work for now. +-- +-- 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 = empty +pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc) + gc_target tag info) = + vcat [ptext SLIT("type: ") <> pprLit closure_type, + ptext SLIT("desc: ") <> pprLit closure_desc, + ptext SLIT("gc_target: ") <> + maybe (ptext SLIT("")) pprBlockId gc_target, + ptext SLIT("tag: ") <> integer (toInteger tag), + pprTypeInfo info] + +pprTypeInfo (ConstrInfo layout constr descr) = + vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)), + ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)), + ptext SLIT("constructor: ") <> integer (toInteger constr), + ppr descr] +pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) = + vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)), + ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)), + 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 + --ppr slow_entry -- TODO: needs to be printed + ] +pprTypeInfo (ThunkInfo layout srt) = + vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)), + ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)), + ptext SLIT("srt: ") <> ppr srt] +pprTypeInfo (ContInfo stack srt) = + vcat [ptext SLIT("stack: ") <> ppr stack, + ptext SLIT("srt: ") <> ppr srt] + -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. @@ -151,12 +188,13 @@ pprStmt stmt = case stmt of -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile CmmCall (CmmForeignCall fn cconv) results args srt -> - hcat [ ptext SLIT("call"), space, + hcat [ if null results + then empty + else parens (commafy $ map ppr results) <> + ptext SLIT(" = "), + ptext SLIT("call"), space, doubleQuotes(ppr cconv), space, target fn, parens ( commafy $ map ppr args ), - (if null results - then empty - else brackets( commafy $ map ppr results)), brackets (ppr srt), semi ] where target (CmmLit lit) = pprLit lit diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 4b659b7..b0fab89 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -51,6 +51,7 @@ import Util import StaticFlags import FastString import Outputable +import Unique import Data.Bits @@ -135,7 +136,7 @@ stdPattern other = Nothing mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness mkLiveness name size bits | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word - = do { let lbl = mkBitmapLabel name + = do { let lbl = mkBitmapLabel (getUnique name) ; emitRODataLits lbl ( mkWordCLit (fromIntegral size) : map mkWordCLit bits) ; return (BigLiveness lbl) } diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 4220b47..6b7fcd5 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -45,6 +45,7 @@ import StaticFlags import Maybes import Constants +import Panic ------------------------------------------------------------------------- -- @@ -92,7 +93,7 @@ emitClosureCodeAndInfoTable cl_info args body return (makeRelativeRefTo info_lbl cstr) else return (mkIntCLit 0) - ; emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks } + ; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks } where info_lbl = infoTableLabelFromCI cl_info @@ -200,7 +201,7 @@ emitReturnTarget name stmts mkRetInfoTable info_lbl liveness srt_info cl_type ; blks <- cgStmtsToBlocks stmts - ; emitInfoTableAndCode info_lbl std_info extra_bits args blks + ; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks ; return info_lbl } where args = {- trace "emitReturnTarget: missing args" -} [] @@ -212,7 +213,7 @@ mkRetInfoTable :: CLabel -- info label -> Liveness -- liveness -> C_SRT -- SRT Info - -> Int -- type (eg. rET_SMALL) + -> StgHalfWord -- type (eg. rET_SMALL) -> ([CmmLit],[CmmLit]) mkRetInfoTable info_lbl liveness srt_info cl_type = (std_info, srt_slot) @@ -264,7 +265,7 @@ emitReturnInstr mkStdInfoTable :: CmmLit -- closure type descr (profiling) -> CmmLit -- closure descr (profiling) - -> Int -- closure type + -> StgHalfWord -- closure type -> StgHalfWord -- SRT length -> CmmLit -- layout field -> [CmmLit] @@ -391,6 +392,19 @@ funInfoTable info_ptr emitInfoTableAndCode :: CLabel -- Label of info table + -> CmmInfo -- ...the info table + -> CmmFormals -- ...args + -> [CmmBasicBlock] -- ...and body + -> Code + +emitInfoTableAndCode info_lbl info args blocks + = emitProc info entry_lbl args blocks + where + entry_lbl = infoLblToEntryLbl info_lbl + +{- +emitInfoTableAndCode + :: CLabel -- Label of info table -> [CmmLit] -- ...its invariant part -> [CmmLit] -- ...and its variant part -> CmmFormals -- ...args @@ -415,6 +429,7 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks where entry_lbl = infoLblToEntryLbl info_lbl +-} ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index ca08e06..e3c8a77 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -734,9 +734,9 @@ emitData sect lits where data_block = CmmData sect lits -emitProc :: [CmmLit] -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code -emitProc lits lbl args blocks - = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks +emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code +emitProc info lbl args blocks + = do { let proc_block = CmmProc info lbl args blocks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } @@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code emitSimpleProc lbl code = do { stmts <- getCgStmts code ; blks <- cgStmtsToBlocks stmts - ; emitProc [] lbl [] blks } + ; emitProc CmmNonInfo lbl [] blks } getCmm :: Code -> FCode Cmm -- Get all the CmmTops (there should be no stmts) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 26857d3..13de213 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -9,7 +9,9 @@ module CgUtils ( addIdReps, cgLit, - emitDataLits, emitRODataLits, emitIf, emitIfThenElse, + emitDataLits, mkDataLits, + emitRODataLits, mkRODataLits, + emitIf, emitIfThenElse, emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, assignNonPtrTemp, newNonPtrTemp, assignPtrTemp, newPtrTemp, @@ -309,6 +311,11 @@ emitDataLits :: CLabel -> [CmmLit] -> Code emitDataLits lbl lits = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +-- Emit a data-segment data block +mkDataLits lbl lits + = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + emitRODataLits :: CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits lbl lits @@ -319,6 +326,15 @@ emitRODataLits lbl lits needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits lbl lits + = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + where section | any needsRelocation lits = RelocatableReadOnlyData + | otherwise = ReadOnlyData + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + mkStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, -- and return its label diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs index 6c57a4e..f323c1b 100644 --- a/compiler/codeGen/SMRep.lhs +++ b/compiler/codeGen/SMRep.lhs @@ -304,7 +304,7 @@ smRepClosureType :: SMRep -> Maybe ClosureType smRepClosureType (GenericRep _ _ _ ty) = Just ty smRepClosureType BlackHoleRep = Nothing -smRepClosureTypeInt :: SMRep -> Int +smRepClosureTypeInt :: SMRep -> StgHalfWord smRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0 smRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1 smRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0 @@ -339,7 +339,7 @@ smRepClosureTypeInt rep = panic "smRepClosuretypeint" -- We export these ones -rET_SMALL = (RET_SMALL :: Int) -rET_BIG = (RET_BIG :: Int) +rET_SMALL = (RET_SMALL :: StgHalfWord) +rET_BIG = (RET_BIG :: StgHalfWord) \end{code} diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 0e52077..a3d24e2 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -26,7 +26,7 @@ import Packages import PackageConfig ( rtsPackageId ) import Util import FastString ( unpackFS ) -import Cmm ( Cmm ) +import Cmm ( RawCmm ) import HscTypes import DynFlags @@ -55,7 +55,7 @@ codeOutput :: DynFlags -> ModLocation -> ForeignStubs -> [PackageId] - -> [Cmm] -- Compiled C-- + -> [RawCmm] -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 93324d5..0ae942c 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -605,7 +605,7 @@ hscCompile cgguts foreign_stubs dir_imps cost_centre_info stg_binds hpc_info ------------------ Convert to CPS -------------------- - continuationC <- cmmCPS dflags abstractC + continuationC <- {-return abstractC-} cmmCPS dflags abstractC ------------------ Code output ----------------------- (stub_h_exists,stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs @@ -721,7 +721,7 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - continuationC <- cmmCPS dflags [cmm] + continuationC <- {-return [cmm]-} cmmCPS dflags [cmm] codeOutput dflags no_mod no_loc NoStubs [] continuationC return True where diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index b3ca844..f954d52 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -108,12 +108,12 @@ The machine-dependent bits break down as follows: -- NB. We *lazilly* compile each block of code for space reasons. -nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc +nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc nativeCodeGen dflags cmms us = let (res, _) = initUs us $ cgCmm (concat (map add_split cmms)) - cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel]) + cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel]) cgCmm tops = lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results -> case unzip3 results of { (cmms,docs,imps) -> @@ -196,7 +196,7 @@ nativeCodeGen dflags cmms us -- Complete native code generation phase for a single top-level chunk -- of Cmm. -cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel]) +cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel]) cmmNativeGen dflags cmm = {-# SCC "fixAssigns" #-} fixAssignsTop cmm `thenUs` \ fixed_cmm -> @@ -390,7 +390,7 @@ apply_mapping ufm (CmmProc info lbl params blocks) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel]) +genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) genMachCode cmm_top = do { initial_us <- getUs @@ -412,7 +412,7 @@ genMachCode cmm_top -- the generic optimiser below, to avoid having two separate passes -- over the Cmm. -fixAssignsTop :: CmmTop -> UniqSM CmmTop +fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop fixAssignsTop top@(CmmData _ _) = returnUs top fixAssignsTop (CmmProc info lbl params blocks) = mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> @@ -490,7 +490,7 @@ Ideas for other things we could do (ToDo): temp assignments, and certain assigns to mem...) -} -cmmToCmm :: CmmTop -> (CmmTop, [CLabel]) +cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm top@(CmmData _ _) = (top, []) cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index dc79d95..154eed8 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -62,7 +62,7 @@ import Data.Int type InstrBlock = OrdList Instr -cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop] +cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop] cmmTopCodeGen (CmmProc info lab params blocks) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat diff --git a/compiler/nativeGen/MachInstrs.hs b/compiler/nativeGen/MachInstrs.hs index 6316d94..5ed8c0c 100644 --- a/compiler/nativeGen/MachInstrs.hs +++ b/compiler/nativeGen/MachInstrs.hs @@ -52,8 +52,8 @@ import GHC.Exts -- Our flavours of the Cmm types -- Type synonyms for Cmm populated with native code -type NatCmm = GenCmm CmmStatic Instr -type NatCmmTop = GenCmmTop CmmStatic Instr +type NatCmm = GenCmm CmmStatic [CmmStatic] Instr +type NatCmmTop = GenCmmTop CmmStatic [CmmStatic] Instr type NatBasicBlock = GenBasicBlock Instr -- ----------------------------------------------------------------------------- -- 1.7.10.4