From d31dfb32ea936c22628b508c28a36c12e631430a Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Wed, 27 Jun 2007 15:21:30 +0000 Subject: [PATCH] Implemented and fixed bugs in CmmInfo handling --- compiler/cmm/CLabel.hs | 8 +- compiler/cmm/Cmm.hs | 12 +- compiler/cmm/CmmCPS.hs | 12 +- compiler/cmm/CmmInfo.hs | 236 ++++++++++++++++++----- compiler/cmm/CmmParse.y | 49 +---- compiler/cmm/PprC.hs | 10 +- compiler/cmm/PprCmm.hs | 19 +- compiler/codeGen/CgBindery.lhs | 12 ++ compiler/codeGen/CgCallConv.hs | 64 ++----- compiler/codeGen/CgClosure.lhs | 2 +- compiler/codeGen/CgForeignCall.hs | 15 +- compiler/codeGen/CgInfoTbls.hs | 383 ++++++++++++++++++------------------- compiler/codeGen/CgProf.hs | 3 +- compiler/codeGen/CgUtils.hs | 29 +-- compiler/codeGen/ClosureInfo.lhs | 9 +- compiler/main/HscMain.lhs | 7 +- compiler/nativeGen/AsmCodeGen.lhs | 21 -- compiler/nativeGen/MachCodeGen.hs | 4 +- includes/Cmm.h | 2 +- rts/Exception.cmm | 42 ++-- rts/HeapStackCheck.cmm | 48 ++--- rts/PrimOps.cmm | 150 +++++++-------- rts/StgMiscClosures.cmm | 32 +--- rts/StgStartup.cmm | 16 +- rts/StgStdThunks.cmm | 10 +- rts/Updates.cmm | 12 +- utils/genapply/GenApply.hs | 17 +- 27 files changed, 607 insertions(+), 617 deletions(-) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 94ae64a..ffca61d 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -521,6 +521,8 @@ externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel HpcModuleNameLabel = False +externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeSRTLabel _) = False -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -702,7 +704,11 @@ 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 (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext SLIT("btm") +-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') +-- until that gets resolved we'll just force them to start +-- with a letter so the label will be legal assmbly code. + pprCLbl (RtsLabel (RtsCode str)) = ptext str pprCLbl (RtsLabel (RtsData str)) = ptext str diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 9038534..530fab5 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -9,9 +9,10 @@ module Cmm ( GenCmm(..), Cmm, RawCmm, GenCmmTop(..), CmmTop, RawCmmTop, - CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), + CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals, + CmmSafety(..), CmmCallTarget(..), CmmStatic(..), Section(..), CmmExpr(..), cmmExprRep, @@ -133,12 +134,14 @@ data ClosureTypeInfo -- 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 ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs type ConstrTag = StgHalfWord type ConstrDescription = CmmLit type FunType = StgHalfWord type FunArity = StgHalfWord -type SlowEntry = CLabel +type SlowEntry = CmmLit + -- ^We would like this to be a CLabel but + -- for now the parser sets this to zero on an INFO_TABLE_FUN. type SelectorOffset = StgWord ----------------------------------------------------------------------------- @@ -161,7 +164,7 @@ data CmmStmt CmmCallTarget CmmHintFormals -- zero or more results CmmActuals -- zero or more arguments - C_SRT -- SRT for the continuation of the call + CmmSafety -- whether to build a continuation | CmmBranch BlockId -- branch to another BB in this fn @@ -184,6 +187,7 @@ type CmmActuals = [(CmmActual,MachHint)] type CmmFormal = LocalReg type CmmHintFormals = [(CmmFormal,MachHint)] type CmmFormals = [CmmFormal] +data CmmSafety = CmmUnsafe | CmmSafe C_SRT {- Discussion diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index be9f474..b6c57ee 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -70,9 +70,9 @@ 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 srt = BasicBlock block_id stmts +make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts where - stmts = [CmmCall stg_gc_gen_target [] [] srt, + stmts = [CmmCall stg_gc_gen_target [] [] safety, CmmJump fun_expr actuals] stg_gc_gen_target = CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv @@ -85,10 +85,10 @@ force_gc_block old_info block_id fun_label formals blocks = CmmInfo _ (Just _) _ _ -> (old_info, []) CmmNonInfo Nothing -> (CmmNonInfo (Just block_id), - [make_gc_block block_id fun_label formals NoC_SRT]) + [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)]) CmmInfo prof Nothing type_tag type_info -> (CmmInfo prof (Just block_id) type_tag type_info, - [make_gc_block block_id fun_label formals srt]) + [make_gc_block block_id fun_label formals (CmmSafe srt)]) where srt = case type_info of ConstrInfo _ _ _ -> NoC_SRT @@ -361,9 +361,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) = -- 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 + tag = rET_SMALL -- cmmToRawCmm will convert this to rET_BIG if needed format = maybe unknown_block id $ lookup label formats unknown_block = panic "unknown BlockId in applyStackFormat" diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index ab46f1e..5937dd4 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,4 +1,5 @@ module CmmInfo ( + cmmToRawCmm, mkInfoTable ) where @@ -6,30 +7,81 @@ module CmmInfo ( import Cmm import CmmUtils +import PprCmm import CLabel +import MachOp import Bitmap import ClosureInfo import CgInfoTbls import CgCallConv import CgUtils +import SMRep import Constants import StaticFlags +import DynFlags import Unique +import UniqSupply import Panic import Data.Bits +cmmToRawCmm :: [Cmm] -> IO [RawCmm] +cmmToRawCmm cmm = do + info_tbl_uniques <- mkSplitUniqSupply 'i' + return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm + where + raw_cmm uniq_supply (Cmm procs) = + Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs + +-- Make a concrete info table, represented as a list of CmmStatic +-- (it can't be simply a list of Word, because the SRT field is +-- represented by a label+offset expression). +-- +-- With tablesNextToCode, the layout is +-- +-- +-- +-- +-- Without tablesNextToCode, the layout of an info table is +-- +-- +-- +-- +-- See includes/InfoTables.h +-- +-- For return-points these are as follows +-- +-- Tables next to code: +-- +-- +-- +-- ret-addr --> +-- +-- Not tables-next-to-code: +-- +-- ret-addr --> +-- +-- +-- +-- * The SRT slot is only there if there is SRT info to record + mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat] mkInfoTable uniq (CmmProc info entry_label arguments blocks) = case info of + -- | Code without an info table. Easy. CmmNonInfo _ -> [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) -> - mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks + (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 fun_extra_bits = [packHalfWordsCLit fun_type fun_arity] ++ @@ -37,71 +89,74 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) = case pap_bitmap of ArgGen liveness -> [makeRelativeRefTo info_label $ mkLivenessCLit liveness, - makeRelativeRefTo info_label (CmmLabel slow_entry)] + makeRelativeRefTo info_label slow_entry] _ -> [] std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout info_label = entryLblToInfoLbl entry_label - (srt_label, srt_bitmap) = - case srt of - NoC_SRT -> ([], 0) - (C_SRT lbl off bitmap) -> - ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], - bitmap) + (srt_label, srt_bitmap) = mkSRTLit info_label srt layout = packHalfWordsCLit ptrs nptrs + -- | A constructor. CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ConstrInfo (ptrs, nptrs) con_tag descr) -> - mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks + mkInfoTableAndCode info_label std_info [con_name] entry_label + arguments blocks where std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout info_label = entryLblToInfoLbl entry_label con_name = makeRelativeRefTo info_label descr layout = packHalfWordsCLit ptrs nptrs + -- | A thunk. CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ThunkInfo (ptrs, nptrs) srt) -> - mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks where std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout info_label = entryLblToInfoLbl entry_label - (srt_label, srt_bitmap) = - case srt of - NoC_SRT -> ([], 0) - (C_SRT lbl off bitmap) -> - ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], - bitmap) + (srt_label, srt_bitmap) = mkSRTLit info_label srt layout = packHalfWordsCLit ptrs nptrs + -- | A selector thunk. CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ThunkSelectorInfo offset srt) -> - mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks where std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset) info_label = entryLblToInfoLbl entry_label - (srt_label, srt_bitmap) = - case srt of - NoC_SRT -> ([], 0) - (C_SRT lbl off bitmap) -> - ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], - bitmap) + (srt_label, srt_bitmap) = mkSRTLit info_label srt + -- A continuation/return-point. CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) -> liveness_data ++ - mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks where - std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit + std_info = mkStdInfoTable ty_prof cl_prof maybe_big_type_tag srt_bitmap + (makeRelativeRefTo info_label liveness_lit) info_label = entryLblToInfoLbl entry_label - (liveness_lit, liveness_data) = mkLiveness uniq stack_layout - (srt_label, srt_bitmap) = - case srt of - NoC_SRT -> ([], 0) - (C_SRT lbl off bitmap) -> - ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], - bitmap) + (liveness_lit, liveness_data, liveness_tag) = + mkLiveness uniq stack_layout + maybe_big_type_tag = if type_tag == rET_SMALL + then liveness_tag + else type_tag + (srt_label, srt_bitmap) = mkSRTLit info_label srt +-- Handle the differences between tables-next-to-code +-- and not tables-next-to-code +mkInfoTableAndCode :: CLabel + -> [CmmLit] + -> [CmmLit] + -> CLabel + -> CmmFormals + -> [CmmBasicBlock] + -> [RawCmmTop] mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc - = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks] + = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) + entry_lbl args blocks] | null blocks -- No actual code; only the info table is significant = -- Use a zero place-holder in place of the @@ -113,27 +168,108 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits), CmmProc [] entry_lbl args blocks] +mkSRTLit :: CLabel + -> C_SRT + -> ([CmmLit], -- srt_label + StgHalfWord) -- srt_bitmap +mkSRTLit info_label NoC_SRT = ([], 0) +mkSRTLit info_label (C_SRT lbl off bitmap) = + ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap) + +------------------------------------------------------------------------- +-- +-- Build a liveness mask for the stack layout +-- +------------------------------------------------------------------------- + +-- There are four kinds of things on the stack: +-- +-- - pointer variables (bound in the environment) +-- - non-pointer variables (bound in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) +-- +-- The first two are represented with a 'Just' of a 'LocalReg'. +-- The last two with one or more 'Nothing' constructors. +-- Each 'Nothing' represents one used word. +-- +-- The head of the stack layout is the top of the stack and +-- the least-significant bit. + -- TODO: refactor to use utility functions -mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt]) -mkLiveness uniq live - = if length live > mAX_SMALL_BITMAP_SIZE - then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word - else (mkWordCLit small_liveness, []) -- fits in one word +-- TODO: combine with CgCallConv.mkLiveness (see comment there) +mkLiveness :: Unique + -> [Maybe LocalReg] + -> (CmmLit, -- ^ The bitmap (literal value or label) + [RawCmmTop], -- ^ Large bitmap CmmData if needed + ClosureTypeTag) -- ^ rET_SMALL or rET_BIG +mkLiveness uniq live = + if length bits > mAX_SMALL_BITMAP_SIZE + -- does not fit in one word + then (CmmLabel big_liveness, [data_lits], rET_BIG) + -- fits in one word + else (mkWordCLit small_liveness, [], rET_SMALL) where - size = length live + mkBits [] = [] + mkBits (reg:regs) = take sizeW bits ++ mkBits regs where + sizeW = case reg of + Nothing -> 1 + Just r -> machRepByteWidth (localRegRep r) `quot` wORD_SIZE + bits = repeat $ is_non_ptr reg -- True <=> Non Ptr - bits = mkBitmap (map is_non_ptr live) is_non_ptr Nothing = True - is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True - is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False + is_non_ptr (Just reg) = + case localRegGCFollow reg of + KindNonPtr -> True + KindPtr -> False - big_liveness = mkBitmapLabel uniq - data_lits = mkRODataLits big_liveness lits - lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits - - small_liveness = - fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT) - small_bits = case bits of + bits :: [Bool] + bits = mkBits live + + bitmap :: Bitmap + bitmap = mkBitmap bits + + small_bitmap = case bitmap of [] -> 0 [b] -> fromIntegral b _ -> panic "mkLiveness" + small_liveness = + fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT) + + big_liveness = mkBitmapLabel uniq + lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap + data_lits = mkRODataLits big_liveness lits + +------------------------------------------------------------------------- +-- +-- Generating a standard info table +-- +------------------------------------------------------------------------- + +-- The standard bits of an info table. This part of the info table +-- corresponds to the StgInfoTable type defined in InfoTables.h. +-- +-- Its shape varies with ticky/profiling/tables next to code etc +-- so we can't use constant offsets from Constants + +mkStdInfoTable + :: CmmLit -- closure type descr (profiling) + -> CmmLit -- closure descr (profiling) + -> StgHalfWord -- closure type + -> StgHalfWord -- SRT length + -> CmmLit -- layout field + -> [CmmLit] + +mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit + = -- Parallel revertible-black hole field + prof_info + -- Ticky info (none at present) + -- Debug info (none at present) + ++ [layout_lit, type_lit] + + where + prof_info + | opt_SccProfilingOn = [type_descr, closure_descr] + | otherwise = [] + + type_lit = packHalfWordsCLit cl_type srt_len diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 7fc4c43..840b564 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -231,7 +231,9 @@ info :: { ExtFCode (CLabel, CmmInfo) } { do prof <- profilingInfo $11 $13 return (mkRtsInfoLabelFS $3, CmmInfo prof Nothing (fromIntegral $9) - (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) } + (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. @@ -258,7 +260,7 @@ info :: { ExtFCode (CLabel, CmmInfo) } CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5) (ContInfo [] NoC_SRT)) } - | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')' + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' -- closure type, live regs { do live <- sequence (map (liftM Just) $7) return (mkRtsInfoLabelFS $3, @@ -792,48 +794,6 @@ forkLabelledCodeEC ec = do stmts <- getCgStmtsEC ec code (forkCgStmts stmts) -retInfo name size live_bits cl_type = do - let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits) - info_lbl = mkRtsRetInfoLabelFS name - (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT - (fromIntegral cl_type) - return (info_lbl, info1, info2) - -stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = - basicInfo name (packHalfWordsCLit ptrs nptrs) - srt_bitmap cl_type desc_str ty_str - -conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do - (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs) - srt_bitmap cl_type desc_str ty_str - desc_lit <- code $ mkStringCLit desc_str - let desc_field = makeRelativeRefTo lbl desc_lit - return (lbl, info1, [desc_field]) - -basicInfo name layout srt_bitmap cl_type desc_str ty_str = do - let info_lbl = mkRtsInfoLabelFS name - lit1 <- if opt_SccProfilingOn - then code $ do lit <- mkStringCLit desc_str - return (makeRelativeRefTo info_lbl lit) - else return (mkIntCLit 0) - lit2 <- if opt_SccProfilingOn - then code $ do lit <- mkStringCLit ty_str - return (makeRelativeRefTo info_lbl lit) - else return (mkIntCLit 0) - let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) - (fromIntegral srt_bitmap) - layout - return (info_lbl, info1, []) - -funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do - (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-} - cl_type desc_str ty_str - let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero - -- we leave most of the fields zero here. This is only used - -- to generate the BCO info table in the RTS at the moment. - return (label,info1,info2) - where - zero = mkIntCLit 0 profilingInfo desc_str ty_str = do lit1 <- if opt_SccProfilingOn @@ -907,6 +867,7 @@ emitRetUT args = do emitStmts stmts when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) []) + -- TODO (when using CPS): emitStmt (CmmReturn (map snd args)) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 8726547..1a909f2 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -199,11 +199,11 @@ pprStmt stmt = case stmt of where rep = cmmExprRep src - CmmCall (CmmForeignCall fn cconv) results args srt -> + CmmCall (CmmForeignCall fn cconv) results args safety -> -- Controversial: leave this out for now. -- pprUndef fn $$ - pprCall ppr_fn cconv results args srt + pprCall ppr_fn cconv results args safety where ppr_fn = case fn of CmmLit (CmmLabel lbl) -> pprCLabel lbl @@ -220,8 +220,8 @@ pprStmt stmt = case stmt of ptext SLIT("#undef") <+> pprCLabel lbl pprUndef _ = empty - CmmCall (CmmPrim op) results args srt -> - pprCall ppr_fn CCallConv results args srt + CmmCall (CmmPrim op) results args safety -> + pprCall ppr_fn CCallConv results args safety where ppr_fn = pprCallishMachOp_for_C op @@ -719,7 +719,7 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT +pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety -> SDoc pprCall ppr_fn cconv results args _ diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 97170a1..163c86b 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -117,7 +117,10 @@ pprTop (CmmData section ds) = (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds))) $$ rbrace - +-- -------------------------------------------------------------------------- +instance Outputable CmmSafety where + ppr CmmUnsafe = ptext SLIT("_unsafe_call_") + ppr (CmmSafe srt) = ppr srt -- -------------------------------------------------------------------------- -- Info tables. The current pretty printer needs refinement @@ -128,13 +131,15 @@ pprTop (CmmData section ds) = -- and were labelled with the procedure name ++ "_info". pprInfo (CmmNonInfo gc_target) = ptext SLIT("gc_target: ") <> - maybe (ptext SLIT("")) pprBlockId gc_target + ptext SLIT("TODO") --maybe (ptext SLIT("")) 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, ptext SLIT("desc: ") <> pprLit closure_desc, ptext SLIT("gc_target: ") <> - maybe (ptext SLIT("")) pprBlockId gc_target, + ptext SLIT("TODO"), --maybe (ptext SLIT("")) pprBlockId gc_target, + -- ^ gc_target is currently unused and wired to a panic ptext SLIT("tag: ") <> integer (toInteger tag), pprTypeInfo info] @@ -192,7 +197,7 @@ pprStmt stmt = case stmt of -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile - CmmCall (CmmForeignCall fn cconv) results args srt -> + CmmCall (CmmForeignCall fn cconv) results args safety -> hcat [ if null results then empty else parens (commafy $ map ppr results) <> @@ -200,14 +205,14 @@ pprStmt stmt = case stmt of ptext SLIT("call"), space, doubleQuotes(ppr cconv), space, target fn, parens ( commafy $ map ppr args ), - brackets (ppr srt), semi ] + brackets (ppr safety), semi ] where target (CmmLit lit) = pprLit lit target fn' = parens (ppr fn') - CmmCall (CmmPrim op) results args srt -> + CmmCall (CmmPrim op) results args safety -> pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv) - results args srt) + results args safety) where lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 66ac9bf..d5a2c69 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -19,6 +19,7 @@ module CgBindery ( nukeVolatileBinds, nukeDeadBindings, getLiveStackSlots, + getLiveStackBindings, bindArgsToStack, rebindToStack, bindNewToNode, bindNewToReg, bindArgsToRegs, @@ -494,3 +495,14 @@ getLiveStackSlots cg_rep = rep } <- varEnvElts binds, isFollowableArg rep] } \end{code} + +\begin{code} +getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)] +getLiveStackBindings + = do { binds <- getBinds + ; return [(off, bind) | + bind <- varEnvElts binds, + CgIdInfo { cg_stb = VirStkLoc off, + cg_rep = rep} <- [bind], + isFollowableArg rep] } +\end{code} diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index b0fab89..34c9bee 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -15,7 +15,7 @@ module CgCallConv ( mkArgDescr, argDescrType, -- Liveness - isBigLiveness, buildContLiveness, mkRegLiveness, + isBigLiveness, mkRegLiveness, smallLiveness, mkLivenessCLit, -- Register assignment @@ -71,7 +71,7 @@ import Data.Bits #include "../includes/StgFun.h" ------------------------- -argDescrType :: ArgDescr -> Int +argDescrType :: ArgDescr -> StgHalfWord -- The "argument type" RTS field type argDescrType (ArgSpec n) = n argDescrType (ArgGen liveness) @@ -98,7 +98,7 @@ argBits [] = [] argBits (PtrArg : args) = False : argBits args argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args -stdPattern :: [CgRep] -> Maybe Int +stdPattern :: [CgRep] -> Maybe StgHalfWord stdPattern [] = Just ARG_NONE -- just void args, probably stdPattern [PtrArg] = Just ARG_P @@ -133,6 +133,14 @@ stdPattern other = Nothing -- ------------------------------------------------------------------------- +-- TODO: This along with 'mkArgDescr' should be unified +-- with 'CmmInfo.mkLiveness'. However that would require +-- potentially invasive changes to the 'ClosureInfo' type. +-- For now, 'CmmInfo.mkLiveness' handles only continuations and +-- this one handles liveness everything else. Another distinction +-- between these two is that 'CmmInfo.mkLiveness' information +-- about the stack layout, and this one is information about +-- the heap layout of PAPs. mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness mkLiveness name size bits | size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word @@ -284,56 +292,6 @@ getSequelAmode ------------------------------------------------------------------------- -- --- Build a liveness mask for the current stack --- -------------------------------------------------------------------------- - --- There are four kinds of things on the stack: --- --- - pointer variables (bound in the environment) --- - non-pointer variables (bound in the environment) --- - free slots (recorded in the stack free list) --- - non-pointer data slots (recorded in the stack free list) --- --- We build up a bitmap of non-pointer slots by searching the environment --- for all the pointer variables, and subtracting these from a bitmap --- with initially all bits set (up to the size of the stack frame). - -buildContLiveness :: Name -- Basis for label (only) - -> [VirtualSpOffset] -- Live stack slots - -> FCode Liveness -buildContLiveness name live_slots - = do { stk_usg <- getStkUsage - ; let StackUsage { realSp = real_sp, - frameSp = frame_sp } = stk_usg - - start_sp :: VirtualSpOffset - start_sp = real_sp - retAddrSizeW - -- In a continuation, we want a liveness mask that - -- starts from just after the return address, which is - -- on the stack at real_sp. - - frame_size :: WordOff - frame_size = start_sp - frame_sp - -- real_sp points to the frame-header for the current - -- stack frame, and the end of this frame is frame_sp. - -- The size is therefore real_sp - frame_sp - retAddrSizeW - -- (subtract one for the frame-header = return address). - - rel_slots :: [WordOff] - rel_slots = sortLe (<=) - [ start_sp - ofs -- Get slots relative to top of frame - | ofs <- live_slots ] - - bitmap = intsToReverseBitmap frame_size rel_slots - - ; WARN( not (all (>=0) rel_slots), - ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots ) - mkLiveness name frame_size bitmap } - - -------------------------------------------------------------------------- --- -- Register assignment -- ------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 2c72860..98e5b0d 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -533,7 +533,7 @@ link_caf cl_info is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] + ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index b2ca5b1..5d84da7 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -116,7 +116,7 @@ emitForeignCall' safety results target args vols srt temp_args <- load_args_into_temps args let (caller_save, caller_load) = callerSaveVolatileRegs vols stmtsC caller_save - stmtC (CmmCall target results temp_args srt) + stmtC (CmmCall target results temp_args CmmUnsafe) stmtsC caller_load | otherwise = do @@ -129,17 +129,20 @@ emitForeignCall' safety results target args vols srt let (caller_save, caller_load) = callerSaveVolatileRegs vols emitSaveThreadState stmtsC caller_save - -- Using the same SRT for each of these is a little bit conservative - -- but it should work for now. + -- The CmmUnsafe arguments are only correct because this part + -- of the code hasn't been moved into the CPS pass yet. + -- Once that happens, this function will just emit a (CmmSafe srt) call, + -- and the CPS will will be the one to convert that + -- to this sequence of three CmmUnsafe calls. stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) [ (id,PtrHint) ] [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] - srt) - stmtC (CmmCall temp_target results temp_args srt) + CmmUnsafe) + stmtC (CmmCall temp_target results temp_args CmmUnsafe) stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) [ (new_base, PtrHint) ] [ (CmmReg (CmmLocal id), PtrHint) ] - srt) + CmmUnsafe) -- Assign the result to BaseReg: we -- might now have a different Capability! stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 6b7fcd5..6d270ae 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -12,10 +12,7 @@ module CgInfoTbls ( dataConTagZ, emitReturnTarget, emitAlgReturnTarget, emitReturnInstr, - mkRetInfoTable, - mkStdInfoTable, stdInfoTableSizeB, - mkFunGenInfoExtraBits, entryCode, closureInfoPtr, getConstrTag, infoTable, infoTableClosureType, @@ -46,6 +43,8 @@ import StaticFlags import Maybes import Constants import Panic +import Util +import Outputable ------------------------------------------------------------------------- -- @@ -53,114 +52,80 @@ import Panic -- ------------------------------------------------------------------------- --- Here we make a concrete info table, represented as a list of CmmAddr --- (it can't be simply a list of Word, because the SRT field is --- represented by a label+offset expression). - --- With tablesNextToCode, the layout is --- --- --- --- --- Without tablesNextToCode, the layout of an info table is --- --- --- --- --- See includes/InfoTables.h +-- Here we make an info table of type 'CmmInfo'. The concrete +-- representation as a list of 'CmmAddr' is handled later +-- in the pipeline by 'cmmToRawCmm'. emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code emitClosureCodeAndInfoTable cl_info args body - = do { ty_descr_lit <- - if opt_SccProfilingOn - then do lit <- mkStringCLit (closureTypeDescr cl_info) - return (makeRelativeRefTo info_lbl lit) - else return (mkIntCLit 0) - ; cl_descr_lit <- - if opt_SccProfilingOn - then do lit <- mkStringCLit cl_descr_string - return (makeRelativeRefTo info_lbl lit) - else return (mkIntCLit 0) - ; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit - cl_type srt_len layout_lit - - ; blks <- cgStmtsToBlocks body - - ; conName <- - if is_con - then do cstr <- mkByteStringCLit $ fromJust conIdentity - return (makeRelativeRefTo info_lbl cstr) - else return (mkIntCLit 0) - - ; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks } + = do { blks <- cgStmtsToBlocks body + ; info <- mkCmmInfo cl_info + ; emitInfoTableAndCode info_lbl info args blks } where info_lbl = infoTableLabelFromCI cl_info - cl_descr_string = closureValDescr cl_info - cl_type = smRepClosureTypeInt (closureSMRep cl_info) - - srt = closureSRT cl_info - needs_srt = needsSRT srt - - mb_con = isConstrClosure_maybe cl_info - is_con = isJust mb_con - - (srt_label,srt_len,conIdentity) - = case mb_con of - Just con -> -- Constructors don't have an SRT - -- We keep the *zero-indexed* tag in the srt_len - -- field of the info table. - (mkIntCLit 0, fromIntegral (dataConTagZ con), - Just $ dataConIdentity con) - - Nothing -> -- Not a constructor - let (label, len) = srtLabelAndLength srt info_lbl - in (label, len, Nothing) - - ptrs = closurePtrsSize cl_info - nptrs = size - ptrs - size = closureNonHdrSize cl_info - layout_lit = packHalfWordsCLit ptrs nptrs - - extra_bits conName - | is_fun = fun_extra_bits - | is_con = [conName] - | needs_srt = [srt_label] - | otherwise = [] - - maybe_fun_stuff = closureFunInfo cl_info - is_fun = isJust maybe_fun_stuff - (Just (arity, arg_descr)) = maybe_fun_stuff - - fun_extra_bits - | ArgGen liveness <- arg_descr - = [ fun_amode, - srt_label, - makeRelativeRefTo info_lbl $ mkLivenessCLit liveness, - slow_entry ] - | needs_srt = [fun_amode, srt_label] - | otherwise = [fun_amode] - - slow_entry = makeRelativeRefTo info_lbl (CmmLabel slow_entry_label) - slow_entry_label = mkSlowEntryLabel (closureName cl_info) - - fun_amode = packHalfWordsCLit fun_type arity - fun_type = argDescrType arg_descr - -- 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 --- A low-level way to generate the variable part of a fun-style info table. --- (must match fun_extra_bits above). Used by the C-- parser. -mkFunGenInfoExtraBits :: Int -> Int -> CmmLit -> CmmLit -> CmmLit -> [CmmLit] -mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry - = [ packHalfWordsCLit fun_type arity, - srt_label, - liveness, - slow_entry ] +-- 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 + (makeRelativeRefTo info_lbl ty_descr_lit) + (makeRelativeRefTo info_lbl 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 prof gc_target cl_type info + + ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureSRT = srt } -> + return $ CmmInfo prof gc_target cl_type info + where + info = + case lf_info of + LFReEntrant _ arity _ arg_descr -> + FunInfo (ptrs, nptrs) + srt + (argDescrType arg_descr) + (fromIntegral arity) + arg_descr + (CmmLabel (mkSlowEntryLabel name)) + LFThunk _ _ _ (SelectorThunk offset) _ -> + ThunkSelectorInfo (fromIntegral offset) srt + LFThunk _ _ _ _ _ -> + ThunkInfo (ptrs, nptrs) srt + _ -> panic "unexpected lambda form in mkCmmInfo" + where + info_lbl = infoTableLabelFromCI cl_info + + cl_type = smRepClosureTypeInt (closureSMRep cl_info) + + ptrs = fromIntegral $ closurePtrsSize cl_info + size = fromIntegral $ closureNonHdrSize cl_info + nptrs = size - ptrs + + -- 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. + -- When the CPS pass is fully integrated, this should + -- be replaced by the label that any heap check jumped to, + -- so that branch can be shared by both the heap (from codeGen) + -- and stack checks (from the CPS pass). + gc_target = panic "TODO: gc_target" ------------------------------------------------------------------------- -- @@ -168,63 +133,134 @@ mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry -- ------------------------------------------------------------------------- --- Here's the layout of a return-point info table --- --- Tables next to code: --- --- --- --- ret-addr --> --- --- Not tables-next-to-code: --- --- ret-addr --> --- --- --- --- * The SRT slot is only there is SRT info to record +-- The concrete representation as a list of 'CmmAddr' is handled later +-- in the pipeline by 'cmmToRawCmm'. emitReturnTarget :: Name -> CgStmts -- The direct-return code (if any) -> FCode CLabel emitReturnTarget name stmts - = do { live_slots <- getLiveStackSlots - ; liveness <- buildContLiveness name live_slots - ; srt_info <- getSRTInfo - - ; let - cl_type | isBigLiveness liveness = rET_BIG - | otherwise = rET_SMALL - - (std_info, extra_bits) = - mkRetInfoTable info_lbl liveness srt_info cl_type - + = do { srt_info <- getSRTInfo ; blks <- cgStmtsToBlocks stmts - ; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks + ; frame <- mkStackLayout + ; let info = CmmInfo + (ProfilingInfo zeroCLit zeroCLit) + gc_target + rET_SMALL -- cmmToRawCmm may convert it to rET_BIG + (ContInfo frame srt_info) + ; emitInfoTableAndCode info_lbl info args blks ; return info_lbl } where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name info_lbl = mkReturnInfoLabel uniq + -- 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. + -- When the CPS pass is fully integrated, this should + -- be replaced by the label that any heap check jumped to, + -- so that branch can be shared by both the heap (from codeGen) + -- and stack checks (from the CPS pass). + gc_target = panic "TODO: gc_target" + -mkRetInfoTable - :: CLabel -- info label - -> Liveness -- liveness - -> C_SRT -- SRT Info - -> StgHalfWord -- type (eg. rET_SMALL) - -> ([CmmLit],[CmmLit]) -mkRetInfoTable info_lbl liveness srt_info cl_type - = (std_info, srt_slot) +-- 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 +-- here to convert from the 'codeGen' representation of the stack +-- to the 'CmmInfo' representation of the stack. +-- +-- See 'CmmInfo.mkLiveness' for where this is converted to a bitmap. + +{- +This seems to be a very error prone part of the code. +It is surprisingly prone to off-by-one errors, because +it converts between offset form (codeGen) and list form (CmmInfo). +Thus a bit of explanation is in order. +Fortunately, this code should go away once the code generator +starts using the CPS conversion pass to handle the stack. + +The stack looks like this: + + | | + |-------------| +frame_sp --> | return addr | + |-------------| + | dead slot | + |-------------| + | live ptr b | + |-------------| + | live ptr a | + |-------------| +real_sp --> | return addr | + +-------------+ + +Both 'frame_sp' and 'real_sp' are measured downwards +(i.e. larger frame_sp means smaller memory address). + +For that frame we want a result like: [Just a, Just b, Nothing] +Note that the 'head' of the list is the top +of the stack, and that the return address +is not present in the list (it is always assumed). +-} +mkStackLayout :: FCode [Maybe LocalReg] +mkStackLayout = do + StackUsage { realSp = real_sp, + frameSp = frame_sp } <- getStkUsage + binds <- getLiveStackBindings + let frame_size = real_sp - frame_sp - retAddrSizeW + rel_binds = reverse $ sortWith fst + [(offset - frame_sp - retAddrSizeW, b) + | (offset, b) <- binds] + + WARN( not (all (\bind -> fst bind >= 0) rel_binds), + ppr binds $$ ppr rel_binds $$ + ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) + return $ stack_layout rel_binds frame_size + +stack_layout :: [(VirtualSpOffset, CgIdInfo)] + -> WordOff + -> [Maybe LocalReg] +stack_layout [] sizeW = replicate sizeW Nothing +stack_layout ((off, bind):binds) sizeW | off == sizeW - 1 = + (Just stack_bind) : (stack_layout binds (sizeW - rep_size)) + where + rep_size = cgRepSizeW (cgIdInfoArgRep bind) + stack_bind = LocalReg unique machRep kind + unique = getUnique (cgIdInfoId bind) + machRep = argMachRep (cgIdInfoArgRep bind) + kind = if isFollowableArg (cgIdInfoArgRep bind) + then KindPtr + else KindNonPtr +stack_layout binds@((off, _):_) sizeW | otherwise = + Nothing : (stack_layout binds (sizeW - 1)) + +{- Another way to write the function that might be less error prone (untested) +stack_layout offsets sizeW = result where - (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl - - srt_slot | needsSRT srt_info = [srt_label] - | otherwise = [] - - liveness_lit = makeRelativeRefTo info_lbl $ mkLivenessCLit liveness - std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit + y = map (flip lookup offsets) [0..] + -- offsets -> nothing and just (each slot is one word) + x = take sizeW y -- set the frame size + z = clip x -- account for multi-word slots + result = map mk_reg z + + clip [] = [] + clip list@(x : _) = x : clip (drop count list) + ASSERT(all isNothing (tail (take count list))) + + count Nothing = 1 + count (Just x) = cgRepSizeW (cgIdInfoArgRep x) + + mk_reg Nothing = Nothing + mk_reg (Just x) = LocalReg unique machRep kind + where + unique = getUnique (cgIdInfoId x) + machRep = argMachrep (cgIdInfoArgRep bind) + kind = if isFollowableArg (cgIdInfoArgRep bind) + then KindPtr + else KindNonPtr +-} emitAlgReturnTarget :: Name -- Just for its unique @@ -250,39 +286,11 @@ emitReturnInstr = do { info_amode <- getSequelAmode ; stmtC (CmmJump (entryCode info_amode) []) } -------------------------------------------------------------------------- --- --- Generating a standard info table +----------------------------------------------------------------------------- -- -------------------------------------------------------------------------- - --- The standard bits of an info table. This part of the info table --- corresponds to the StgInfoTable type defined in InfoTables.h. +-- Info table offsets -- --- Its shape varies with ticky/profiling/tables next to code etc --- so we can't use constant offsets from Constants - -mkStdInfoTable - :: CmmLit -- closure type descr (profiling) - -> CmmLit -- closure descr (profiling) - -> StgHalfWord -- closure type - -> StgHalfWord -- SRT length - -> CmmLit -- layout field - -> [CmmLit] - -mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit - = -- Parallel revertible-black hole field - prof_info - -- Ticky info (none at present) - -- Debug info (none at present) - ++ [layout_lit, type_lit] - - where - prof_info - | opt_SccProfilingOn = [type_descr, closure_descr] - | otherwise = [] - - type_lit = packHalfWordsCLit cl_type srt_len +----------------------------------------------------------------------------- stdInfoTableSizeW :: WordOff -- The size of a standard info table varies with profiling/ticky etc, @@ -402,35 +410,6 @@ emitInfoTableAndCode info_lbl info 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 - -> [CmmBasicBlock] -- ...and body - -> Code - -emitInfoTableAndCode info_lbl std_info extra_bits args blocks - | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc - = emitProc (reverse extra_bits ++ std_info) - entry_lbl args blocks - -- NB: the info_lbl is discarded - - | null blocks -- No actual code; only the info table is significant - = -- Use a zero place-holder in place of the - -- entry-label in the info table - emitRODataLits info_lbl (zeroCLit : std_info ++ extra_bits) - - | otherwise -- Separately emit info table (with the function entry - = -- point as first entry) and the entry code - do { emitDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits) - ; emitProc [] entry_lbl args blocks } - - where - entry_lbl = infoLblToEntryLbl info_lbl --} - ------------------------------------------------------------------------- -- -- Static reference tables diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 3ba9d05..27ee54c 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -257,7 +257,7 @@ enterCostCentreThunk closure = ifProfiling $ do stmtC $ CmmStore curCCSAddr (costCentreFrom closure) -enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] +enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False -- ToDo: vols enter_ccs_fsub = enteringPAP 0 @@ -407,6 +407,7 @@ pushCostCentre result ccs cc = emitRtsCallWithResult result PtrHint SLIT("PushCostCentre") [(ccs,PtrHint), (CmmLit (mkCCostCentre cc), PtrHint)] + False bumpSccCount :: CmmExpr -> CmmStmt bumpSccCount ccs diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 13de213..c48b584 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -269,18 +269,18 @@ emitIfThenElse cond then_part else_part ; labelC join_id } -emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code -emitRtsCall fun args = emitRtsCall' [] fun args Nothing +emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code +emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code -emitRtsCallWithVols fun args vols - = emitRtsCall' [] fun args (Just vols) +emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code +emitRtsCallWithVols fun args vols safe + = emitRtsCall' [] fun args (Just vols) safe emitRtsCallWithResult :: LocalReg -> MachHint -> LitString - -> [(CmmExpr,MachHint)] -> Code -emitRtsCallWithResult res hint fun args - = emitRtsCall' [(res,hint)] fun args Nothing + -> [(CmmExpr,MachHint)] -> Bool -> Code +emitRtsCallWithResult res hint fun args safe + = emitRtsCall' [(res,hint)] fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' @@ -288,12 +288,15 @@ emitRtsCall' -> LitString -> [(CmmExpr,MachHint)] -> Maybe [GlobalReg] + -> Bool -- True <=> CmmSafe call -> Code -emitRtsCall' res fun args vols = do - srt <- getSRTInfo - stmtsC caller_save - stmtC (CmmCall target res args srt) - stmtsC caller_load +emitRtsCall' res fun args vols safe = do + safety <- if safe + then getSRTInfo >>= (return . CmmSafe) + else return CmmUnsafe + stmtsC caller_save + stmtC (CmmCall target res args safety) + stmtsC caller_load where (caller_save, caller_load) = callerSaveVolatileRegs vols target = CmmForeignCall fun_expr CCallConv diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index ad26b2e..db46368 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -13,8 +13,9 @@ the STG paper. \begin{code} module ClosureInfo ( - ClosureInfo, LambdaFormInfo, SMRep, -- all abstract - StandardFormInfo, + ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but + StandardFormInfo(..), -- mkCmmInfo looks inside + SMRep, ArgDescr(..), Liveness(..), C_SRT(..), needsSRT, @@ -188,7 +189,7 @@ data LambdaFormInfo data ArgDescr = ArgSpec -- Fits one of the standard patterns - !Int -- RTS type identifier ARG_P, ARG_N, ... + !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ... | ArgGen -- General case Liveness -- Details about the arguments @@ -957,5 +958,3 @@ getTyDescription ty getPredTyDescription (ClassP cl tys) = getOccString cl getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} - - diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 0ae942c..f0fd95d 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -76,6 +76,7 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CmmParse ( parseCmmFile ) import CmmCPS +import CmmInfo import CodeOutput ( codeOutput ) import NameEnv ( emptyNameEnv ) @@ -605,7 +606,8 @@ hscCompile cgguts foreign_stubs dir_imps cost_centre_info stg_binds hpc_info ------------------ Convert to CPS -------------------- - continuationC <- {-return abstractC-} cmmCPS dflags abstractC + --continuationC <- cmmCPS dflags abstractC + continuationC <- cmmToRawCmm abstractC ------------------ Code output ----------------------- (stub_h_exists,stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs @@ -721,7 +723,8 @@ hscCmmFile dflags filename = do case maybe_cmm of Nothing -> return False Just cmm -> do - continuationC <- {-return [cmm]-} cmmCPS dflags [cmm] + --continuationC <- cmmCPS dflags [cmm] + continuationC <- cmmToRawCmm [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 f954d52..a04c5c7 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -429,9 +429,6 @@ fixAssigns stmts = returnUs (concat stmtss) fixAssign :: CmmStmt -> UniqSM [CmmStmt] -fixAssign (CmmAssign (CmmGlobal BaseReg) src) - = panic "cmmStmtConFold: assignment to BaseReg"; - fixAssign (CmmAssign (CmmGlobal reg) src) | Left realreg <- reg_or_addr = returnUs [CmmAssign (CmmGlobal reg) src] @@ -444,24 +441,6 @@ fixAssign (CmmAssign (CmmGlobal reg) src) where reg_or_addr = get_GlobalReg_reg_or_addr reg -{- -fixAssign (CmmCall target results args) - = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) -> - returnUs (CmmCall target results' args : - concat stores) - where - fixResult g@(CmmGlobal reg,hint) = - case get_GlobalReg_reg_or_addr reg of - Left realreg -> returnUs (g, []) - Right baseRegAddr -> - getUniqueUs `thenUs` \ uq -> - let local = CmmLocal (LocalReg uq (globalRegRep reg)) in - returnUs ((local,hint), - [CmmStore baseRegAddr (CmmReg local)]) - fixResult other = - returnUs (other,[]) --} - fixAssign other_stmt = returnUs [other_stmt] -- ----------------------------------------------------------------------------- diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index 154eed8..1d1cfa1 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -3182,13 +3182,13 @@ outOfLineFloatOp mop res args if localRegRep res == F64 then - stmtToInstrs (CmmCall target [(res,FloatHint)] args NoC_SRT) + stmtToInstrs (CmmCall target [(res,FloatHint)] args CmmUnsafe) else do uq <- getUniqueNat let tmp = LocalReg uq F64 KindNonPtr -- in - code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args NoC_SRT) + code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args CmmUnsafe) code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where diff --git a/includes/Cmm.h b/includes/Cmm.h index c238a84..b23a37b 100644 --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -524,7 +524,7 @@ __bd = W_[mut_list]; \ if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \ W_ __new_bd; \ - "ptr" __new_bd = foreign "C" allocBlock_lock() [regs]; \ + ("ptr" __new_bd) = foreign "C" allocBlock_lock() [regs]; \ bdescr_link(__new_bd) = __bd; \ __bd = __new_bd; \ W_[mut_list] = __bd; \ diff --git a/rts/Exception.cmm b/rts/Exception.cmm index 346c949..a0a6db4 100644 --- a/rts/Exception.cmm +++ b/rts/Exception.cmm @@ -47,8 +47,7 @@ -------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, - 0/*framesize*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, RET_SMALL ) { CInt r; @@ -73,7 +72,7 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, Sp_adj(1); #endif SAVE_THREAD_STATE(); - r = foreign "C" maybePerformBlockedException (MyCapability() "ptr", + (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", CurrentTSO "ptr") [R1]; if (r != 0::CInt) { @@ -106,8 +105,7 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, #endif } -INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret, - 0/*framesize*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret, RET_SMALL ) { StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32; @@ -165,7 +163,7 @@ unblockAsyncExceptionszh_fast * thread, which might result in the thread being killed. */ SAVE_THREAD_STATE(); - r = foreign "C" maybePerformBlockedException (MyCapability() "ptr", + (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", CurrentTSO "ptr") [R1]; if (r != 0::CInt) { @@ -229,7 +227,7 @@ killThreadzh_fast W_ retcode; out = BaseReg + OFFSET_StgRegTable_rmp_tmp_w; - retcode = foreign "C" throwTo(MyCapability() "ptr", + (retcode) = foreign "C" throwTo(MyCapability() "ptr", CurrentTSO "ptr", target "ptr", exception "ptr", @@ -260,22 +258,16 @@ killThreadzh_fast #define SP_OFF 1 #endif -#if defined(PROFILING) -#define CATCH_FRAME_BITMAP 7 -#define CATCH_FRAME_WORDS 4 -#else -#define CATCH_FRAME_BITMAP 1 -#define CATCH_FRAME_WORDS 2 -#endif - /* Catch frames are very similar to update frames, but when entering * one we just pop the frame off the stack and perform the correct * kind of return to the activation record underneath us on the stack. */ -INFO_TABLE_RET(stg_catch_frame, - CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP, - CATCH_FRAME) +INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME, +#if defined(PROFILING) + W_ unused1, W_ unused2, +#endif + W_ unused3, "ptr" W_ unused4) #ifdef REG_R1 { Sp = Sp + SIZEOF_StgCatchFrame; @@ -347,7 +339,7 @@ section "data" { no_break_on_exception: W_[1]; } -INFO_TABLE_RET(stg_raise_ret, 1, 0, RET_SMALL) +INFO_TABLE_RET(stg_raise_ret, RET_SMALL, "ptr" W_ arg1) { R1 = Sp(1); Sp = Sp + WDS(2); @@ -377,7 +369,7 @@ raisezh_fast retry_pop_stack: StgTSO_sp(CurrentTSO) = Sp; - frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") []; + (frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") []; Sp = StgTSO_sp(CurrentTSO); if (frame_type == ATOMICALLY_FRAME) { /* The exception has reached the edge of a memory transaction. Check that @@ -391,8 +383,8 @@ retry_pop_stack: W_ trec, outer; W_ r; trec = StgTSO_trec(CurrentTSO); - r = foreign "C" stmValidateNestOfTransactions(trec "ptr") []; - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + (r) = foreign "C" stmValidateNestOfTransactions(trec "ptr") []; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") []; foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") []; @@ -409,7 +401,7 @@ retry_pop_stack: } else { // Transaction was not valid: we retry the exception (otherwise continue // with a further call to raiseExceptionHelper) - "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") []; + ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") []; StgTSO_trec(CurrentTSO) = trec; R1 = StgAtomicallyFrame_code(Sp); jump stg_ap_v_fast; @@ -433,7 +425,7 @@ retry_pop_stack: // for exmplae. Perhaps the stop_on_exception flag should // be per-thread. W_[rts_stop_on_exception] = 0; - "ptr" ioAction = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") []; + ("ptr" ioAction) = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") []; Sp = Sp - WDS(6); Sp(5) = exception; Sp(4) = stg_raise_ret_info; @@ -491,7 +483,7 @@ retry_pop_stack: } else { W_ trec, outer; trec = StgTSO_trec(CurrentTSO); - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") []; foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") []; StgTSO_trec(CurrentTSO) = outer; diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index e9ddf5b..75f1418 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -108,7 +108,7 @@ There are canned sequences for 'n' pointer values in registers. -------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_enter, 1/*framesize*/, 0/*bitmap*/, RET_SMALL) +INFO_TABLE_RET( stg_enter, RET_SMALL, "ptr" W_ unused) { R1 = Sp(1); Sp_adj(2); @@ -430,7 +430,7 @@ stg_gc_noregs /*-- void return ------------------------------------------------------------ */ -INFO_TABLE_RET( stg_gc_void, 0/*framesize*/, 0/*bitmap*/, RET_SMALL) +INFO_TABLE_RET( stg_gc_void, RET_SMALL) { Sp_adj(1); jump %ENTRY_CODE(Sp(0)); @@ -438,7 +438,7 @@ INFO_TABLE_RET( stg_gc_void, 0/*framesize*/, 0/*bitmap*/, RET_SMALL) /*-- R1 is boxed/unpointed -------------------------------------------------- */ -INFO_TABLE_RET( stg_gc_unpt_r1, 1/*framesize*/, 0/*bitmap*/, RET_SMALL) +INFO_TABLE_RET( stg_gc_unpt_r1, RET_SMALL, "ptr" W_ unused) { R1 = Sp(1); Sp_adj(2); @@ -456,7 +456,7 @@ stg_gc_unpt_r1 /*-- R1 is unboxed -------------------------------------------------- */ /* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */ -INFO_TABLE_RET( stg_gc_unbx_r1, 1/*framesize*/, 1/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_gc_unbx_r1, RET_SMALL, W_ unused ) { R1 = Sp(1); Sp_adj(2); @@ -473,7 +473,7 @@ stg_gc_unbx_r1 /*-- F1 contains a float ------------------------------------------------- */ -INFO_TABLE_RET( stg_gc_f1, 1/*framesize*/, 1/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_gc_f1, RET_SMALL, F_ unused ) { F1 = F_[Sp+WDS(1)]; Sp_adj(2); @@ -490,17 +490,7 @@ stg_gc_f1 /*-- D1 contains a double ------------------------------------------------- */ -/* we support doubles of either 1 or 2 words in size */ - -#if SIZEOF_DOUBLE == SIZEOF_VOID_P -# define DBL_BITMAP 1 -# define DBL_WORDS 1 -#else -# define DBL_BITMAP 3 -# define DBL_WORDS 2 -#endif - -INFO_TABLE_RET( stg_gc_d1, DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_gc_d1, RET_SMALL, D_ unused ) { D1 = D_[Sp + WDS(1)]; Sp = Sp + WDS(1) + SIZEOF_StgDouble; @@ -518,17 +508,7 @@ stg_gc_d1 /*-- L1 contains an int64 ------------------------------------------------- */ -/* we support int64s of either 1 or 2 words in size */ - -#if SIZEOF_VOID_P == 8 -# define LLI_BITMAP 1 -# define LLI_WORDS 1 -#else -# define LLI_BITMAP 3 -# define LLI_WORDS 2 -#endif - -INFO_TABLE_RET( stg_gc_l1, LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_gc_l1, RET_SMALL, L_ unused ) { L1 = L_[Sp + WDS(1)]; Sp_adj(1) + SIZEOF_StgWord64; @@ -545,7 +525,7 @@ stg_gc_l1 /*-- Unboxed tuple return, one pointer (unregisterised build only) ---------- */ -INFO_TABLE_RET( stg_ut_1_0_unreg, 1/*size*/, 0/*BITMAP*/, RET_SMALL ) +INFO_TABLE_RET( stg_ut_1_0_unreg, RET_SMALL, "ptr" W_ unused ) { Sp_adj(1); // one ptr is on the stack (Sp(0)) @@ -642,7 +622,7 @@ __stg_gc_fun appropriately. The stack layout is given above. -------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_gc_fun, 0/*framesize*/, 0/*bitmap*/, RET_FUN ) +INFO_TABLE_RET( stg_gc_fun, RET_FUN ) { R1 = Sp(2); Sp_adj(3); @@ -729,7 +709,7 @@ INFO_TABLE_RET( stg_gc_fun, 0/*framesize*/, 0/*bitmap*/, RET_FUN ) Sp(1) = R9; /* liveness mask */ \ Sp(0) = stg_gc_gen_info; -INFO_TABLE_RET( stg_gc_gen, 0/*framesize*/, 0/*bitmap*/, RET_DYN ) +INFO_TABLE_RET( stg_gc_gen, RET_DYN ) /* bitmap in the above info table is unused, the real one is on the stack. */ { RESTORE_EVERYTHING; @@ -830,7 +810,7 @@ stg_block_1 * * -------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_block_takemvar, 1/*framesize*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_block_takemvar, RET_SMALL, "ptr" W_ unused ) { R1 = Sp(1); Sp_adj(2); @@ -855,7 +835,7 @@ stg_block_takemvar BLOCK_BUT_FIRST(stg_block_takemvar_finally); } -INFO_TABLE_RET( stg_block_putmvar, 2/*framesize*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, "ptr" W_ unused1, "ptr" W_ unused2 ) { R2 = Sp(2); R1 = Sp(1); @@ -902,7 +882,7 @@ stg_block_blackhole BLOCK_BUT_FIRST(stg_block_blackhole_finally); } -INFO_TABLE_RET( stg_block_throwto, 2/*framesize*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_block_throwto, RET_SMALL, "ptr" W_ unused, "ptr" W_ unused ) { R2 = Sp(2); R1 = Sp(1); @@ -928,7 +908,7 @@ stg_block_throwto } #ifdef mingw32_HOST_OS -INFO_TABLE_RET( stg_block_async, 0/*framesize*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_block_async, RET_SMALL ) { W_ ares; W_ len, errC; diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 800f93e..ad761ab 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -49,7 +49,7 @@ newByteArrayzh_fast n = R1; payload_words = ROUNDUP_BYTES_TO_WDS(n); words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words; - "ptr" p = foreign "C" allocateLocal(MyCapability() "ptr",words) []; + ("ptr" p) = foreign "C" allocateLocal(MyCapability() "ptr",words) []; TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0); SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]); StgArrWords_words(p) = payload_words; @@ -73,7 +73,7 @@ newPinnedByteArrayzh_fast words = words + 1; } - "ptr" p = foreign "C" allocatePinned(words) []; + ("ptr" p) = foreign "C" allocatePinned(words) []; TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0); // Again, if the ArrWords header isn't a multiple of 8 bytes, we @@ -97,7 +97,7 @@ newArrayzh_fast MAYBE_GC(R2_PTR,newArrayzh_fast); words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + n; - "ptr" arr = foreign "C" allocateLocal(MyCapability() "ptr",words) [R2]; + ("ptr" arr) = foreign "C" allocateLocal(MyCapability() "ptr",words) [R2]; TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0); SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]); @@ -676,7 +676,7 @@ gcdIntzh_fast FETCH_MP_TEMP(mp_tmp_w); W_[mp_tmp_w] = R1; - r = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) []; + (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) []; R1 = r; /* Result parked in R1, return via info-pointer at TOS */ @@ -687,7 +687,9 @@ gcdIntzh_fast gcdIntegerIntzh_fast { /* R1 = s1; R2 = d1; R3 = the int */ - R1 = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) []; + W_ s1; + (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) []; + R1 = s1; /* Result parked in R1, return via info-pointer at TOS */ jump %ENTRY_CODE(Sp(0)); @@ -768,7 +770,7 @@ cmpIntegerzh_fast up = BYTE_ARR_CTS(R2); vp = BYTE_ARR_CTS(R4); - cmp = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) []; + (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) []; if (cmp == 0 :: CInt) { R1 = 0; @@ -891,7 +893,7 @@ forkzh_fast W_ threadid; closure = R1; - "ptr" threadid = foreign "C" createIOThread( MyCapability() "ptr", + ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr") []; foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") []; @@ -914,7 +916,7 @@ forkOnzh_fast cpu = R1; closure = R2; - "ptr" threadid = foreign "C" createIOThread( MyCapability() "ptr", + ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr") []; foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") []; @@ -951,7 +953,7 @@ isCurrentThreadBoundzh_fast { /* no args */ W_ r; - r = foreign "C" isThreadBound(CurrentTSO) []; + (r) = foreign "C" isThreadBound(CurrentTSO) []; RET_N(r); } @@ -970,25 +972,19 @@ isCurrentThreadBoundzh_fast // Catch retry frame ------------------------------------------------------------ +INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME, #if defined(PROFILING) -#define CATCH_RETRY_FRAME_BITMAP 7 -#define CATCH_RETRY_FRAME_WORDS 5 -#else -#define CATCH_RETRY_FRAME_BITMAP 1 -#define CATCH_RETRY_FRAME_WORDS 3 + W_ unused1, W_ unused2, #endif - -INFO_TABLE_RET(stg_catch_retry_frame, - CATCH_RETRY_FRAME_WORDS, CATCH_RETRY_FRAME_BITMAP, - CATCH_RETRY_FRAME) + W_ unused3, "ptr" W_ unused4, "ptr" W_ unused5) { W_ r, frame, trec, outer; IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); ) frame = Sp; trec = StgTSO_trec(CurrentTSO); - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; - r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") []; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") []; if (r != 0) { /* Succeeded (either first branch or second branch) */ StgTSO_trec(CurrentTSO) = outer; @@ -998,7 +994,7 @@ INFO_TABLE_RET(stg_catch_retry_frame, } else { /* Did not commit: re-execute */ W_ new_trec; - "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; + ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; StgTSO_trec(CurrentTSO) = new_trec; if (StgCatchRetryFrame_running_alt_code(frame) != 0::I32) { R1 = StgCatchRetryFrame_alt_code(frame); @@ -1012,28 +1008,22 @@ INFO_TABLE_RET(stg_catch_retry_frame, // Atomically frame ------------------------------------------------------------ +INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME, #if defined(PROFILING) -#define ATOMICALLY_FRAME_BITMAP 3 -#define ATOMICALLY_FRAME_WORDS 4 -#else -#define ATOMICALLY_FRAME_BITMAP 0 -#define ATOMICALLY_FRAME_WORDS 2 + W_ unused1, W_ unused2, #endif - -INFO_TABLE_RET(stg_atomically_frame, - ATOMICALLY_FRAME_WORDS, ATOMICALLY_FRAME_BITMAP, - ATOMICALLY_FRAME) + "ptr" W_ unused3, "ptr" W_ unused4) { W_ frame, trec, valid, next_invariant, q, outer; IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); ) frame = Sp; trec = StgTSO_trec(CurrentTSO); - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; if (outer == NO_TREC) { /* First time back at the atomically frame -- pick up invariants */ - "ptr" q = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") []; + ("ptr" q) = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") []; StgAtomicallyFrame_next_invariant_to_check(frame) = q; } else { @@ -1054,7 +1044,7 @@ INFO_TABLE_RET(stg_atomically_frame, if (q != END_INVARIANT_CHECK_QUEUE) { /* We can't commit yet: another invariant to check */ - "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") []; + ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") []; StgTSO_trec(CurrentTSO) = trec; next_invariant = StgInvariantCheckQueue_invariant(q); @@ -1064,7 +1054,7 @@ INFO_TABLE_RET(stg_atomically_frame, } else { /* We've got no more invariants to check, try to commit */ - valid = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") []; + (valid) = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") []; if (valid != 0) { /* Transaction was valid: commit succeeded */ StgTSO_trec(CurrentTSO) = NO_TREC; @@ -1073,7 +1063,7 @@ INFO_TABLE_RET(stg_atomically_frame, jump %ENTRY_CODE(Sp(SP_OFF)); } else { /* Transaction was not valid: try again */ - "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") []; + ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") []; StgTSO_trec(CurrentTSO) = trec; StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE; R1 = StgAtomicallyFrame_code(frame); @@ -1082,9 +1072,11 @@ INFO_TABLE_RET(stg_atomically_frame, } } -INFO_TABLE_RET(stg_atomically_waiting_frame, - ATOMICALLY_FRAME_WORDS, ATOMICALLY_FRAME_BITMAP, - ATOMICALLY_FRAME) +INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME, +#if defined(PROFILING) + W_ unused1, W_ unused2, +#endif + "ptr" W_ unused3, "ptr" W_ unused4) { W_ frame, trec, valid; IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); ) @@ -1092,7 +1084,7 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, frame = Sp; /* The TSO is currently waiting: should we stop waiting? */ - valid = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") []; + (valid) = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") []; if (valid != 0) { /* Previous attempt is still valid: no point trying again yet */ IF_NOT_REG_R1(Sp_adj(-2); @@ -1101,7 +1093,7 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, jump stg_block_noregs; } else { /* Previous attempt is no longer valid: try again */ - "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") []; + ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") []; StgTSO_trec(CurrentTSO) = trec; StgHeader_info(frame) = stg_atomically_frame_info; R1 = StgAtomicallyFrame_code(frame); @@ -1117,29 +1109,23 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, #define SP_OFF 1 #endif -#if defined(PROFILING) -#define CATCH_STM_FRAME_BITMAP 3 -#define CATCH_STM_FRAME_WORDS 4 -#else -#define CATCH_STM_FRAME_BITMAP 0 -#define CATCH_STM_FRAME_WORDS 2 -#endif - /* Catch frames are very similar to update frames, but when entering * one we just pop the frame off the stack and perform the correct * kind of return to the activation record underneath us on the stack. */ -INFO_TABLE_RET(stg_catch_stm_frame, - CATCH_STM_FRAME_WORDS, CATCH_STM_FRAME_BITMAP, - CATCH_STM_FRAME) +INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME, +#if defined(PROFILING) + W_ unused1, W_ unused2, +#endif + "ptr" W_ unused3, "ptr" W_ unused4) { IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); ) W_ r, frame, trec, outer; frame = Sp; trec = StgTSO_trec(CurrentTSO); - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; - r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") []; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") []; if (r != 0) { /* Commit succeeded */ StgTSO_trec(CurrentTSO) = outer; @@ -1149,7 +1135,7 @@ INFO_TABLE_RET(stg_catch_stm_frame, } else { /* Commit failed */ W_ new_trec; - "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; + ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; StgTSO_trec(CurrentTSO) = new_trec; R1 = StgCatchSTMFrame_code(frame); jump stg_ap_v_fast; @@ -1188,7 +1174,7 @@ atomicallyzh_fast StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE; /* Start the memory transcation */ - "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1]; + ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1]; StgTSO_trec(CurrentTSO) = new_trec; /* Apply R1 to the realworld token */ @@ -1216,7 +1202,7 @@ catchSTMzh_fast W_ cur_trec; W_ new_trec; cur_trec = StgTSO_trec(CurrentTSO); - "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr"); + ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr"); StgTSO_trec(CurrentTSO) = new_trec; /* Apply R1 to the realworld token */ @@ -1239,7 +1225,7 @@ catchRetryzh_fast /* Start a nested transaction within which to run the first code */ trec = StgTSO_trec(CurrentTSO); - "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2]; + ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2]; StgTSO_trec(CurrentTSO) = new_trec; /* Set up the catch-retry frame */ @@ -1269,11 +1255,11 @@ retryzh_fast // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME retry_pop_stack: StgTSO_sp(CurrentTSO) = Sp; - frame_type = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") []; + (frame_type) = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") []; Sp = StgTSO_sp(CurrentTSO); frame = Sp; trec = StgTSO_trec(CurrentTSO); - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; if (frame_type == CATCH_RETRY_FRAME) { // The retry reaches a CATCH_RETRY_FRAME before the atomic frame @@ -1283,7 +1269,7 @@ retry_pop_stack: foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") []; if (!StgCatchRetryFrame_running_alt_code(frame) != 0::I32) { // Retry in the first branch: try the alternative - "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; + ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; StgTSO_trec(CurrentTSO) = trec; StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true; R1 = StgCatchRetryFrame_alt_code(frame); @@ -1305,12 +1291,12 @@ retry_pop_stack: foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") []; foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") []; trec = outer; - StgTSO_trec(CurrentTSO) = trec; - "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") []; + StgTSO_trec(CurrentTSO) = trec; + ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") []; } ASSERT(outer == NO_TREC); - r = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr") []; + (r) = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr") []; if (r != 0) { // Transaction was valid: stmWait put us on the TVars' queues, we now block StgHeader_info(frame) = stg_atomically_waiting_frame_info; @@ -1323,7 +1309,7 @@ retry_pop_stack: jump stg_block_stmwait; } else { // Transaction was not valid: retry immediately - "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; + ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") []; StgTSO_trec(CurrentTSO) = trec; R1 = StgAtomicallyFrame_code(frame); Sp = frame; @@ -1358,7 +1344,7 @@ newTVarzh_fast MAYBE_GC (R1_PTR, newTVarzh_fast); new_value = R1; - "ptr" tv = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") []; + ("ptr" tv) = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") []; RET_P(tv); } @@ -1374,7 +1360,7 @@ readTVarzh_fast MAYBE_GC (R1_PTR, readTVarzh_fast); // Call to stmReadTVar may allocate trec = StgTSO_trec(CurrentTSO); tvar = R1; - "ptr" result = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") []; + ("ptr" result) = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") []; RET_P(result); } @@ -1481,7 +1467,7 @@ takeMVarzh_fast mvar = R1; #if defined(THREADED_RTS) - "ptr" info = foreign "C" lockClosure(mvar "ptr") []; + ("ptr" info) = foreign "C" lockClosure(mvar "ptr") []; #else info = GET_INFO(mvar); #endif @@ -1520,10 +1506,10 @@ takeMVarzh_fast #if defined(GRAN) || defined(PAR) /* ToDo: check 2nd arg (mvar) is right */ - "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar) []; + ("ptr" tso) = foreign "C" unblockOne(StgMVar_head(mvar),mvar) []; StgMVar_head(mvar) = tso; #else - "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", + ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") []; StgMVar_head(mvar) = tso; #endif @@ -1562,7 +1548,7 @@ tryTakeMVarzh_fast mvar = R1; #if defined(THREADED_RTS) - "ptr" info = foreign "C" lockClosure(mvar "ptr") []; + ("ptr" info) = foreign "C" lockClosure(mvar "ptr") []; #else info = GET_INFO(mvar); #endif @@ -1594,10 +1580,10 @@ tryTakeMVarzh_fast #if defined(GRAN) || defined(PAR) /* ToDo: check 2nd arg (mvar) is right */ - "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") []; + ("ptr" tso) = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") []; StgMVar_head(mvar) = tso; #else - "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", + ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") []; StgMVar_head(mvar) = tso; #endif @@ -1632,7 +1618,7 @@ putMVarzh_fast mvar = R1; #if defined(THREADED_RTS) - "ptr" info = foreign "C" lockClosure(mvar "ptr") [R2]; + ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [R2]; #else info = GET_INFO(mvar); #endif @@ -1664,10 +1650,10 @@ putMVarzh_fast #if defined(GRAN) || defined(PAR) /* ToDo: check 2nd arg (mvar) is right */ - "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") []; + ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") []; StgMVar_head(mvar) = tso; #else - "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") []; + ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") []; StgMVar_head(mvar) = tso; #endif @@ -1705,7 +1691,7 @@ tryPutMVarzh_fast mvar = R1; #if defined(THREADED_RTS) - "ptr" info = foreign "C" lockClosure(mvar "ptr") [R2]; + ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [R2]; #else info = GET_INFO(mvar); #endif @@ -1730,10 +1716,10 @@ tryPutMVarzh_fast #if defined(GRAN) || defined(PAR) /* ToDo: check 2nd arg (mvar) is right */ - "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") []; + ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") []; StgMVar_head(mvar) = tso; #else - "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") []; + ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") []; StgMVar_head(mvar) = tso; #endif @@ -1772,7 +1758,7 @@ makeStableNamezh_fast ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast ); - index = foreign "C" lookupStableName(R1 "ptr") []; + (index) = foreign "C" lookupStableName(R1 "ptr") []; /* Is there already a StableName for this heap object? * stable_ptr_table is a pointer to an array of snEntry structs. @@ -1795,7 +1781,7 @@ makeStablePtrzh_fast /* Args: R1 = a */ W_ sp; MAYBE_GC(R1_PTR, makeStablePtrzh_fast); - "ptr" sp = foreign "C" getStablePtr(R1 "ptr") []; + ("ptr" sp) = foreign "C" getStablePtr(R1 "ptr") []; RET_N(sp); } @@ -2010,7 +1996,7 @@ delayzh_fast #ifdef mingw32_HOST_OS /* could probably allocate this on the heap instead */ - "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult, + ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult, stg_delayzh_malloc_str); reqID = foreign "C" addDelayRequest(R1); StgAsyncIOResult_reqID(ares) = reqID; @@ -2030,7 +2016,7 @@ delayzh_fast W_ time; W_ divisor; - time = foreign "C" getourtimeofday() [R1]; + (time) = foreign "C" getourtimeofday() [R1]; divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags))*1000; target = ((R1 + divisor - 1) / divisor) /* divide rounding up */ + time + 1; /* Add 1 as getourtimeofday rounds down */ diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index e532e51..e092e3f 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -57,9 +57,7 @@ stg_interp_constr_entry haven't got a good story about that yet. */ -INFO_TABLE_RET( stg_ctoi_R1p, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO) +INFO_TABLE_RET( stg_ctoi_R1p, RET_BCO) { Sp_adj(-2); Sp(1) = R1; @@ -70,9 +68,7 @@ INFO_TABLE_RET( stg_ctoi_R1p, /* * When the returned value is a pointer, but unlifted, in R1 ... */ -INFO_TABLE_RET( stg_ctoi_R1unpt, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_ctoi_R1unpt, RET_BCO ) { Sp_adj(-2); Sp(1) = R1; @@ -83,9 +79,7 @@ INFO_TABLE_RET( stg_ctoi_R1unpt, /* * When the returned value is a non-pointer in R1 ... */ -INFO_TABLE_RET( stg_ctoi_R1n, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_ctoi_R1n, RET_BCO ) { Sp_adj(-2); Sp(1) = R1; @@ -96,9 +90,7 @@ INFO_TABLE_RET( stg_ctoi_R1n, /* * When the returned value is in F1 */ -INFO_TABLE_RET( stg_ctoi_F1, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_ctoi_F1, RET_BCO ) { Sp_adj(-2); F_[Sp + WDS(1)] = F1; @@ -109,9 +101,7 @@ INFO_TABLE_RET( stg_ctoi_F1, /* * When the returned value is in D1 */ -INFO_TABLE_RET( stg_ctoi_D1, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_ctoi_D1, RET_BCO ) { Sp_adj(-1) - SIZEOF_DOUBLE; D_[Sp + WDS(1)] = D1; @@ -122,9 +112,7 @@ INFO_TABLE_RET( stg_ctoi_D1, /* * When the returned value is in L1 */ -INFO_TABLE_RET( stg_ctoi_L1, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_ctoi_L1, RET_BCO ) { Sp_adj(-1) - 8; L_[Sp + WDS(1)] = L1; @@ -135,9 +123,7 @@ INFO_TABLE_RET( stg_ctoi_L1, /* * When the returned value is a void */ -INFO_TABLE_RET( stg_ctoi_V, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_ctoi_V, RET_BCO ) { Sp_adj(-1); Sp(0) = stg_gc_void_info; @@ -149,9 +135,7 @@ INFO_TABLE_RET( stg_ctoi_V, * should apply the BCO on the stack to its arguments, also on the * stack. */ -INFO_TABLE_RET( stg_apply_interp, - 0/*size*/, 0/*bitmap*/, /* special layout! */ - RET_BCO ) +INFO_TABLE_RET( stg_apply_interp, RET_BCO ) { /* Just in case we end up in here... (we shouldn't) */ jump stg_yield_to_interpreter; diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm index 2d83a67..5b0f7e2 100644 --- a/rts/StgStartup.cmm +++ b/rts/StgStartup.cmm @@ -36,16 +36,12 @@ Returning from the STG world. -------------------------------------------------------------------------- */ +INFO_TABLE_RET( stg_stop_thread, STOP_FRAME, #if defined(PROFILING) -#define STOP_THREAD_BITMAP 3 -#define STOP_THREAD_WORDS 2 -#else -#define STOP_THREAD_BITMAP 0 -#define STOP_THREAD_WORDS 0 + W_ unused, + W_ unused #endif - -INFO_TABLE_RET( stg_stop_thread, STOP_THREAD_WORDS, STOP_THREAD_BITMAP, - STOP_FRAME) +) { /* The final exit. @@ -148,7 +144,7 @@ stg_threadFinished results that comes back. ------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_forceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL) +INFO_TABLE_RET( stg_forceIO, RET_SMALL) #ifdef REG_R1 { @@ -172,7 +168,7 @@ INFO_TABLE_RET( stg_forceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL) is a register or not. ------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_noforceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL ) +INFO_TABLE_RET( stg_noforceIO, RET_SMALL ) #ifdef REG_R1 { diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm index 342a6eb..db9c254 100644 --- a/rts/StgStdThunks.cmm +++ b/rts/StgStdThunks.cmm @@ -32,17 +32,15 @@ #ifdef PROFILING #define SAVE_CCCS(fs) StgHeader_ccs(Sp-fs) = W_[CCCS] #define GET_SAVED_CCCS W_[CCCS] = StgHeader_ccs(Sp) -#define RET_BITMAP 3 -#define RET_FRAMESIZE 2 +#define RET_PARAMS W_ unused1, W_ unused2 #else #define SAVE_CCCS(fs) /* empty */ #define GET_SAVED_CCCS /* empty */ -#define RET_BITMAP 0 -#define RET_FRAMESIZE 0 +#define RET_PARAMS #endif #define SELECTOR_CODE_UPD(offset) \ - INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_FRAMESIZE, RET_BITMAP, RET_SMALL) \ + INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_SMALL, RET_PARAMS) \ { \ R1 = StgClosure_payload(R1,offset); \ GET_SAVED_CCCS; \ @@ -85,7 +83,7 @@ SELECTOR_CODE_UPD(14) SELECTOR_CODE_UPD(15) #define SELECTOR_CODE_NOUPD(offset) \ - INFO_TABLE_RET(stg_sel_ret_##offset##_noupd, RET_FRAMESIZE, RET_BITMAP, RET_SMALL) \ + INFO_TABLE_RET(stg_sel_ret_##offset##_noupd, RET_SMALL, RET_PARAMS) \ { \ R1 = StgClosure_payload(R1,offset); \ GET_SAVED_CCCS; \ diff --git a/rts/Updates.cmm b/rts/Updates.cmm index a9f25b7..7ebade0 100644 --- a/rts/Updates.cmm +++ b/rts/Updates.cmm @@ -45,11 +45,9 @@ } #if defined(PROFILING) -#define UPD_FRAME_BITMAP 3 -#define UPD_FRAME_WORDS 3 +#define UPD_FRAME_PARAMS W_ unused1, W_ unused2, "ptr" W_ unused3 #else -#define UPD_FRAME_BITMAP 0 -#define UPD_FRAME_WORDS 1 +#define UPD_FRAME_PARAMS "ptr" W_ unused1 #endif /* this bitmap indicates that the first word of an update frame is a @@ -57,11 +55,9 @@ * there's a cost-centre-stack in there too). */ -INFO_TABLE_RET( stg_upd_frame, - UPD_FRAME_WORDS, UPD_FRAME_BITMAP, UPDATE_FRAME) +INFO_TABLE_RET( stg_upd_frame, UPDATE_FRAME, UPD_FRAME_PARAMS) UPD_FRAME_ENTRY_TEMPLATE -INFO_TABLE_RET( stg_marked_upd_frame, - UPD_FRAME_WORDS, UPD_FRAME_BITMAP, UPDATE_FRAME) +INFO_TABLE_RET( stg_marked_upd_frame, UPDATE_FRAME, UPD_FRAME_PARAMS) UPD_FRAME_ENTRY_TEMPLATE diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index 1a03140..b7cc6dd 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -336,6 +336,18 @@ genMkPAP regstatus macro jump ticker disamb -- generate an apply function -- args is a list of 'p', 'n', 'f', 'd' or 'l' +formalParam :: ArgRep -> Int -> Doc +formalParam V _ = empty +formalParam arg n = + formalParamType arg <> space <> + text "arg" <> int n <> text ", " +formalParamType arg | isPtr arg = text "\"ptr\"" <> space <> argRep arg + | otherwise = argRep arg + +argRep F = text "F_" +argRep D = text "D_" +argRep L = text "L_" +argRep _ = text "W_" genApply regstatus args = let @@ -345,9 +357,8 @@ genApply regstatus args = in vcat [ text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <> - int all_args_size <> text "/*framsize*/," <> - int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <> - text "RET_SMALL)\n{", + text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <> + text ")\n{", nest 4 (vcat [ text "W_ info;", text "W_ arity;", -- 1.7.10.4