diff options
Diffstat (limited to 'compiler')
53 files changed, 1502 insertions, 1154 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index a5d559e9ff..04312321cc 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -72,7 +72,7 @@ module CLabel ( mkCmmRetLabel, mkCmmCodeLabel, mkCmmDataLabel, - mkCmmGcPtrLabel, + mkCmmClosureLabel, mkRtsApFastLabel, @@ -331,7 +331,7 @@ data CmmLabelInfo | CmmRet -- ^ misc rts return points, suffix _ret | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure | CmmCode -- ^ misc rts code - | CmmGcPtr -- ^ GcPtrs eg CHARLIKE_closure + | CmmClosure -- ^ closures eg CHARLIKE_closure | CmmPrimCall -- ^ a prim call to some hand written Cmm code deriving (Eq, Ord) @@ -418,7 +418,7 @@ mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOL ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, - mkCmmCodeLabel, mkCmmDataLabel, mkCmmGcPtrLabel + mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel :: PackageId -> FastString -> CLabel mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo @@ -427,7 +427,7 @@ mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode mkCmmDataLabel pkg str = CmmLabel pkg str CmmData -mkCmmGcPtrLabel pkg str = CmmLabel pkg str CmmGcPtr +mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure -- Constructing RtsLabels @@ -543,6 +543,7 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod toClosureLbl :: CLabel -> CLabel toClosureLbl (IdLabel n c _) = IdLabel n c Closure +toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure toClosureLbl l = pprPanic "toClosureLbl" (ppr l) toSlowEntryLbl :: CLabel -> CLabel @@ -774,7 +775,7 @@ isGcPtrLabel lbl = case labelType lbl of -- whether it be code, data, or static GC object. labelType :: CLabel -> CLabelType labelType (CmmLabel _ _ CmmData) = DataLabel -labelType (CmmLabel _ _ CmmGcPtr) = GcPtrLabel +labelType (CmmLabel _ _ CmmClosure) = GcPtrLabel labelType (CmmLabel _ _ CmmCode) = CodeLabel labelType (CmmLabel _ _ CmmInfo) = DataLabel labelType (CmmLabel _ _ CmmEntry) = CodeLabel @@ -1001,7 +1002,6 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi pprCLbl (CmmLabel _ str CmmCode) = ftext str pprCLbl (CmmLabel _ str CmmData) = ftext str -pprCLbl (CmmLabel _ str CmmGcPtr) = ftext str pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") @@ -1046,6 +1046,9 @@ pprCLbl (CmmLabel _ fs CmmRetInfo) pprCLbl (CmmLabel _ fs CmmRet) = ftext fs <> ptext (sLit "_ret") +pprCLbl (CmmLabel _ fs CmmClosure) + = ftext fs <> ptext (sLit "_closure") + pprCLbl (RtsLabel (RtsPrimOp primop)) = ptext (sLit "stg_") <> ppr primop diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 2dedee0d52..8409f0dbeb 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -109,9 +109,14 @@ data CmmStackInfo -- number of bytes of arguments on the stack on entry to the -- the proc. This is filled in by StgCmm.codeGen, and used -- by the stack allocator later. - updfr_space :: Maybe ByteOff + updfr_space :: Maybe ByteOff, -- XXX: this never contains anything useful, but it should. -- See comment in CmmLayoutStack. + do_layout :: Bool + -- Do automatic stack layout for this proc. This is + -- True for all code generated by the code generator, + -- but is occasionally False for hand-written Cmm where + -- we want to do the stack manipulation manually. } -- | Info table as a haskell data type diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index ecaab57d76..304f4c2170 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -235,8 +235,8 @@ to_SRT dflags top_srt off len bmp tbl = CmmData RelocatableReadOnlyData $ Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW dflags top_srt off - : mkWordCLit dflags (toStgWord dflags (fromIntegral len)) - : map (mkWordCLit dflags) bmp) + : mkWordCLit dflags (fromIntegral len) + : map (mkStgWordCLit dflags) bmp) return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags)) | otherwise = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp)))) @@ -252,7 +252,8 @@ localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) = case topInfoTable proc of - Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep) + Just (CmmInfoTable { cit_rep = rep }) + | not (isStaticRep rep) && not (isStackRep rep) -> (cafs, Just (toClosureLbl top_l)) _other -> (cafs, Nothing) where diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 235fe7f911..180b2d7eab 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -8,7 +8,8 @@ module CmmCallConv ( ParamLocation(..), assignArgumentsPos, - globalArgRegs + assignStack, + globalArgRegs, realArgRegs ) where #include "HsVersions.h" @@ -18,7 +19,6 @@ import SMRep import Cmm (Convention(..)) import PprCmm () -import qualified Data.List as L import DynFlags import Outputable @@ -33,15 +33,22 @@ instance Outputable ParamLocation where ppr (RegisterParam g) = ppr g ppr (StackParam p) = ppr p --- | JD: For the new stack story, I want arguments passed on the stack to manifest as --- positive offsets in a CallArea, not negative offsets from the stack pointer. --- Also, I want byte offsets, not word offsets. -assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] -> - [(a, ParamLocation)] +-- | -- Given a list of arguments, and a function that tells their types, -- return a list showing where each argument is passed -assignArgumentsPos dflags conv arg_ty reps = assignments - where -- The calling conventions (CgCallConv.hs) are complicated, to say the least +-- +assignArgumentsPos :: DynFlags + -> ByteOff -- stack offset to start with + -> Convention + -> (a -> CmmType) -- how to get a type from an arg + -> [a] -- args + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) + +assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) + where regs = case (reps, conv) of (_, NativeNodeCall) -> getRegsWithNode dflags (_, NativeDirectCall) -> getRegsWithoutNode dflags @@ -49,23 +56,14 @@ assignArgumentsPos dflags conv arg_ty reps = assignments (_, NativeReturn) -> getRegsWithNode dflags -- GC calling convention *must* put values in registers (_, GC) -> allRegs dflags - (_, PrimOpCall) -> allRegs dflags - ([_], PrimOpReturn) -> allRegs dflags - (_, PrimOpReturn) -> getRegsWithNode dflags (_, Slow) -> noRegs -- The calling conventions first assign arguments to registers, -- then switch to the stack when we first run out of registers - -- (even if there are still available registers for args of a different type). - -- When returning an unboxed tuple, we also separate the stack - -- arguments by pointerhood. - (reg_assts, stk_args) = assign_regs [] reps regs - stk_args' = case conv of NativeReturn -> part - PrimOpReturn -> part - GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call" - _ -> stk_args - where part = uncurry (++) - (L.partition (not . isGcPtrType . arg_ty) stk_args) - stk_assts = assign_stk 0 [] (reverse stk_args') + -- (even if there are still available registers for args of a + -- different type). When returning an unboxed tuple, we also + -- separate the stack arguments by pointerhood. + (reg_assts, stk_args) = assign_regs [] reps regs + (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args assignments = reg_assts ++ stk_assts assign_regs assts [] _ = (assts, []) @@ -88,11 +86,21 @@ assignArgumentsPos dflags conv arg_ty reps = assignments gcp | isGcPtrType ty = VGcPtr | otherwise = VNonGcPtr - assign_stk _ assts [] = assts - assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs + +assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] + -> ( + ByteOff -- bytes of stack args + , [(a, ParamLocation)] -- args and locations + ) +assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args) + where + assign_stk offset assts [] = (offset, assts) + assign_stk offset assts (r:rs) + = assign_stk off' ((r, StackParam off') : assts) rs where w = typeWidth (arg_ty r) - size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags + size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size off' = offset + size + word_size = wORD_SIZE dflags ----------------------------------------------------------------------------- -- Local information about the registers available @@ -158,3 +166,9 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ allFloatRegs dflags ++ allDoubleRegs dflags ++ allLongRegs dflags + +realArgRegs :: DynFlags -> [GlobalReg] +realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++ + realFloatRegs dflags ++ + realDoubleRegs dflags ++ + realLongRegs dflags diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index aa2925fe53..4028efddf6 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -97,15 +97,17 @@ cmmCfgOptsProc _ top = top blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId) blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } - = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map) + = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map') where - -- we might be able to shortcut the entry BlockId itself - new_entry + -- we might be able to shortcut the entry BlockId itself. + -- remember to update the shortcut_map', since we also have to + -- update the info_tbls mapping now. + (new_entry, shortcut_map') | Just entry_blk <- mapLookup entry_id new_blocks , Just dest <- canShortcut entry_blk - = dest + = (dest, mapInsert entry_id dest shortcut_map) | otherwise - = entry_id + = (entry_id, shortcut_map) blocks = postorderDfs g blockmap = foldr addBlock emptyBody blocks diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index cd838821b3..017d120d84 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -22,19 +22,23 @@ cmmOfZgraph tops = map mapTop tops where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds -data ValueDirection = Arguments | Results +add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a] +add_hints args hints = zipWith Old.CmmHinted args hints -add_hints :: ForeignTarget -> ValueDirection -> [a] -> [Old.CmmHinted a] -add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd) - -get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint] -get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints -get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results = hints -get_hints (PrimTarget _) _vd = repeat NoHint +get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) +get_hints (PrimTarget op) = (res_hints ++ repeat NoHint, + arg_hints ++ repeat NoHint) + where (res_hints, arg_hints) = callishMachOpHints op +get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _)) + = (res_hints, arg_hints) cmm_target :: ForeignTarget -> Old.CmmCallTarget cmm_target (PrimTarget op) = Old.CmmPrim op Nothing -cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc +cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc + +get_ret :: ForeignTarget -> CmmReturnInfo +get_ret (PrimTarget _) = CmmMayReturn +get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g @@ -83,11 +87,14 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g CmmAssign l r -> Old.CmmAssign l r CmmStore l r -> Old.CmmStore l r CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop - CmmUnsafeForeignCall target ress args -> + CmmUnsafeForeignCall target ress args -> Old.CmmCall (cmm_target target) - (add_hints target Results ress) - (add_hints target Arguments args) - Old.CmmMayReturn + (add_hints ress res_hints) + (add_hints args arg_hints) + (get_ret target) + where + (res_hints, arg_hints) = get_hints target + last :: CmmNode O C -> () -> [Old.CmmStmt] last node _ = stmts diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 6aa4d6cbfa..dec6b5d09d 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -155,7 +155,7 @@ type InfoTableContents = ( [CmmLit] -- The standard part mkInfoTableContents :: DynFlags -> CmmInfoTable - -> Maybe StgHalfWord -- Override default RTS type tag? + -> Maybe Int -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls InfoTableContents) -- Info tbl + extra bits @@ -178,22 +178,19 @@ mkInfoTableContents dflags ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag - | null liveness_data = rET_SMALL dflags -- Fits in extra_bits - | otherwise = rET_BIG dflags -- Does not; extra_bits is - -- a label + | null liveness_data = rET_SMALL -- Fits in extra_bits + | otherwise = rET_BIG -- Does not; extra_bits is + -- a label ; return (prof_data ++ liveness_data, (std_info, srt_label)) } | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packHalfWordsCLit - dflags - (toStgHalfWord dflags (toInteger ptrs)) - (toStgHalfWord dflags (toInteger nonptrs)) + = do { let layout = packIntsCLit dflags ptrs nonptrs ; (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits - (mb_rts_tag `orElse` rtsClosureType dflags smrep) + (mb_rts_tag `orElse` rtsClosureType smrep) (mb_srt_field `orElse` srt_bitmap) (mb_layout `orElse` layout) ; return (prof_data ++ ct_data, (std_info, extra_bits)) } @@ -205,24 +202,25 @@ mkInfoTableContents dflags , [RawCmmDecl]) -- Auxiliary data decls mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor = do { (descr_lit, decl) <- newStringLit con_descr - ; return (Just con_tag, Nothing, [descr_lit], [decl]) } + ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag)) + , Nothing, [descr_lit], [decl]) } mk_pieces Thunk srt_label = return (Nothing, Nothing, srt_label, []) mk_pieces (ThunkSelector offset) _no_srt - = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], []) + = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], []) -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label + = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits - ; let fun_type | null liveness_data = aRG_GEN dflags - | otherwise = aRG_GEN_BIG dflags - extra_bits = [ packHalfWordsCLit dflags fun_type arity + ; let fun_type | null liveness_data = aRG_GEN + | otherwise = aRG_GEN_BIG + extra_bits = [ packIntsCLit dflags fun_type arity , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where @@ -233,9 +231,14 @@ mkInfoTableContents dflags mk_pieces BlackHole _ = panic "mk_pieces: BlackHole" - mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier +packIntsCLit :: DynFlags -> Int -> Int -> CmmLit +packIntsCLit dflags a b = packHalfWordsCLit dflags + (toStgHalfWord dflags (fromIntegral a)) + (toStgHalfWord dflags (fromIntegral b)) + + mkSRTLit :: DynFlags -> C_SRT -> ([CmmLit], -- srt_label, if any @@ -314,7 +317,7 @@ mkLivenessBits dflags liveness [mkRODataLits bitmap_lbl lits]) } | otherwise -- Fits in one word - = return (mkWordCLit dflags bitmap_word, []) + = return (mkStgWordCLit dflags bitmap_word, []) where n_bits = length liveness @@ -328,7 +331,8 @@ mkLivenessBits dflags liveness bitmap_word = toStgWord dflags (fromIntegral n_bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) - lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap + lits = mkWordCLit dflags (fromIntegral n_bits) + : map (mkStgWordCLit dflags) bitmap -- The first word is the size. The structure must match -- StgLargeBitmap in includes/rts/storage/InfoTable.h @@ -348,8 +352,8 @@ mkLivenessBits dflags liveness mkStdInfoTable :: DynFlags -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) - -> StgHalfWord -- Closure RTS tag - -> StgHalfWord -- SRT length + -> Int -- Closure RTS tag + -> StgHalfWord -- SRT length -> CmmLit -- layout field -> [CmmLit] @@ -365,7 +369,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] | otherwise = [] - type_lit = packHalfWordsCLit dflags cl_type srt_len + type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len ------------------------------------------------------------------------- -- diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 6f75f5451c..5c4045778a 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -933,7 +933,7 @@ lowerSafeForeignCall dflags block (ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ) (map (CmmReg . CmmLocal) res) - updfr (0, []) + updfr [] -- NB. after resumeThread returns, the top-of-stack probably contains -- the stack frame for succ, but it might not: if the current thread @@ -973,14 +973,14 @@ callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O callSuspendThread dflags id intrbl = CmmUnsafeForeignCall (ForeignTarget (foreignLbl (fsLit "suspendThread")) - (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint])) + (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn)) [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = CmmUnsafeForeignCall (ForeignTarget (foreignLbl (fsLit "resumeThread")) - (ForeignConvention CCallConv [AddrHint] [AddrHint])) + (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn)) [new_base] [CmmReg (CmmLocal id)] -- ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index ddd681d25e..718eb27c82 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -23,9 +23,9 @@ module CmmLex ( CmmToken(..), cmmlex, ) where -import OldCmm -import Lexer +import CmmExpr +import Lexer import SrcLoc import UniqFM import StringBuffer @@ -147,6 +147,7 @@ data CmmToken | CmmT_align | CmmT_goto | CmmT_if + | CmmT_call | CmmT_jump | CmmT_foreign | CmmT_never @@ -157,6 +158,7 @@ data CmmToken | CmmT_switch | CmmT_case | CmmT_default + | CmmT_push | CmmT_bits8 | CmmT_bits16 | CmmT_bits32 @@ -224,8 +226,9 @@ reservedWordsFM = listToUFM $ ( "align", CmmT_align ), ( "goto", CmmT_goto ), ( "if", CmmT_if ), - ( "jump", CmmT_jump ), - ( "foreign", CmmT_foreign ), + ( "call", CmmT_call ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), ( "never", CmmT_never ), ( "prim", CmmT_prim ), ( "return", CmmT_return ), @@ -233,8 +236,9 @@ reservedWordsFM = listToUFM $ ( "import", CmmT_import ), ( "switch", CmmT_switch ), ( "case", CmmT_case ), - ( "default", CmmT_default ), - ( "bits8", CmmT_bits8 ), + ( "default", CmmT_default ), + ( "push", CmmT_push ), + ( "bits8", CmmT_bits8 ), ( "bits16", CmmT_bits16 ), ( "bits32", CmmT_bits32 ), ( "bits64", CmmT_bits64 ), diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 520c7e7a7d..c00cdb5b5a 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -16,7 +16,7 @@ module CmmMachOp , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 -- CallishMachOp - , CallishMachOp(..) + , CallishMachOp(..), callishMachOpHints , pprCallishMachOp ) where @@ -463,3 +463,10 @@ data CallishMachOp pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp mo = text (show mo) +callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint]) +callishMachOpHints op = case op of + MO_Memcpy -> ([], [AddrHint,AddrHint,NoHint,NoHint]) + MO_Memset -> ([], [AddrHint,NoHint,NoHint,NoHint]) + MO_Memmove -> ([], [AddrHint,AddrHint,NoHint,NoHint]) + _ -> ([],[]) + -- empty lists indicate NoHint diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index ae7ac091de..b7bb270bd6 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -9,8 +9,9 @@ -- for details module CmmNode ( - CmmNode(..), ForeignHint(..), CmmFormal, CmmActual, + CmmNode(..), CmmFormal, CmmActual, UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..), + CmmReturnInfo(..), mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf, mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors ) where @@ -228,14 +229,31 @@ type CmmFormal = LocalReg type UpdFrameOffset = ByteOff +-- | A convention maps a list of values (function arguments or return +-- values) to registers or stack locations. data Convention - = NativeDirectCall -- Native C-- call skipping the node (closure) argument - | NativeNodeCall -- Native C-- call including the node argument - | NativeReturn -- Native C-- return - | Slow -- Slow entry points: all args pushed on the stack - | GC -- Entry to the garbage collector: uses the node reg! - | PrimOpCall -- Calling prim ops - | PrimOpReturn -- Returning from prim ops + = NativeDirectCall + -- ^ top-level Haskell functions use @NativeDirectCall@, which + -- maps arguments to registers starting with R2, according to + -- how many registers are available on the platform. This + -- convention ignores R1, because for a top-level function call + -- the function closure is implicit, and doesn't need to be passed. + | NativeNodeCall + -- ^ non-top-level Haskell functions, which pass the address of + -- the function closure in R1 (regardless of whether R1 is a + -- real register or not), and the rest of the arguments in + -- registers or on the stack. + | NativeReturn + -- ^ a native return. The convention for returns depends on + -- how many values are returned: for just one value returned, + -- the appropriate register is used (R1, F1, etc.). regardless + -- of whether it is a real register or not. For multiple + -- values returned, they are mapped to registers or the stack. + | Slow + -- ^ Slow entry points: all args pushed on the stack + | GC + -- ^ Entry to the garbage collector: uses the node reg! + -- (TODO: I don't think we need this --SDM) deriving( Eq ) data ForeignConvention @@ -243,8 +261,14 @@ data ForeignConvention CCallConv -- Which foreign-call convention [ForeignHint] -- Extra info about the args [ForeignHint] -- Extra info about the result + CmmReturnInfo deriving Eq +data CmmReturnInfo + = CmmMayReturn + | CmmNeverReturns + deriving ( Eq ) + data ForeignTarget -- The target of a foreign call = ForeignTarget -- A foreign procedure CmmExpr -- Its address @@ -253,12 +277,6 @@ data ForeignTarget -- The target of a foreign call CallishMachOp -- Which one deriving Eq -data ForeignHint - = NoHint | AddrHint | SignedHint - deriving( Eq ) - -- Used to give extra per-argument or per-result - -- information needed by foreign calling conventions - -------------------------------------------------- -- Instances of register and slot users / definers diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 32afa1d078..843626303a 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -14,6 +14,7 @@ module CmmOpt ( #include "HsVersions.h" +import CmmUtils import OldCmm import DynFlags import CLabel @@ -184,22 +185,22 @@ cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], ar -- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] - = Just $ CmmRegOff reg (fromIntegral (narrowS rep n)) + = Just $ cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = Just $ CmmRegOff reg (off + fromIntegral (narrowS rep n)) + = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] - = Just $ CmmRegOff reg (- fromIntegral (narrowS rep n)) + = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = Just $ CmmRegOff reg (off - fromIntegral (narrowS rep n)) + = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible -cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] - = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) -cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)] - = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) -cmmMachOpFoldM _ (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] - = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i)))) +cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) +cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)] + = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i)))) -- Comparison of literal with widened operand: perform the comparison diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 8c3559b774..22e28a8a9d 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1,14 +1,160 @@ ----------------------------------------------------------------------------- -- --- (c) The University of Glasgow, 2004-2006 +-- (c) The University of Glasgow, 2004-2012 -- -- Parser for concrete Cmm. --- This doesn't just parse the Cmm file, we also do some code generation --- along the way for switches and foreign calls etc. -- ----------------------------------------------------------------------------- --- TODO: Add support for interruptible/uninterruptible foreign call specification +{- ----------------------------------------------------------------------------- +Note [Syntax of .cmm files] + +NOTE: You are very much on your own in .cmm. There is very little +error checking at all: + + * Type errors are detected by the (optional) -dcmm-lint pass, if you + don't turn this on then a type error will likely result in a panic + from the native code generator. + + * Passing the wrong number of arguments or arguments of the wrong + type is not detected. + +There are two ways to write .cmm code: + + (1) High-level Cmm code delegates the stack handling to GHC, and + never explicitly mentions Sp or registers. + + (2) Low-level Cmm manages the stack itself, and must know about + calling conventions. + +Whether you want high-level or low-level Cmm is indicated by the +presence of an argument list on a procedure. For example: + +foo ( gcptr a, bits32 b ) +{ + // this is high-level cmm code + + if (b > 0) { + // we can make tail calls passing arguments: + jump stg_ap_0_fast(a); + } + + push (stg_upd_frame_info, a) { + // stack frames can be explicitly pushed + + (x,y) = call wibble(a,b,3,4); + // calls pass arguments and return results using the native + // Haskell calling convention. The code generator will automatically + // construct a stack frame and an info table for the continuation. + + return (x,y); + // we can return multiple values from the current proc + } +} + +bar +{ + // this is low-level cmm code, indicated by the fact that we did not + // put an argument list on bar. + + x = R1; // the calling convention is explicit: better be careful + // that this works on all platforms! + + jump %ENTRY_CODE(Sp(0)) +} + +Here is a list of rules for high-level and low-level code. If you +break the rules, you get a panic (for using a high-level construct in +a low-level proc), or wrong code (when using low-level code in a +high-level proc). This stuff isn't checked! (TODO!) + +High-level only: + + - tail-calls with arguments, e.g. + jump stg_fun (arg1, arg2); + + - function calls: + (ret1,ret2) = call stg_fun (arg1, arg2); + + This makes a call with the NativeNodeCall convention, and the + values are returned to the following code using the NativeReturn + convention. + + - returning: + return (ret1, ret2) + + These use the NativeReturn convention to return zero or more + results to the caller. + + - pushing stack frames: + push (info_ptr, field1, ..., fieldN) { ... statements ... } + +Low-level only: + + - References to Sp, R1-R8, F1-F4 etc. + + NB. foreign calls may clobber the argument registers R1-R8, F1-F4 + etc., so ensure they are saved into variables around foreign + calls. + + - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp + directly. + +Both high-level and low-level code can use a raw tail-call: + + jump stg_fun [R1,R2] + +This always transfers control to a low-level Cmm function, but the +call can be made from high-level code. Arguments must be passed +explicitly in R/F/D/L registers. + +NB. you *must* specify the list of GlobalRegs that are passed via a +jump, otherwise the register allocator will assume that all the +GlobalRegs are dead at the jump. + + +A stack frame is written like this: + +INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN ) + return ( arg1, ..., argM ) +{ + ... code ... +} + +where field1 ... fieldN are the fields of the stack frame (with types) +arg1...argN are the values returned to the stack frame (with types). +The return values are assumed to be passed according to the +NativeReturn convention. + +On entry to the code, the stack frame looks like: + + |----------| + | fieldN | + | ... | + | field1 | + |----------| + | info_ptr | + |----------| + | argN | + | ... | <- Sp + +and some of the args may be in registers. + +We prepend the code by a copyIn of the args, and assign all the stack +frame fields to their formals. The initial "arg offset" for stack +layout purposes consists of the whole stack frame plus any args that +might be on the stack. + +A tail-call may pass a stack frame to the callee using the following +syntax: + +jump f (info_ptr, field1,..,fieldN) (arg1,..,argN) + +where info_ptr and field1..fieldN describe the stack frame, and +arg1..argN are the arguments passed to f using the NativeNodeCall +convention. + +----------------------------------------------------------------------------- -} { {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 @@ -21,30 +167,32 @@ module CmmParse ( parseCmmFile ) where -import CgMonad -import CgExtCode -import CgHeapery -import CgUtils -import CgProf -import CgTicky -import CgInfoTbls -import CgForeignCall -import CgTailCall -import CgStackery -import ClosureInfo -import CgCallConv -import CgClosure -import CostCentre - -import BlockId -import OldCmm -import OldPprCmm() +import StgCmmExtCode +import CmmCallConv +import StgCmmProf +import StgCmmHeap +import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore + , emitAssign, emitOutOfLine, withUpdFrameOff + , getUpdFrameOff ) +import qualified StgCmmMonad as F +import StgCmmUtils +import StgCmmForeign +import StgCmmExpr +import StgCmmClosure +import StgCmmLayout +import StgCmmTicky +import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame ) + +import MkGraph +import Cmm import CmmUtils +import BlockId import CmmLex import CLabel import SMRep import Lexer +import CostCentre import ForeignCall import Module import Platform @@ -68,6 +216,7 @@ import Control.Monad import Data.Array import Data.Char ( ord ) import System.Exit +import Data.Maybe #include "HsVersions.h" } @@ -110,41 +259,43 @@ import System.Exit '&&' { L _ (CmmT_BoolAnd) } '||' { L _ (CmmT_BoolOr) } - 'CLOSURE' { L _ (CmmT_CLOSURE) } - 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } - 'INFO_TABLE_RET' { L _ (CmmT_INFO_TABLE_RET) } - 'INFO_TABLE_FUN' { L _ (CmmT_INFO_TABLE_FUN) } - 'INFO_TABLE_CONSTR' { L _ (CmmT_INFO_TABLE_CONSTR) } - 'INFO_TABLE_SELECTOR' { L _ (CmmT_INFO_TABLE_SELECTOR) } - 'else' { L _ (CmmT_else) } - 'export' { L _ (CmmT_export) } - 'section' { L _ (CmmT_section) } - 'align' { L _ (CmmT_align) } - 'goto' { L _ (CmmT_goto) } - 'if' { L _ (CmmT_if) } - 'jump' { L _ (CmmT_jump) } - 'foreign' { L _ (CmmT_foreign) } - 'never' { L _ (CmmT_never) } - 'prim' { L _ (CmmT_prim) } - 'return' { L _ (CmmT_return) } - 'returns' { L _ (CmmT_returns) } - 'import' { L _ (CmmT_import) } - 'switch' { L _ (CmmT_switch) } - 'case' { L _ (CmmT_case) } - 'default' { L _ (CmmT_default) } - 'bits8' { L _ (CmmT_bits8) } - 'bits16' { L _ (CmmT_bits16) } - 'bits32' { L _ (CmmT_bits32) } - 'bits64' { L _ (CmmT_bits64) } - 'float32' { L _ (CmmT_float32) } - 'float64' { L _ (CmmT_float64) } - 'gcptr' { L _ (CmmT_gcptr) } - - GLOBALREG { L _ (CmmT_GlobalReg $$) } - NAME { L _ (CmmT_Name $$) } - STRING { L _ (CmmT_String $$) } - INT { L _ (CmmT_Int $$) } - FLOAT { L _ (CmmT_Float $$) } + 'CLOSURE' { L _ (CmmT_CLOSURE) } + 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } + 'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) } + 'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) } + 'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) } + 'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) } + 'else' { L _ (CmmT_else) } + 'export' { L _ (CmmT_export) } + 'section' { L _ (CmmT_section) } + 'align' { L _ (CmmT_align) } + 'goto' { L _ (CmmT_goto) } + 'if' { L _ (CmmT_if) } + 'call' { L _ (CmmT_call) } + 'jump' { L _ (CmmT_jump) } + 'foreign' { L _ (CmmT_foreign) } + 'never' { L _ (CmmT_never) } + 'prim' { L _ (CmmT_prim) } + 'return' { L _ (CmmT_return) } + 'returns' { L _ (CmmT_returns) } + 'import' { L _ (CmmT_import) } + 'switch' { L _ (CmmT_switch) } + 'case' { L _ (CmmT_case) } + 'default' { L _ (CmmT_default) } + 'push' { L _ (CmmT_push) } + 'bits8' { L _ (CmmT_bits8) } + 'bits16' { L _ (CmmT_bits16) } + 'bits32' { L _ (CmmT_bits32) } + 'bits64' { L _ (CmmT_bits64) } + 'float32' { L _ (CmmT_float32) } + 'float64' { L _ (CmmT_float64) } + 'gcptr' { L _ (CmmT_gcptr) } + + GLOBALREG { L _ (CmmT_GlobalReg $$) } + NAME { L _ (CmmT_Name $$) } + STRING { L _ (CmmT_String $$) } + INT { L _ (CmmT_Int $$) } + FLOAT { L _ (CmmT_Float $$) } %monad { P } { >>= } { return } %lexer { cmmlex } { L _ CmmT_EOF } @@ -166,18 +317,18 @@ import System.Exit %% -cmm :: { ExtCode } - : {- empty -} { return () } - | cmmtop cmm { do $1; $2 } +cmm :: { CmmParse () } + : {- empty -} { return () } + | cmmtop cmm { do $1; $2 } -cmmtop :: { ExtCode } - : cmmproc { $1 } - | cmmdata { $1 } - | decl { $1 } - | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - {% withThisPackage $ \pkg -> - do lits <- sequence $6; - staticClosure pkg $3 $5 (map getLit lits) } +cmmtop :: { CmmParse () } + : cmmproc { $1 } + | cmmdata { $1 } + | decl { $1 } + | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' + {% withThisPackage $ \pkg -> + do lits <- sequence $6; + staticClosure pkg $3 $5 (map getLit lits) } -- The only static closures in the RTS are dummy closures like -- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need @@ -188,37 +339,37 @@ cmmtop :: { ExtCode } -- * payload is always empty -- * we can derive closure and info table labels from a single NAME -cmmdata :: { ExtCode } - : 'section' STRING '{' data_label statics '}' - { do lbl <- $4; - ss <- sequence $5; - code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) } - -data_label :: { ExtFCode CLabel } - : NAME ':' - {% withThisPackage $ \pkg -> - return (mkCmmDataLabel pkg $1) } - -statics :: { [ExtFCode [CmmStatic]] } - : {- empty -} { [] } - | static statics { $1 : $2 } - +cmmdata :: { CmmParse () } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) } + +data_label :: { CmmParse CLabel } + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } + +statics :: { [CmmParse [CmmStatic]] } + : {- empty -} { [] } + | static statics { $1 : $2 } + -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. -static :: { ExtFCode [CmmStatic] } - : type expr ';' { do e <- $2; - return [CmmStaticLit (getLit e)] } - | type ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1))] } - | 'bits8' '[' ']' STRING ';' { return [mkString $4] } - | 'bits8' '[' INT ']' ';' { return [CmmUninitialised - (fromIntegral $3)] } - | typenot8 '[' INT ']' ';' { return [CmmUninitialised - (widthInBytes (typeWidth $1) * - fromIntegral $3)] } - | 'CLOSURE' '(' NAME lits ')' - { do { lits <- sequence $4 - ; dflags <- getDynFlags +static :: { CmmParse [CmmStatic] } + : type expr ';' { do e <- $2; + return [CmmStaticLit (getLit e)] } + | type ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1))] } + | 'bits8' '[' ']' STRING ';' { return [mkString $4] } + | 'bits8' '[' INT ']' ';' { return [CmmUninitialised + (fromIntegral $3)] } + | typenot8 '[' INT ']' ';' { return [CmmUninitialised + (widthInBytes (typeWidth $1) * + fromIntegral $3)] } + | 'CLOSURE' '(' NAME lits ')' + { do { lits <- sequence $4 + ; dflags <- getDynFlags ; return $ map CmmStaticLit $ mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) -- mkForeignLabel because these are only used @@ -226,140 +377,140 @@ static :: { ExtFCode [CmmStatic] } dontCareCCS (map getLit lits) [] [] [] } } -- arrays of closures required for the CHARLIKE & INTLIKE arrays -lits :: { [ExtFCode CmmExpr] } - : {- empty -} { [] } - | ',' expr lits { $2 : $3 } - -cmmproc :: { ExtCode } --- TODO: add real SRT/info tables to parsed Cmm - : info maybe_formals_without_hints '{' body '}' - { do ((entry_ret_label, info, live, formals), stmts) <- - getCgStmtsEC' $ loopDecls $ do { - (entry_ret_label, info, live) <- $1; - formals <- sequence $2; +lits :: { [CmmParse CmmExpr] } + : {- empty -} { [] } + | ',' expr lits { $2 : $3 } + +cmmproc :: { CmmParse () } + : info maybe_conv maybe_formals maybe_body + { do ((entry_ret_label, info, stk_formals, formals), agraph) <- + getCodeR $ loopDecls $ do { + (entry_ret_label, info, stk_formals) <- $1; + formals <- sequence (fromMaybe [] $3); $4; - return (entry_ret_label, info, live, formals) } - blks <- code (cgStmtsToBlocks stmts) - code (emitInfoTableAndCode entry_ret_label info formals blks) } + return (entry_ret_label, info, stk_formals, formals) } + let do_layout = isJust $3 + code (emitProcWithStackFrame $2 info + entry_ret_label stk_formals formals agraph + do_layout ) } - | info maybe_formals_without_hints ';' - { do (entry_ret_label, info, live) <- $1; - formals <- sequence $2; - code (emitInfoTableAndCode entry_ret_label info formals []) } +maybe_conv :: { Convention } + : {- empty -} { NativeNodeCall } + | 'return' { NativeReturn } - | NAME maybe_formals_without_hints '{' body '}' - {% withThisPackage $ \pkg -> - do newFunctionName $1 pkg - (formals, stmts) <- - getCgStmtsEC' $ loopDecls $ do { - formals <- sequence $2; - $4; - return formals } - blks <- code (cgStmtsToBlocks stmts) - code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) } - -info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } - : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ')' - -- ptrs, nptrs, closure type, description, type - {% withThisPackage $ \pkg -> +maybe_body :: { CmmParse () } + : ';' { return () } + | '{' body '}' { $2 } + +info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) } + : NAME + {% withThisPackage $ \pkg -> + do newFunctionName $1 pkg + return (mkCmmCodeLabel pkg $1, Nothing, []) } + + + | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' + -- ptrs, nptrs, closure type, description, type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 - rep = mkRTSRep $9 $ + rep = mkRTSRep (fromIntegral $9) $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) Thunk -- not really Thunk, but that makes the info table -- we want. return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ',' stgHalfWord ')' - -- ptrs, nptrs, closure type, description, type, fun type - {% withThisPackage $ \pkg -> + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' + -- ptrs, nptrs, closure type, description, type, fun type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $11 $13 - ty = Fun (toStgHalfWord dflags 0) (ArgSpec $15) + ty = Fun 0 (ArgSpec (fromIntegral $15)) -- Arity zero, arg_type $15 - rep = mkRTSRep $9 $ + rep = mkRTSRep (fromIntegral $9) $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - -- we leave most of the fields zero here. This is only used - -- to generate the BCO info table in the RTS at the moment. - - | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' stgHalfWord ',' STRING ',' STRING ')' + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + -- we leave most of the fields zero here. This is only used + -- to generate the BCO info table in the RTS at the moment. + + | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $13 $15 - ty = Constr $9 -- Tag + ty = Constr (fromIntegral $9) -- Tag (stringToWord8s $13) - rep = mkRTSRep $11 $ + rep = mkRTSRep (fromIntegral $11) $ mkHeapRep dflags False (fromIntegral $5) (fromIntegral $7) ty return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - -- If profiling is on, this string gets duplicated, - -- but that's the way the old code did it we can fix it some other time. - - | 'INFO_TABLE_SELECTOR' '(' NAME ',' stgWord ',' stgHalfWord ',' STRING ',' STRING ')' - -- selector, closure type, description, type - {% withThisPackage $ \pkg -> + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + -- If profiling is on, this string gets duplicated, + -- but that's the way the old code did it we can fix it some other time. + + | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' + -- selector, closure type, description, type + {% withThisPackage $ \pkg -> do dflags <- getDynFlags let prof = profilingInfo dflags $9 $11 - ty = ThunkSelector $5 - rep = mkRTSRep $7 $ + ty = ThunkSelector (fromIntegral $5) + rep = mkRTSRep (fromIntegral $7) $ mkHeapRep dflags False 0 0 ty return (mkCmmEntryLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ')' - -- closure type (no live regs) - {% withThisPackage $ \pkg -> - do let prof = NoProfilingInfo - rep = mkRTSRep $5 $ mkStackRep [] + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ')' + -- closure type (no live regs) + {% withThisPackage $ \pkg -> + do let prof = NoProfilingInfo + rep = mkRTSRep (fromIntegral $5) $ mkStackRep [] return (mkCmmRetLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } - - | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ',' formals_without_hints0 ')' - -- closure type, live regs - {% withThisPackage $ \pkg -> + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + []) } + + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' + -- closure type, live regs + {% withThisPackage $ \pkg -> do dflags <- getDynFlags - live <- sequence (map (liftM Just) $7) - let prof = NoProfilingInfo - bitmap = mkLiveness dflags live - rep = mkRTSRep $5 $ mkStackRep bitmap + live <- sequence $7 + let prof = NoProfilingInfo + -- drop one for the info pointer + bitmap = mkLiveness dflags (map Just (drop 1 live)) + rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, - CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 - , cit_rep = rep - , cit_prof = prof, cit_srt = NoC_SRT }, - []) } + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 + , cit_rep = rep + , cit_prof = prof, cit_srt = NoC_SRT }, + live) } -body :: { ExtCode } - : {- empty -} { return () } - | decl body { do $1; $2 } - | stmt body { do $1; $2 } +body :: { CmmParse () } + : {- empty -} { return () } + | decl body { do $1; $2 } + | stmt body { do $1; $2 } -decl :: { ExtCode } - : type names ';' { mapM_ (newLocal $1) $2 } - | 'import' importNames ';' { mapM_ newImport $2 } - | 'export' names ';' { return () } -- ignore exports +decl :: { CmmParse () } + : type names ';' { mapM_ (newLocal $1) $2 } + | 'import' importNames ';' { mapM_ newImport $2 } + | 'export' names ';' { return () } -- ignore exports -- an imported function name, with optional packageId @@ -371,84 +522,96 @@ importNames importName :: { (FastString, CLabel) } - -- A label imported without an explicit packageId. - -- These are taken to come frome some foreign, unnamed package. - : NAME - { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } - - -- A label imported with an explicit packageId. - | STRING NAME - { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } - - -names :: { [FastString] } - : NAME { [$1] } - | NAME ',' names { $1 : $3 } - -stmt :: { ExtCode } - : ';' { nopEC } - - | NAME ':' - { do l <- newLabel $1; code (labelC l) } - - | lreg '=' expr ';' - { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) } - | type '[' expr ']' '=' expr ';' - { doStore $1 $3 $6 } - - -- 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 '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';' - {% foreignCall $3 $1 $4 $6 $9 $8 $10 } - | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';' - {% primCall $1 $4 $6 $9 $8 } - -- stmt-level macros, stealing syntax from ordinary C-- function calls. - -- Perhaps we ought to use the %%-form? - | NAME '(' exprs0 ')' ';' - {% stmtMacro $1 $3 } - | 'switch' maybe_range expr '{' arms default '}' - { do as <- sequence $5; doSwitch $2 $3 as $6 } - | 'goto' NAME ';' - { do l <- lookupLabel $2; stmtEC (CmmBranch l) } + -- A label imported without an explicit packageId. + -- These are taken to come frome some foreign, unnamed package. + : NAME + { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } + + -- A label imported with an explicit packageId. + | STRING NAME + { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } + + +names :: { [FastString] } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } + +stmt :: { CmmParse () } + : ';' { return () } + + | NAME ':' + { do l <- newLabel $1; emitLabel l } + + + + | lreg '=' expr ';' + { do reg <- $1; e <- $3; emitAssign reg e } + | type '[' expr ']' '=' expr ';' + { doStore $1 $3 $6 } + + -- Gah! We really want to say "foreign_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. + | foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $8 $9 } + | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';' + {% primCall $1 $4 $6 } + -- stmt-level macros, stealing syntax from ordinary C-- function calls. + -- Perhaps we ought to use the %%-form? + | NAME '(' exprs0 ')' ';' + {% stmtMacro $1 $3 } + | 'switch' maybe_range expr '{' arms default '}' + { do as <- sequence $5; doSwitch $2 $3 as $6 } + | 'goto' NAME ';' + { do l <- lookupLabel $2; emit (mkBranch l) } + | 'return' '(' exprs0 ')' ';' + { doReturn $3 } | 'jump' expr vols ';' - { do e <- $2; stmtEC (CmmJump e $3) } - | 'return' ';' - { stmtEC CmmReturn } + { doRawJump $2 $3 } + | 'jump' expr '(' exprs0 ')' ';' + { doJumpWithStack $2 [] $4 } + | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';' + { doJumpWithStack $2 $4 $7 } + | 'call' expr '(' exprs0 ')' ';' + { doCall $2 [] $4 } + | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';' + { doCall $6 $2 $8 } | 'if' bool_expr 'goto' NAME - { do l <- lookupLabel $4; cmmRawIf $2 l } - | 'if' bool_expr '{' body '}' else - { cmmIfThenElse $2 $4 $6 } + { do l <- lookupLabel $4; cmmRawIf $2 l } + | 'if' bool_expr '{' body '}' else + { cmmIfThenElse $2 $4 $6 } + | 'push' '(' exprs0 ')' maybe_body + { pushStackFrame $3 $5 } opt_never_returns :: { CmmReturnInfo } : { CmmMayReturn } | 'never' 'returns' { CmmNeverReturns } -bool_expr :: { ExtFCode BoolExpr } - : bool_op { $1 } - | expr { do e <- $1; return (BoolTest e) } - -bool_op :: { ExtFCode BoolExpr } - : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; - return (BoolAnd e1 e2) } - | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; - return (BoolOr e1 e2) } - | '!' bool_expr { do e <- $2; return (BoolNot e) } - | '(' bool_op ')' { $2 } - --- This is not C-- syntax. What to do? -safety :: { CmmSafety } - : {- empty -} { CmmUnsafe } -- Default may change soon - | STRING {% parseSafety $1 } - --- This is not C-- syntax. What to do? -vols :: { Maybe [GlobalReg] } - : {- empty -} { Nothing } - | '[' ']' { Just [] } - | '[' globals ']' { Just $2 } +bool_expr :: { CmmParse BoolExpr } + : bool_op { $1 } + | expr { do e <- $1; return (BoolTest e) } + +bool_op :: { CmmParse BoolExpr } + : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolAnd e1 e2) } + | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3; + return (BoolOr e1 e2) } + | '!' bool_expr { do e <- $2; return (BoolNot e) } + | '(' bool_op ')' { $2 } + +safety :: { Safety } + : {- empty -} { PlayRisky } + | STRING {% parseSafety $1 } + +vols :: { [GlobalReg] } + : '[' ']' { [] } + | '[' '*' ']' {% do df <- getDynFlags + ; return (realArgRegs df) } + -- all of them + | '[' globals ']' { $2 } globals :: { [GlobalReg] } : GLOBALREG { [$1] } @@ -458,67 +621,67 @@ maybe_range :: { Maybe (Int,Int) } : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } | {- empty -} { Nothing } -arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] } - : {- empty -} { [] } - | arm arms { $1 : $2 } +arms :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] } + : {- empty -} { [] } + | arm arms { $1 : $2 } -arm :: { ExtFCode ([Int],Either BlockId ExtCode) } - : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } +arm :: { CmmParse ([Int],Either BlockId (CmmParse ())) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } -arm_body :: { ExtFCode (Either BlockId ExtCode) } - : '{' body '}' { return (Right $2) } - | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } +arm_body :: { CmmParse (Either BlockId (CmmParse ())) } + : '{' body '}' { return (Right $2) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } ints :: { [Int] } : INT { [ fromIntegral $1 ] } | INT ',' ints { fromIntegral $1 : $3 } -default :: { Maybe ExtCode } - : 'default' ':' '{' body '}' { Just $4 } - -- taking a few liberties with the C-- syntax here; C-- doesn't have - -- 'default' branches - | {- empty -} { Nothing } +default :: { Maybe (CmmParse ()) } + : 'default' ':' '{' body '}' { Just $4 } + -- taking a few liberties with the C-- syntax here; C-- doesn't have + -- 'default' branches + | {- empty -} { Nothing } -- Note: OldCmm doesn't support a first class 'else' statement, though -- CmmNode does. -else :: { ExtCode } - : {- empty -} { nopEC } - | 'else' '{' body '}' { $3 } +else :: { CmmParse () } + : {- empty -} { return () } + | 'else' '{' body '}' { $3 } -- we have to write this out longhand so that Happy's precedence rules -- can kick in. -expr :: { ExtFCode CmmExpr } - : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } - | expr '*' expr { mkMachOp MO_Mul [$1,$3] } - | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } - | expr '-' expr { mkMachOp MO_Sub [$1,$3] } - | expr '+' expr { mkMachOp MO_Add [$1,$3] } - | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } - | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } - | expr '&' expr { mkMachOp MO_And [$1,$3] } - | expr '^' expr { mkMachOp MO_Xor [$1,$3] } - | expr '|' expr { mkMachOp MO_Or [$1,$3] } - | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } - | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } - | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } - | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } - | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } - | expr '==' expr { mkMachOp MO_Eq [$1,$3] } - | '~' expr { mkMachOp MO_Not [$2] } - | '-' expr { mkMachOp MO_S_Neg [$2] } - | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; - return (mkMachOp mo [$1,$5]) } } - | expr0 { $1 } - -expr0 :: { ExtFCode CmmExpr } - : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } - | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } - | STRING { do s <- code (newStringCLit $1); - return (CmmLit s) } - | reg { $1 } - | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } - | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } - | '(' expr ')' { $2 } +expr :: { CmmParse CmmExpr } + : expr '/' expr { mkMachOp MO_U_Quot [$1,$3] } + | expr '*' expr { mkMachOp MO_Mul [$1,$3] } + | expr '%' expr { mkMachOp MO_U_Rem [$1,$3] } + | expr '-' expr { mkMachOp MO_Sub [$1,$3] } + | expr '+' expr { mkMachOp MO_Add [$1,$3] } + | expr '>>' expr { mkMachOp MO_U_Shr [$1,$3] } + | expr '<<' expr { mkMachOp MO_Shl [$1,$3] } + | expr '&' expr { mkMachOp MO_And [$1,$3] } + | expr '^' expr { mkMachOp MO_Xor [$1,$3] } + | expr '|' expr { mkMachOp MO_Or [$1,$3] } + | expr '>=' expr { mkMachOp MO_U_Ge [$1,$3] } + | expr '>' expr { mkMachOp MO_U_Gt [$1,$3] } + | expr '<=' expr { mkMachOp MO_U_Le [$1,$3] } + | expr '<' expr { mkMachOp MO_U_Lt [$1,$3] } + | expr '!=' expr { mkMachOp MO_Ne [$1,$3] } + | expr '==' expr { mkMachOp MO_Eq [$1,$3] } + | '~' expr { mkMachOp MO_Not [$2] } + | '-' expr { mkMachOp MO_S_Neg [$2] } + | expr0 '`' NAME '`' expr0 {% do { mo <- nameToMachOp $3 ; + return (mkMachOp mo [$1,$5]) } } + | expr0 { $1 } + +expr0 :: { CmmParse CmmExpr } + : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } + | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } + | STRING { do s <- code (newStringCLit $1); + return (CmmLit s) } + | reg { $1 } + | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) } + | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } + | '(' expr ')' { $2 } -- leaving out the type of a literal gives you the native word size in C-- @@ -526,81 +689,78 @@ maybe_ty :: { CmmType } : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags } | '::' type { $2 } -maybe_actuals :: { [ExtFCode HintedCmmActual] } - : {- empty -} { [] } - | '(' cmm_hint_exprs0 ')' { $2 } - -cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] } - : {- empty -} { [] } +cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] } + : {- empty -} { [] } | cmm_hint_exprs { $1 } -cmm_hint_exprs :: { [ExtFCode HintedCmmActual] } - : cmm_hint_expr { [$1] } - | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } +cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] } + : cmm_hint_expr { [$1] } + | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } -cmm_hint_expr :: { ExtFCode HintedCmmActual } - : expr { do e <- $1; return (CmmHinted e (inferCmmHint e)) } - | expr STRING {% do h <- parseCmmHint $2; - return $ do - e <- $1; return (CmmHinted e h) } +cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) } + : expr { do e <- $1; + return (e, inferCmmHint e) } + | expr STRING {% do h <- parseCmmHint $2; + return $ do + e <- $1; return (e, h) } -exprs0 :: { [ExtFCode CmmExpr] } - : {- empty -} { [] } - | exprs { $1 } - -exprs :: { [ExtFCode CmmExpr] } - : expr { [ $1 ] } - | expr ',' exprs { $1 : $3 } - -reg :: { ExtFCode CmmExpr } - : NAME { lookupName $1 } - | GLOBALREG { return (CmmReg (CmmGlobal $1)) } - -maybe_results :: { [ExtFCode HintedCmmFormal] } - : {- empty -} { [] } - | '(' cmm_formals ')' '=' { $2 } - -cmm_formals :: { [ExtFCode HintedCmmFormal] } - : cmm_formal { [$1] } - | cmm_formal ',' { [$1] } - | cmm_formal ',' cmm_formals { $1 : $3 } - -cmm_formal :: { ExtFCode HintedCmmFormal } - : local_lreg { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) } - | STRING local_lreg {% do h <- parseCmmHint $1; - return $ do - e <- $2; return (CmmHinted e h) } - -local_lreg :: { ExtFCode LocalReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg (CmmLocal r) -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } - -lreg :: { ExtFCode CmmReg } - : NAME { do e <- lookupName $1; - return $ - case e of - CmmReg r -> r - other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } - | GLOBALREG { return (CmmGlobal $1) } - -maybe_formals_without_hints :: { [ExtFCode LocalReg] } - : {- empty -} { [] } - | '(' formals_without_hints0 ')' { $2 } - -formals_without_hints0 :: { [ExtFCode LocalReg] } - : {- empty -} { [] } - | formals_without_hints { $1 } +exprs0 :: { [CmmParse CmmExpr] } + : {- empty -} { [] } + | exprs { $1 } -formals_without_hints :: { [ExtFCode LocalReg] } - : formal_without_hint ',' { [$1] } - | formal_without_hint { [$1] } - | formal_without_hint ',' formals_without_hints { $1 : $3 } +exprs :: { [CmmParse CmmExpr] } + : expr { [ $1 ] } + | expr ',' exprs { $1 : $3 } -formal_without_hint :: { ExtFCode LocalReg } - : type NAME { newLocal $1 $2 } +reg :: { CmmParse CmmExpr } + : NAME { lookupName $1 } + | GLOBALREG { return (CmmReg (CmmGlobal $1)) } + +foreign_results :: { [CmmParse (LocalReg, ForeignHint)] } + : {- empty -} { [] } + | '(' foreign_formals ')' '=' { $2 } + +foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] } + : foreign_formal { [$1] } + | foreign_formal ',' { [$1] } + | foreign_formal ',' foreign_formals { $1 : $3 } + +foreign_formal :: { CmmParse (LocalReg, ForeignHint) } + : local_lreg { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) } + | STRING local_lreg {% do h <- parseCmmHint $1; + return $ do + e <- $2; return (e,h) } + +local_lreg :: { CmmParse LocalReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") } + +lreg :: { CmmParse CmmReg } + : NAME { do e <- lookupName $1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } + | GLOBALREG { return (CmmGlobal $1) } + +maybe_formals :: { Maybe [CmmParse LocalReg] } + : {- empty -} { Nothing } + | '(' formals0 ')' { Just $2 } + +formals0 :: { [CmmParse LocalReg] } + : {- empty -} { [] } + | formals { $1 } + +formals :: { [CmmParse LocalReg] } + : formal ',' { [$1] } + | formal { [$1] } + | formal ',' formals { $1 : $3 } + +formal :: { CmmParse LocalReg } + : type NAME { newLocal $1 $2 } type :: { CmmType } : 'bits8' { b8 } @@ -614,12 +774,6 @@ typenot8 :: { CmmType } | 'float64' { f64 } | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags } -stgWord :: { StgWord } - : INT {% do dflags <- getDynFlags; return $ toStgWord dflags $1 } - -stgHalfWord :: { StgHalfWord } - : INT {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 } - { section :: String -> Section section "text" = Text @@ -632,11 +786,22 @@ section s = OtherSection s mkString :: String -> CmmStatic mkString s = CmmString (map (fromIntegral.ord) s) +-- | +-- Given an info table, decide what the entry convention for the proc +-- is. That is, for an INFO_TABLE_RET we want the return convention, +-- otherwise it is a NativeNodeCall. +-- +infoConv :: Maybe CmmInfoTable -> Convention +infoConv Nothing = NativeNodeCall +infoConv (Just info) + | isStackRep (cit_rep info) = NativeReturn + | otherwise = NativeNodeCall + -- mkMachOp infers the type of the MachOp from the type of its first -- argument. We assume that this is correct: for MachOps that don't have -- symmetrical args (e.g. shift ops), the first arg determines the type of -- the op. -mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr +mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr mkMachOp fn args = do dflags <- getDynFlags arg_exprs <- sequence args @@ -653,7 +818,7 @@ nameToMachOp name = Nothing -> fail ("unknown primitive " ++ unpackFS name) Just m -> return m -exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr) +exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr) exprOp name args_code = do dflags <- getDynFlags case lookupUFM (exprMacros dflags) name of @@ -755,10 +920,10 @@ callishMachOps = listToUFM $ -- ToDo: the rest, maybe ] -parseSafety :: String -> P CmmSafety -parseSafety "safe" = return (CmmSafe NoC_SRT) -parseSafety "unsafe" = return CmmUnsafe -parseSafety "interruptible" = return CmmInterruptible +parseSafety :: String -> P Safety +parseSafety "safe" = return PlaySafe +parseSafety "unsafe" = return PlayRisky +parseSafety "interruptible" = return PlayInterruptible parseSafety str = fail ("unrecognised safety: " ++ str) parseCmmHint :: String -> P ForeignHint @@ -788,7 +953,7 @@ happyError = srcParseFail -- ----------------------------------------------------------------------------- -- Statement-level macros -stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode +stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ()) stmtMacro fun args_code = do case lookupUFM stmtMacros fun of Nothing -> fail ("unknown macro: " ++ unpackFS fun) @@ -796,49 +961,61 @@ stmtMacro fun args_code = do args <- sequence args_code code (fcode args) -stmtMacros :: UniqFM ([CmmExpr] -> Code) +stmtMacros :: UniqFM ([CmmExpr] -> FCode ()) stmtMacros = listToUFM [ ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), - ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), - ( fsLit "HP_CHK_GEN", \[words,liveness,reentry] -> - hpChkGen words liveness reentry ), - ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ), - ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), - ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), - ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + + -- completely generic heap and stack checks, for use in high-level cmm. + ( fsLit "HP_CHK_GEN", \[bytes] -> + heapStackCheckGen Nothing (Just bytes) ), + ( fsLit "STK_CHK_GEN", \[] -> + heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), + + -- A stack check for a fixed amount of stack. Sounds a bit strange, but + -- we use the stack for a bit of temporary storage in a couple of primops + ( fsLit "STK_CHK_GEN_N", \[bytes] -> + heapStackCheckGen (Just bytes) Nothing ), + + -- A stack check on entry to a thunk, where the argument is the thunk pointer. + ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), + + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + + ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), + ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), - ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), ( fsLit "SET_HDR", \[ptr,info,ccs] -> - emitSetDynHdr ptr info ccs ), - ( fsLit "STK_CHK_GEN", \[words,liveness,reentry] -> - stkChkGen words liveness reentry ), - ( fsLit "STK_CHK_NP", \[e] -> stkChkNodePoints e ), + emitSetDynHdr ptr info ccs ), ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> - tickyAllocPrim hdr goods slop ), - ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> - tickyAllocPAP goods slop ), - ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> - tickyAllocThunk goods slop ), - ( fsLit "UPD_BH_UPDATABLE", \[] -> emitBlackHoleCode False ), - ( fsLit "UPD_BH_SINGLE_ENTRY", \[] -> emitBlackHoleCode True ), - - ( fsLit "RET_P", \[a] -> emitRetUT [(PtrArg,a)]), - ( fsLit "RET_N", \[a] -> emitRetUT [(NonPtrArg,a)]), - ( fsLit "RET_PP", \[a,b] -> emitRetUT [(PtrArg,a),(PtrArg,b)]), - ( fsLit "RET_NN", \[a,b] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]), - ( fsLit "RET_NP", \[a,b] -> emitRetUT [(NonPtrArg,a),(PtrArg,b)]), - ( fsLit "RET_PPP", \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]), - ( fsLit "RET_NPP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]), - ( fsLit "RET_NNP", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]), - ( fsLit "RET_NNN", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]), - ( fsLit "RET_NNNN", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]), - ( fsLit "RET_NNNP", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]), - ( fsLit "RET_NPNP", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)]) - + tickyAllocPrim hdr goods slop ), + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> + tickyAllocPAP goods slop ), + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> + tickyAllocThunk goods slop ), + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode False reg ), + ( fsLit "UPD_BH_SINGLE_ENTRY", \[reg] -> emitBlackHoleCode True reg ) ] +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushUpdateFrame sp e = do + dflags <- getDynFlags + emitUpdateFrame dflags sp mkUpdInfoLabel e + +pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () +pushStackFrame fields body = do + dflags <- getDynFlags + exprs <- sequence fields + updfr_off <- getUpdFrameOff + let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old + [] updfr_off exprs + emit g + withUpdFrameOff new_updfr_off body profilingInfo dflags desc_str ty_str = if not (dopt Opt_SccProfilingOn dflags) @@ -846,7 +1023,7 @@ profilingInfo dflags desc_str ty_str else ProfilingInfo (stringToWord8s desc_str) (stringToWord8s ty_str) -staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode +staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] @@ -854,78 +1031,93 @@ staticClosure pkg cl_label info payload foreignCall :: String - -> [ExtFCode HintedCmmFormal] - -> ExtFCode CmmExpr - -> [ExtFCode HintedCmmActual] - -> Maybe [GlobalReg] - -> CmmSafety + -> [CmmParse (LocalReg, ForeignHint)] + -> CmmParse CmmExpr + -> [CmmParse (CmmExpr, ForeignHint)] + -> Safety -> CmmReturnInfo - -> P ExtCode -foreignCall conv_string results_code expr_code args_code vols safety ret - = do convention <- case conv_string of + -> P (CmmParse ()) +foreignCall conv_string results_code expr_code args_code safety ret + = do conv <- case conv_string of "C" -> return CCallConv "stdcall" -> return StdCallConv - "C--" -> return CmmCallConv _ -> fail ("unknown calling convention: " ++ conv_string) return $ do dflags <- getDynFlags - let platform = targetPlatform dflags results <- sequence results_code - expr <- expr_code - args <- sequence args_code - case convention of - -- Temporary hack so at least some functions are CmmSafe - CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret)) - _ -> - let expr' = adjCallTarget dflags convention expr args in - case safety of - CmmUnsafe -> - code (emitForeignCall' PlayRisky results - (CmmCallee expr' convention) args vols NoC_SRT ret) - CmmSafe srt -> - code (emitForeignCall' PlaySafe results - (CmmCallee expr' convention) args vols NoC_SRT ret) where - CmmInterruptible -> - code (emitForeignCall' PlayInterruptible results - (CmmCallee expr' convention) args vols NoC_SRT ret) - -adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] + expr <- expr_code + args <- sequence args_code + let + expr' = adjCallTarget dflags conv expr args + (arg_exprs, arg_hints) = unzip args + (res_regs, res_hints) = unzip results + fc = ForeignConvention conv arg_hints res_hints ret + target = ForeignTarget expr' fc + _ <- code $ emitForeignCall safety res_regs target arg_exprs + return () + + +doReturn :: [CmmParse CmmExpr] -> CmmParse () +doReturn exprs_code = do + dflags <- getDynFlags + exprs <- sequence exprs_code + updfr_off <- getUpdFrameOff + emit (mkReturnSimple dflags exprs updfr_off) + +doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () +doRawJump expr_code vols = do + dflags <- getDynFlags + expr <- expr_code + updfr_off <- getUpdFrameOff + emit (mkRawJump dflags expr updfr_off vols) + +doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] + -> [CmmParse CmmExpr] -> CmmParse () +doJumpWithStack expr_code stk_code args_code = do + dflags <- getDynFlags + expr <- expr_code + stk_args <- sequence stk_code + args <- sequence args_code + updfr_off <- getUpdFrameOff + emit (mkJumpExtra dflags expr args updfr_off stk_args) + +doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] + -> CmmParse () +doCall expr_code res_code args_code = do + dflags <- getDynFlags + expr <- expr_code + args <- sequence args_code + ress <- sequence res_code + updfr_off <- getUpdFrameOff + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + emit c + +adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ] -> CmmExpr -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention. adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args | platformOS (targetPlatform dflags) == OSMinGW32 = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) + where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) -- c.f. CgForeignCall.emitForeignCall adjCallTarget _ _ expr _ = expr primCall - :: [ExtFCode HintedCmmFormal] - -> FastString - -> [ExtFCode HintedCmmActual] - -> Maybe [GlobalReg] - -> CmmSafety - -> P ExtCode -primCall results_code name args_code vols safety + :: [CmmParse (CmmFormal, ForeignHint)] + -> FastString + -> [CmmParse CmmExpr] + -> P (CmmParse ()) +primCall results_code name args_code = case lookupUFM callishMachOps name of Nothing -> fail ("unknown primitive " ++ unpackFS name) - Just p -> return $ do - results <- sequence results_code - args <- sequence args_code - case safety of - CmmUnsafe -> - code (emitForeignCall' PlayRisky results - (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) - CmmSafe srt -> - code (emitForeignCall' PlaySafe results - (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where - CmmInterruptible -> - code (emitForeignCall' PlayInterruptible results - (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) - -doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode + Just p -> return $ do + results <- sequence results_code + args <- sequence args_code + code (emitPrimCall (map fst results) p args) + +doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () doStore rep addr_code val_code = do dflags <- getDynFlags addr <- addr_code @@ -940,19 +1132,7 @@ doStore rep addr_code val_code let coerce_val | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] | otherwise = val - stmtEC (CmmStore addr coerce_val) - --- Return an unboxed tuple. -emitRetUT :: [(CgRep,CmmExpr)] -> Code -emitRetUT args = do - dflags <- getDynFlags - tickyUnboxedTupleReturn (length args) -- TICK - (sp, stmts, live) <- pushUnboxedTuple 0 args - emitSimultaneously stmts -- NB. the args might overlap with the stack slots - -- or regs that we assign to, so better use - -- simultaneous assignments here (#3546) - when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp))) - stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live) + emitStore addr coerce_val -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions @@ -966,16 +1146,16 @@ data BoolExpr -- ToDo: smart constructors which simplify the boolean expression. cmmIfThenElse cond then_part else_part = do - then_id <- code newLabelC - join_id <- code newLabelC + then_id <- newBlockId + join_id <- newBlockId c <- cond emitCond c then_id else_part - stmtEC (CmmBranch join_id) - code (labelC then_id) + emit (mkBranch join_id) + emitLabel then_id then_part -- fall through to join - code (labelC join_id) + emitLabel join_id cmmRawIf cond then_id = do c <- cond @@ -984,30 +1164,32 @@ cmmRawIf cond then_id = do -- 'emitCond cond true_id' emits code to test whether the cond is true, -- branching to true_id if so, and falling through otherwise. emitCond (BoolTest e) then_id = do - stmtEC (CmmCondBranch e then_id) + else_id <- newBlockId + emit (mkCbranch e then_id else_id) + emitLabel else_id emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id | Just op' <- maybeInvertComparison op = emitCond (BoolTest (CmmMachOp op' args)) then_id emitCond (BoolNot e) then_id = do - else_id <- code newLabelC + else_id <- newBlockId emitCond e else_id - stmtEC (CmmBranch then_id) - code (labelC else_id) + emit (mkBranch then_id) + emitLabel else_id emitCond (e1 `BoolOr` e2) then_id = do emitCond e1 then_id emitCond e2 then_id emitCond (e1 `BoolAnd` e2) then_id = do -- we'd like to invert one of the conditionals here to avoid an - -- extra branch instruction, but we can't use maybeInvertComparison - -- here because we can't look too closely at the expression since - -- we're in a loop. - and_id <- code newLabelC - else_id <- code newLabelC + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- newBlockId + else_id <- newBlockId emitCond e1 and_id - stmtEC (CmmBranch else_id) - code (labelC and_id) + emit (mkBranch else_id) + emitLabel and_id emitCond e2 then_id - code (labelC else_id) + emitLabel else_id -- ----------------------------------------------------------------------------- @@ -1020,38 +1202,45 @@ emitCond (e1 `BoolAnd` e2) then_id = do -- optional range on the switch (eg. switch [0..7] {...}), or by -- the minimum/maximum values from the branches. -doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)] - -> Maybe ExtCode -> ExtCode +doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))] + -> Maybe (CmmParse ()) -> CmmParse () doSwitch mb_range scrut arms deflt = do - -- Compile code for the default branch - dflt_entry <- - case deflt of - Nothing -> return Nothing - Just e -> do b <- forkLabelledCodeEC e; return (Just b) - - -- Compile each case branch - table_entries <- mapM emitArm arms - - -- Construct the table - let - all_entries = concat table_entries - ixs = map fst all_entries - (min,max) - | Just (l,u) <- mb_range = (l,u) - | otherwise = (minimum ixs, maximum ixs) - - entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max) - all_entries) - expr <- scrut - -- ToDo: check for out of range and jump to default if necessary - stmtEC (CmmSwitch expr entries) + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCode e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + + -- Construct the table + let + all_entries = concat table_entries + ixs = map fst all_entries + (min,max) + | Just (l,u) <- mb_range = (l,u) + | otherwise = (minimum ixs, maximum ixs) + + entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max) + all_entries) + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + emit (mkSwitch expr entries) where - emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)] - emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] - emitArm (ints,Right code) = do - blockid <- forkLabelledCodeEC code - return [ (i,blockid) | i <- ints ] + emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCode code + return [ (i,blockid) | i <- ints ] + +forkLabelledCode :: CmmParse () -> CmmParse BlockId +forkLabelledCode p = do + ag <- getCode p + l <- newBlockId + emitOutOfLine l ag + return l -- ----------------------------------------------------------------------------- -- Putting it all together diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 5fca9e7164..4f5d3b926c 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -52,7 +52,7 @@ cmmPipeline hsc_env topSRT prog = cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) -cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = +cpsTop hsc_env proc = do ----------- Control-flow optimisations ---------------------------------- @@ -60,10 +60,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) -- later passes by removing lots of empty blocks, so we do it -- even when optimisation isn't turned on. -- - g <- {-# SCC "cmmCfgOpts(1)" #-} - return $ cmmCfgOpts splitting_proc_points g + CmmProc h l g <- {-# SCC "cmmCfgOpts(1)" #-} + return $ cmmCfgOptsProc splitting_proc_points proc dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g + let !TopInfo {stack_info=StackInfo { arg_space = entry_off + , do_layout = do_layout }} = h + ----------- Eliminate common blocks ------------------------------------- g <- {-# SCC "elimCommonBlocks" #-} condPass Opt_CmmElimCommonBlocks elimCommonBlocks g @@ -95,7 +98,9 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Layout the stack and manifest Sp ---------------------------- (g, stackmaps) <- {-# SCC "layoutStack" #-} - runUniqSM $ cmmLayoutStack dflags proc_points entry_off g + if do_layout + then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g + else return (g, mapEmpty) dump Opt_D_dump_cmmz_sp "Layout Stack" g ----------- Sink and inline assignments *after* stack layout ------------ diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 471faf8b0c..19f0155908 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -291,7 +291,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of (lbl, Just info_lbl) | bid == entry - -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info}) + -> CmmProc (TopInfo {info_tbls = info_tbls, + stack_info = stack_info}) top_l (replacePPIds g) | otherwise -> CmmProc (TopInfo {info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl), stack_info=stack_info}) @@ -300,7 +301,9 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info}) lbl (replacePPIds g) where - stack_info = StackInfo 0 Nothing -- panic "No StackInfo" + stack_info = StackInfo { arg_space = 0 + , updfr_space = Nothing + , do_layout = True } -- cannot use panic, this is printed by -ddump-cmmz -- References to procpoint IDs can now be replaced with the diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 2ff9b98d2a..6dccdabe89 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -6,6 +6,7 @@ module CmmSink ( import CodeGen.Platform (callerSaves) import Cmm +import CmmOpt import BlockId import CmmLive import CmmUtils @@ -13,8 +14,7 @@ import Hoopl import DynFlags import UniqFM --- import PprCmm () --- import Outputable +import PprCmm () import Data.List (partition) import qualified Data.Set as Set @@ -76,9 +76,11 @@ import qualified Data.Set as Set -- *but*, that will invalidate the liveness analysis, and we'll have -- to re-do it. --- TODO: things that we aren't optimising very well yet. +-- ----------------------------------------------------------------------------- +-- things that we aren't optimising very well yet. -- --- From GHC's FastString.hashStr: +-- ----------- +-- (1) From GHC's FastString.hashStr: -- -- s2ay: -- if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp; @@ -95,6 +97,26 @@ import qualified Data.Set as Set -- a nice loop, but we didn't eliminate the silly assignment at the end. -- See Note [dependent assignments], which would probably fix this. -- +-- ----------- +-- (2) From stg_atomically_frame in PrimOps.cmm +-- +-- We have a diamond control flow: +-- +-- x = ... +-- | +-- / \ +-- A B +-- \ / +-- | +-- use of x +-- +-- Now x won't be sunk down to its use, because we won't push it into +-- both branches of the conditional. We certainly do have to check +-- that we can sink it past all the code in both A and B, but having +-- discovered that, we could sink it to its use. +-- + +-- ----------------------------------------------------------------------------- type Assignment = (LocalReg, CmmExpr, AbsMem) -- Assignment caches AbsMem, an abstraction of the memory read by @@ -130,7 +152,8 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks -- Now sink and inline in this block (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) - (final_last, assigs') = tryToInline dflags live last assigs + fold_last = constantFold dflags last + (final_last, assigs') = tryToInline dflags live fold_last assigs -- We cannot sink into join points (successors with more than -- one predecessor), so identify the join points and the set @@ -246,13 +269,24 @@ walk dflags nodes assigs = go nodes emptyBlock assigs go [] block as = (block, as) go ((live,node):ns) block as | shouldDiscard node live = go ns block as - | Just a <- shouldSink dflags node1 = go ns block (a : as1) + | Just a <- shouldSink dflags node2 = go ns block (a : as1) | otherwise = go ns block' as' where - (node1, as1) = tryToInline dflags live node as + node1 = constantFold dflags node + + (node2, as1) = tryToInline dflags live node1 as + + (dropped, as') = dropAssignmentsSimple dflags + (\a -> conflicts dflags a node2) as1 + + block' = foldl blockSnoc block dropped `blockSnoc` node2 + - (dropped, as') = dropAssignmentsSimple dflags (\a -> conflicts dflags a node1) as1 - block' = foldl blockSnoc block dropped `blockSnoc` node1 +constantFold :: DynFlags -> CmmNode e x -> CmmNode e x +constantFold dflags node = mapExpDeep f node + where f (CmmMachOp op args) = cmmMachOpFold dflags op args + f (CmmRegOff r 0) = CmmReg r + f e = e -- -- Heuristic to decide whether to pick up and sink an assignment @@ -352,6 +386,8 @@ tryToInline dflags live node assigs = go usages node [] assigs where inline (CmmReg (CmmLocal l')) | l == l' = rhs inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset dflags rhs off + -- re-constant fold after inlining + inline (CmmMachOp op args) = cmmMachOpFold dflags op args inline other = other go usages node skipped (assig@(l,rhs,_) : rest) @@ -416,7 +452,8 @@ conflicts dflags (r, rhs, addr) node | foldRegsUsed (\b r' -> r == r' || b) False node = True -- (2) a store to an address conflicts with a read of the same memory - | CmmStore addr' e <- node, memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True + | CmmStore addr' e <- node + , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True -- (3) an assignment to Hp/Sp conflicts with a heap/stack read respectively | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True @@ -526,5 +563,6 @@ loadAddr dflags e w = regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) regAddr _ (CmmGlobal Hp) _ _ = HeapMem +regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself regAddr _ _ _ _ = AnyMem diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index d6da5a4022..9a443c1ae2 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -15,6 +15,8 @@ module CmmType , rEP_CostCentreStack_mem_alloc , rEP_CostCentreStack_scc_count , rEP_StgEntCounter_allocs + + , ForeignHint(..) ) where @@ -52,7 +54,8 @@ instance Outputable CmmType where instance Outputable CmmCat where ppr FloatCat = ptext $ sLit("F") - ppr _ = ptext $ sLit("I") + ppr GcPtrCat = ptext $ sLit("P") + ppr BitsCat = ptext $ sLit("I") -- Why is CmmType stratified? For native code generation, -- most of the time you just want to know what sort of register @@ -242,6 +245,19 @@ narrowS W64 x = fromIntegral (fromIntegral x :: Int64) narrowS _ _ = panic "narrowTo" ------------------------------------------------------------------------- +-- Hints + +-- Hints are extra type information we attach to the arguments and +-- results of a foreign call, where more type information is sometimes +-- needed by the ABI to make the correct kind of call. + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + +------------------------------------------------------------------------- -- These don't really belong here, but I don't know where is best to -- put them. diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index bf93a2f6ff..f420e7d94e 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -22,6 +22,7 @@ module CmmUtils( mkWordCLit, packHalfWordsCLit, mkByteStringCLit, mkDataLits, mkRODataLits, + mkStgWordCLit, -- CmmExpr mkIntExpr, zeroExpr, @@ -120,6 +121,8 @@ typeForeignHint = primRepForeignHint . typePrimRep -- --------------------------------------------------- +-- XXX: should really be Integer, since Int doesn't necessarily cover +-- the full range of target Ints. mkIntCLit :: DynFlags -> Int -> CmmLit mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) @@ -132,6 +135,9 @@ zeroCLit dflags = CmmInt 0 (wordWidth dflags) zeroExpr :: DynFlags -> CmmExpr zeroExpr dflags = CmmLit (zeroCLit dflags) +mkWordCLit :: DynFlags -> Integer -> CmmLit +mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) + mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) -- We have to make a top-level decl for the string, -- and return a literal pointing to it @@ -155,8 +161,8 @@ mkRODataLits lbl lits needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkWordCLit :: DynFlags -> StgWord -> CmmLit -mkWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) +mkStgWordCLit :: DynFlags -> StgWord -> CmmLit +mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags) packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit -- Make a single word literal in which the lower_half_word is @@ -168,8 +174,8 @@ packHalfWordsCLit dflags lower_half_word upper_half_word = if wORDS_BIGENDIAN dflags then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u) else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags)) - where l = toStgWord dflags (fromStgHalfWord lower_half_word) - u = toStgWord dflags (fromStgHalfWord upper_half_word) + where l = fromStgHalfWord lower_half_word + u = fromStgHalfWord upper_half_word --------------------------------------------------- -- @@ -197,6 +203,9 @@ cmmOffset _ e 0 = e cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) +cmmOffset _ (CmmStackSlot area off) byte_off + = CmmStackSlot area (off - byte_off) + -- note stack area offsets increase towards lower addresses cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 = CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] @@ -207,6 +216,7 @@ cmmOffset dflags expr byte_off -- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. cmmRegOff :: CmmReg -> Int -> CmmExpr +cmmRegOff reg 0 = CmmReg reg cmmRegOff reg byte_off = CmmRegOff reg byte_off cmmOffsetLit :: CmmLit -> Int -> CmmLit diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 4ba82cd8f8..1e2ddfadd1 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -9,9 +9,10 @@ module MkGraph , stackStubExpr , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo , mkJumpReturnsTo - , mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC + , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra + , mkRawJump , mkCbranch, mkSwitch - , mkReturn, mkComment, mkCallEntry, mkBranch + , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch , copyInOflow, copyOutOflow , noExtraStack , toCall, Transfer(..) @@ -20,7 +21,7 @@ where import BlockId import Cmm -import CmmCallConv (assignArgumentsPos, ParamLocation(..)) +import CmmCallConv import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) @@ -161,11 +162,11 @@ outOfLine l g = unitOL (CgFork l g) -- | allocate a fresh label for the entry point lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph lgraphOfAGraph g = do u <- getUniqueM - return (flattenCmmAGraph (mkBlockId u) g) + return (labelAGraph (mkBlockId u) g) -- | use the given BlockId as the label of the entry point -labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph -labelAGraph lbl ag = return (flattenCmmAGraph lbl ag) +labelAGraph :: BlockId -> CmmAGraph -> CmmGraph +labelAGraph lbl ag = flattenCmmAGraph lbl ag ---------- No-ops mkNop :: CmmAGraph @@ -194,16 +195,25 @@ mkJump dflags e actuals updfr_off = lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0 -mkDirectJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset +-- | A jump where the caller says what the live GlobalRegs are. Used +-- for low-level hand-written Cmm. +mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] -> CmmAGraph -mkDirectJump dflags e actuals updfr_off = - lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $ +mkRawJump dflags e updfr_off vols = + lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $ + \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols + + +mkJumpExtra :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset + -> [CmmActual] -> CmmAGraph +mkJumpExtra dflags e actuals updfr_off extra_stack = + lastWithArgsAndExtraStack dflags Jump Old NativeNodeCall actuals updfr_off extra_stack $ toCall e Nothing updfr_off 0 -mkJumpGC :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset +mkDirectJump :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkJumpGC dflags e actuals updfr_off = - lastWithArgs dflags Jump Old GC actuals updfr_off $ +mkDirectJump dflags e actuals updfr_off = + lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0 mkForeignJump :: DynFlags @@ -213,7 +223,7 @@ mkForeignJump dflags conv e actuals updfr_off = mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual] - -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)]) + -> UpdFrameOffset -> [CmmActual] -> CmmAGraph mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack = lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ @@ -231,6 +241,11 @@ mkReturn dflags e actuals updfr_off = lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 +mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple dflags actuals updfr_off = + mkReturn dflags e actuals updfr_off + where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags) + mkBranch :: BlockId -> CmmAGraph mkBranch bid = mkLast (CmmBranch bid) @@ -245,7 +260,7 @@ mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual] -> BlockId -> ByteOff -> UpdFrameOffset - -> (ByteOff, [(CmmExpr,ByteOff)]) + -> [CmmActual] -> CmmAGraph mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals @@ -282,39 +297,40 @@ stackStubExpr :: Width -> CmmExpr stackStubExpr w = CmmLit (CmmInt 0 w) -- When we copy in parameters, we usually want to put overflow --- parameters on the stack, but sometimes we want to pass --- the variables in their spill slots. --- Therefore, for copying arguments and results, we provide different --- functions to pass the arguments in an overflow area and to pass them in spill slots. -copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal] +-- parameters on the stack, but sometimes we want to pass the +-- variables in their spill slots. Therefore, for copying arguments +-- and results, we provide different functions to pass the arguments +-- in an overflow area and to pass them in spill slots. +copyInOflow :: DynFlags -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] -> (Int, CmmAGraph) -copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes) - where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals - -type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) -> - (ByteOff, [CmmNode O O]) -type CopyIn = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O]) +copyInOflow dflags conv area formals extra_stk + = (offset, catAGraphs $ map mkMiddle nodes) + where (offset, nodes) = copyIn dflags conv area formals extra_stk -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. -copyIn :: CopyIn -copyIn dflags oflow conv area formals = - foldr ci (init_offset, []) args' - where ci (reg, RegisterParam r) (n, ms) = - (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) - ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) - init_offset = widthInBytes (wordWidth dflags) -- infotable - args = assignArgumentsPos dflags conv localRegType formals - args' = foldl adjust [] args - where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst - adjust rst x@(_, RegisterParam _) = x : rst - --- Copy-in one arg, using overflow space if needed. -oneCopyOflowI :: SlotCopier -oneCopyOflowI area (reg, off) (n, ms) = - (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms) - where ty = localRegType reg +copyIn :: DynFlags -> Convention -> Area + -> [CmmFormal] + -> [CmmFormal] + -> (ByteOff, [CmmNode O O]) +copyIn dflags conv area formals extra_stk + = (stk_size, map ci (stk_args ++ args)) + where + ci (reg, RegisterParam r) = + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + ci (reg, StackParam off) = + CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) + where ty = localRegType reg + + init_offset = widthInBytes (wordWidth dflags) -- infotable + + (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk + + (stk_size, args) = assignArgumentsPos dflags stk_off conv + localRegType formals -- Factoring out the common parts of the copyout functions yielded something -- more complicated: @@ -323,7 +339,7 @@ data Transfer = Call | JumpRet | Jump | Ret deriving Eq copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset - -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff + -> [CmmActual] -- extra stack args -> (Int, [GlobalReg], CmmAGraph) -- Generate code to move the actual parameters into the locations @@ -335,22 +351,20 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual] -- the info table for return and adjust the offsets of the other -- parameters. If this is a call instruction, we adjust the offsets -- of the other parameters. -copyOutOflow dflags conv transfer area actuals updfr_off - (extra_stack_off, extra_stack_stuff) - = foldr co (init_offset, [], mkNop) (args' ++ stack_params) - where - co (v, RegisterParam r) (n, rs, ms) - = (n, r:rs, mkAssign (CmmGlobal r) v <*> ms) - co (v, StackParam off) (n, rs, ms) - = (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms) - - stack_params = [ (e, StackParam (off + init_offset)) - | (e,off) <- extra_stack_stuff ] +copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff + = (stk_size, regs, graph) + where + (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) + + co (v, RegisterParam r) (rs, ms) + = (r:rs, mkAssign (CmmGlobal r) v <*> ms) + co (v, StackParam off) (rs, ms) + = (rs, mkStore (CmmStackSlot area off) v <*> ms) (setRA, init_offset) = case area of - Young id -> id `seq` -- Generate a store instruction for - -- the return address if making a call + Young id -> -- Generate a store instruction for + -- the return address if making a call case transfer of Call -> ([(CmmLit (CmmBlock id), StackParam init_offset)], @@ -362,19 +376,19 @@ copyOutOflow dflags conv transfer area actuals updfr_off ([], 0) Old -> ([], updfr_off) - arg_offset = init_offset + extra_stack_off + (extra_stack_off, stack_params) = + assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it - args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals - - args' = foldl adjust setRA args - where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst - adjust rst x@(_, RegisterParam _) = x : rst + (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv + (cmmExprType dflags) actuals -mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph) -mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals +mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] + -> (Int, CmmAGraph) +mkCallEntry dflags conv formals extra_stk + = copyInOflow dflags conv Old formals extra_stk lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset @@ -386,7 +400,7 @@ lastWithArgs dflags transfer area conv actuals updfr_off last = lastWithArgsAndExtraStack :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual] - -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)]) + -> UpdFrameOffset -> [CmmActual] -> (ByteOff -> [GlobalReg] -> CmmAGraph) -> CmmAGraph lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off @@ -397,8 +411,8 @@ lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off updfr_off extra_stack -noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)]) -noExtraStack = (0,[]) +noExtraStack :: [CmmActual] +noExtraStack = [] toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> [GlobalReg] diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 05aa5fb811..3d0599b7ea 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -16,7 +16,7 @@ module OldCmm ( GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, - CmmStmt(..), CmmReturnInfo(..), CmmHinted(..), + CmmStmt(..), New.CmmReturnInfo(..), CmmHinted(..), HintedCmmFormal, HintedCmmActual, CmmSafety(..), CmmCallTarget(..), @@ -120,11 +120,6 @@ cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) cmmTopMapGraph _ (CmmData s ds) = CmmData s ds -data CmmReturnInfo - = CmmMayReturn - | CmmNeverReturns - deriving ( Eq ) - ----------------------------------------------------------------------------- -- CmmStmt -- A "statement". Note that all branches are explicit: there are no @@ -145,7 +140,7 @@ data CmmStmt CmmCallTarget [HintedCmmFormal] -- zero or more results [HintedCmmActual] -- zero or more arguments - CmmReturnInfo + New.CmmReturnInfo -- Some care is necessary when handling the arguments of these, see -- [Register parameter passing] and the hack in cmm/CmmOpt.hs diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index a3857d4e47..dcde86e37c 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -111,12 +111,8 @@ pprStmt stmt = case stmt of pp_lhs | null results = empty | otherwise = commafy (map ppr_ar results) <+> equals -- Don't print the hints on a native C-- call - ppr_ar (CmmHinted ar k) = case cconv of - CmmCallConv -> ppr ar - _ -> ppr (ar,k) - pp_conv = case cconv of - CmmCallConv -> empty - _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) + ppr_ar (CmmHinted ar k) = ppr (ar,k) + pp_conv = ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. CmmCall (CmmPrim op _) results args ret -> diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 1a3eb0d716..a2427df868 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -865,7 +865,6 @@ is_cishCC :: CCallConv -> Bool is_cishCC CCallConv = True is_cishCC CApiConv = True is_cishCC StdCallConv = True -is_cishCC CmmCallConv = False is_cishCC PrimCallConv = False -- --------------------------------------------------------------------- diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 423bcd5504..f3e2a02737 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -75,6 +75,8 @@ instance Outputable ForeignConvention where instance Outputable ForeignTarget where ppr = pprForeignTarget +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo instance Outputable (Block CmmNode C C) where ppr = pprBlock @@ -145,17 +147,18 @@ pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>" pprConvention (NativeReturn {}) = text "<native-ret-convention>" pprConvention Slow = text "<slow-convention>" pprConvention GC = text "<gc-convention>" -pprConvention PrimOpCall = text "<primop-call-convention>" -pprConvention PrimOpReturn = text "<primop-ret-convention>" pprForeignConvention :: ForeignConvention -> SDoc -pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = ptext (sLit "never returns") pprForeignTarget :: ForeignTarget -> SDoc -pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn - where ppr_fc :: ForeignConvention -> SDoc - ppr_fc (ForeignConvention c args res) = - doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res +pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn + where ppr_target :: CmmExpr -> SDoc ppr_target t@(CmmLit _) = ppr t ppr_target fn' = parens (ppr fn') diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index d9644488fc..ac021df761 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -30,6 +30,7 @@ module SMRep ( -- ** Predicates isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, + isStackRep, -- ** Size-related things heapClosureSize, @@ -148,7 +149,7 @@ data SMRep Liveness | RTSRep -- The RTS needs to declare info tables with specific - StgHalfWord -- type tags, so this form lets us override the default + Int -- type tags, so this form lets us override the default SMRep -- tag for an SMRep. -- | True <=> This is a static closure. Affects how we garbage-collect it. @@ -166,10 +167,10 @@ data ClosureTypeInfo | ThunkSelector SelectorOffset | BlackHole -type ConstrTag = StgHalfWord +type ConstrTag = Int type ConstrDescription = [Word8] -- result of dataConIdentity -type FunArity = StgHalfWord -type SelectorOffset = StgWord +type FunArity = Int +type SelectorOffset = Int ------------------------- -- We represent liveness bitmaps as a Bitmap (whose internal @@ -188,7 +189,7 @@ type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead data ArgDescr = ArgSpec -- Fits one of the standard patterns - !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ... + !Int -- RTS type identifier ARG_P, ARG_N, ... | ArgGen -- General case Liveness -- Details about the arguments @@ -212,7 +213,7 @@ mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info hdr_size = closureTypeHdrSize dflags cl_type_info payload_size = ptr_wds + nonptr_wds -mkRTSRep :: StgHalfWord -> SMRep -> SMRep +mkRTSRep :: Int -> SMRep -> SMRep mkRTSRep = RTSRep mkStackRep :: [Bool] -> SMRep @@ -229,6 +230,11 @@ isStaticRep (HeapRep is_static _ _ _) = is_static isStaticRep (StackRep {}) = False isStaticRep (RTSRep _ rep) = isStaticRep rep +isStackRep :: SMRep -> Bool +isStackRep StackRep{} = True +isStackRep (RTSRep _ rep) = isStackRep rep +isStackRep _ = False + isConRep :: SMRep -> Bool isConRep (HeapRep _ _ _ Constr{}) = True isConRep _ = False @@ -314,11 +320,10 @@ closureTypeHdrSize dflags ty = case ty of -- Defines CONSTR, CONSTR_1_0 etc -- | Derives the RTS closure type from an 'SMRep' -rtsClosureType :: DynFlags -> SMRep -> StgHalfWord -rtsClosureType dflags rep - = toStgHalfWord dflags - $ case rep of - RTSRep ty _ -> fromStgHalfWord ty +rtsClosureType :: SMRep -> Int +rtsClosureType rep + = case rep of + RTSRep ty _ -> ty HeapRep False 1 0 Constr{} -> CONSTR_1_0 HeapRep False 0 1 Constr{} -> CONSTR_0_1 @@ -355,11 +360,11 @@ rtsClosureType dflags rep _ -> panic "rtsClosureType" -- We export these ones -rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: DynFlags -> StgHalfWord -rET_SMALL dflags = toStgHalfWord dflags RET_SMALL -rET_BIG dflags = toStgHalfWord dflags RET_BIG -aRG_GEN dflags = toStgHalfWord dflags ARG_GEN -aRG_GEN_BIG dflags = toStgHalfWord dflags ARG_GEN_BIG +rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int +rET_SMALL = RET_SMALL +rET_BIG = RET_BIG +aRG_GEN = ARG_GEN +aRG_GEN_BIG = ARG_GEN_BIG \end{code} Note [Static NoCaf constructors] diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 1f5b711d86..d548741e1f 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -70,7 +70,7 @@ mkArgDescr _nm args let arg_bits = argBits dflags arg_reps arg_reps = filter nonVoidArg (map idCgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern dflags arg_reps of + case stdPattern arg_reps of Just spec_id -> return (ArgSpec spec_id) Nothing -> return (ArgGen arg_bits) @@ -79,10 +79,9 @@ argBits _ [] = [] argBits dflags (PtrArg : args) = False : argBits dflags args argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args -stdPattern :: DynFlags -> [CgRep] -> Maybe StgHalfWord -stdPattern dflags reps - = fmap (toStgHalfWord dflags) - $ case reps of +stdPattern :: [CgRep] -> Maybe Int +stdPattern reps + = case reps of [] -> Just ARG_NONE -- just void args, probably [PtrArg] -> Just ARG_P diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index aeb87235e3..858de3a616 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -189,7 +189,7 @@ buildDynCon' dflags platform binder _ con [arg_amode] , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags - = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") + = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW) @@ -201,7 +201,7 @@ buildDynCon' dflags platform binder _ con [arg_amode] , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") + = do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW) diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 965abf0db8..8cff77381d 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -415,7 +415,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code { dflags <- getDynFlags ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! - (CmmLit (mkWordCLit dflags liveness)) + (CmmLit (mkStgWordCLit dflags liveness)) liveness = mkRegLiveness dflags regs ptrs nptrs live = Just $ map snd regs rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index c124b5f68a..03e01b332a 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -258,7 +258,7 @@ dynLdvInit :: DynFlags -> CmmExpr dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], - CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags)) + CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) ] -- @@ -289,8 +289,8 @@ ldvEnter cl_ptr = do -- don't forget to substract node's tag ldv_wd = ldvWord dflags cl_ptr new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags)))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags)))) + (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | @@ -308,10 +308,3 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) -lDV_CREATE_MASK :: DynFlags -> StgWord -lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags) -lDV_STATE_CREATE :: DynFlags -> StgWord -lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags) -lDV_STATE_USE :: DynFlags -> StgWord -lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags) - diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 3a106abfb4..9f9a2cfe26 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -800,8 +800,8 @@ getSRTInfo = do let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl ( cmmLabelOffW dflags srt_lbl off - : mkWordCLit dflags (toStgWord dflags (toInteger len)) - : map (mkWordCLit dflags) bmp) + : mkWordCLit dflags (toInteger len) + : map (mkWordCLit dflags . fromStgWord) bmp) return (C_SRT srt_desc_lbl 0 (srt_escape dflags)) | otherwise diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 740bfab845..f2cbc21d27 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -480,7 +480,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr -- anything else gets eta expanded. where name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) nonptr_wds = tot_wds - ptr_wds mkConInfo :: DynFlags @@ -492,7 +492,7 @@ mkConInfo dflags is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con } where - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) lf_info = mkConLFInfo data_con nonptr_wds = tot_wds - ptr_wds \end{code} @@ -526,16 +526,16 @@ closureNeedsUpdSpace cl_info = closureUpdReqd cl_info %************************************************************************ \begin{code} -lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo -lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd -lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con))) - (dataConIdentity con) -lfClosureType dflags (LFThunk _ _ _ is_sel _) = thunkClosureType dflags is_sel -lfClosureType _ _ = panic "lfClosureType" - -thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo -thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off)) -thunkClosureType _ _ = Thunk +lfClosureType :: LambdaFormInfo -> ClosureTypeInfo +lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) + (dataConIdentity con) +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" + +thunkClosureType :: StandardFormInfo -> ClosureTypeInfo +thunkClosureType (SelectorThunk off) = ThunkSelector off +thunkClosureType _ = Thunk -- We *do* get non-updatable top-level thunks sometimes. eg. f = g -- gets compiled to a jump to g (if g has non-zero arity), instead of diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 37ca5e0d43..67aae3f6c0 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -245,7 +245,7 @@ cgDataCon data_con arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] -- Dynamic closure code for non-nullary constructors only - ; whenC (not (isNullaryRepDataCon data_con)) + ; when (not (isNullaryRepDataCon data_con)) (emit_info dyn_info_tbl tickyEnterDynCon) -- Dynamic-Closure first, to reduce forward references diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 89d27dd161..5e46dcfd65 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -10,7 +10,7 @@ module StgCmmBind ( cgTopRhsClosure, cgBind, emitBlackHoleCode, - pushUpdateFrame + pushUpdateFrame, emitUpdateFrame ) where #include "HsVersions.h" @@ -37,7 +37,6 @@ import CLabel import StgSyn import CostCentre import Id -import Control.Monad import Name import Module import ListSetOps @@ -48,6 +47,8 @@ import FastString import Maybes import DynFlags +import Control.Monad + ------------------------------------------------------------------------ -- Top-level bindings ------------------------------------------------------------------------ @@ -460,7 +461,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg , mkIntExpr dflags (funTag dflags cl_info) ]) - ; whenC node_points (ldvEnterClosure cl_info) + ; when node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points -- Main payload @@ -525,8 +526,8 @@ thunkCode cl_info fv_details _cc node arity body ; entryHeapCheck cl_info node' arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check - ; whenC (blackHoleOnEntry cl_info && node_points) - (blackHoleIt cl_info) + ; when (blackHoleOnEntry cl_info && node_points) + (blackHoleIt cl_info node) -- Push update frame ; setupUpdate cl_info node $ @@ -545,13 +546,14 @@ thunkCode cl_info fv_details _cc node arity body -- Update and black-hole wrappers ------------------------------------------------------------------------ -blackHoleIt :: ClosureInfo -> FCode () +blackHoleIt :: ClosureInfo -> LocalReg -> FCode () -- Only called for closures with no args -- Node points to the closure -blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) +blackHoleIt closure_info node + = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node)) -emitBlackHoleCode :: Bool -> FCode () -emitBlackHoleCode is_single_entry = do +emitBlackHoleCode :: Bool -> CmmExpr -> FCode () +emitBlackHoleCode is_single_entry node = do dflags <- getDynFlags -- Eager blackholing is normally disabled, but can be turned on with @@ -578,12 +580,12 @@ emitBlackHoleCode is_single_entry = do -- profiling), so currently eager blackholing doesn't -- work with profiling. - whenC eager_blackholing $ do + when eager_blackholing $ do tickyBlackHole (not is_single_entry) - emitStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags)) + emitStore (cmmOffsetW dflags node (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] - emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) + emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), @@ -634,13 +636,20 @@ pushUpdateFrame lbl updatee body let hdr = fixedHdrSize dflags * wORD_SIZE dflags frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags -- - emitStore (CmmStackSlot Old frame) (mkLblExpr lbl) - emitStore (CmmStackSlot Old (frame - off_updatee)) updatee - initUpdFrameProf frame + emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee withUpdFrameOff frame body +emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode () +emitUpdateFrame dflags frame lbl updatee = do + let + hdr = fixedHdrSize dflags * wORD_SIZE dflags + off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags + -- + emitStore frame (mkLblExpr lbl) + emitStore (cmmOffset dflags frame off_updatee) updatee + initUpdFrameProf frame + ----------------------------------------------------------------------------- -- Entering a CAF -- diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 4be5bd3d0c..f865c37ad8 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -353,16 +353,16 @@ isLFReEntrant _ = False -- Choosing SM reps ----------------------------------------------------------------------------- -lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo -lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd -lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con))) - (dataConIdentity con) -lfClosureType dflags (LFThunk _ _ _ is_sel _) = thunkClosureType dflags is_sel -lfClosureType _ _ = panic "lfClosureType" +lfClosureType :: LambdaFormInfo -> ClosureTypeInfo +lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd +lfClosureType (LFCon con) = Constr (dataConTagZ con) + (dataConIdentity con) +lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel +lfClosureType _ = panic "lfClosureType" -thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo -thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off)) -thunkClosureType _ _ = Thunk +thunkClosureType :: StandardFormInfo -> ClosureTypeInfo +thunkClosureType (SelectorThunk off) = ThunkSelector off +thunkClosureType _ = Thunk -- We *do* get non-updatable top-level thunks sometimes. eg. f = g -- gets compiled to a jump to g (if g has non-zero arity), instead of @@ -373,8 +373,6 @@ thunkClosureType _ _ = Thunk -- nodeMustPointToIt ----------------------------------------------------------------------------- --- Be sure to see the stg-details notes about these... - nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) = not no_fvs || -- Certainly if it has fvs we need to point to it @@ -687,7 +685,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr closureProf = prof } -- (we don't have an SRT yet) where name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info) + sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) prof = mkProfilingInfo dflags id val_descr nonptr_wds = tot_wds - ptr_wds @@ -899,8 +897,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type - cl_type = Constr (toStgHalfWord dflags (toInteger (dataConTagZ data_con))) - (dataConIdentity data_con) + cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr val_descr diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index c822a64e2c..8e775dec51 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -185,7 +185,7 @@ buildDynCon' dflags platform binder _cc con [arg] , StgLitArg (MachInt val) <- arg , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") + = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") val_int = fromIntegral val :: Int offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload @@ -200,7 +200,7 @@ buildDynCon' dflags platform binder _cc con [arg] , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") + = do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index a8ffc12bb0..a0859252ff 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -717,12 +717,12 @@ emitEnter fun = do -- AssignTo res_regs _ -> do { lret <- newLabelC - ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs + ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] ; lcall <- newLabelC ; updfr_off <- getUpdFrameOff ; let area = Young lret ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area - [fun] updfr_off (0,[]) + [fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index a651319a49..b0608227ae 100644 --- a/compiler/codeGen/CgExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -9,44 +9,36 @@ -- to collect declarations as we parse the proc, and feed the environment -- back in circularly (to avoid a two-pass algorithm). -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgExtCode ( - ExtFCode(..), - ExtCode, - Named(..), Env, +module StgCmmExtCode ( + CmmParse(..), + Named(..), Env, loopDecls, getEnv, newLocal, - newLabel, + newLabel, + newBlockId, newFunctionName, newImport, lookupLabel, lookupName, code, - code2, - nopEC, - stmtEC, - stmtsEC, - getCgStmtsEC, - getCgStmtsEC', - forkLabelledCodeEC + emit, emitLabel, emitAssign, emitStore, + getCode, getCodeR, + emitOutOfLine, + withUpdFrameOff, getUpdFrameOff ) where -import CgMonad +import qualified StgCmmMonad as F +import StgCmmMonad (FCode, newUnique) +import Cmm import CLabel -import OldCmm hiding( ClosureTypeInfo(..) ) +import MkGraph -- import BasicTypes import BlockId @@ -73,22 +65,22 @@ type Decls = [(FastString,Named)] -- | Does a computation in the FCode monad, with a current environment -- and a list of local declarations. Returns the resulting list of declarations. -newtype ExtFCode a +newtype CmmParse a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } -type ExtCode = ExtFCode () +type ExtCode = CmmParse () -returnExtFC :: a -> ExtFCode a +returnExtFC :: a -> CmmParse a returnExtFC a = EC $ \_ s -> return (s, a) -thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b +thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' -instance Monad ExtFCode where +instance Monad CmmParse where (>>=) = thenExtFC return = returnExtFC -instance HasDynFlags ExtFCode where +instance HasDynFlags CmmParse where getDynFlags = EC (\_ d -> do dflags <- getDynFlags return (d, dflags)) @@ -99,15 +91,15 @@ instance HasDynFlags ExtFCode where -- procedure, and imports that scope over the entire module. -- Discards the local declaration contained within decl' -- -loopDecls :: ExtFCode a -> ExtFCode a +loopDecls :: CmmParse a -> CmmParse a loopDecls (EC fcode) = EC $ \e globalDecls -> do - (_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) + (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) return (globalDecls, a) -- | Get the current environment from the monad. -getEnv :: ExtFCode Env +getEnv :: CmmParse Env getEnv = EC $ \e s -> return (s, e) @@ -127,7 +119,7 @@ addLabel name block_id newLocal :: CmmType -- ^ data type -> FastString -- ^ name of variable - -> ExtFCode LocalReg -- ^ register holding the value + -> CmmParse LocalReg -- ^ register holding the value newLocal ty name = do u <- code newUnique @@ -137,12 +129,14 @@ newLocal ty name = do -- | Allocate a fresh label. -newLabel :: FastString -> ExtFCode BlockId +newLabel :: FastString -> CmmParse BlockId newLabel name = do u <- code newUnique addLabel name (mkBlockId u) return (mkBlockId u) +newBlockId :: CmmParse BlockId +newBlockId = code F.newLabelC -- | Add add a local function to the environment. newFunctionName @@ -159,7 +153,7 @@ newFunctionName name pkg -- over the whole module. newImport :: (FastString, CLabel) - -> ExtFCode () + -> CmmParse () newImport (name, cmmLabel) = addVarDecl name (CmmLit (CmmLabel cmmLabel)) @@ -168,7 +162,7 @@ newImport (name, cmmLabel) -- | Lookup the BlockId bound to the label with this name. -- If one hasn't been bound yet, create a fresh one based on the -- Unique of the name. -lookupLabel :: FastString -> ExtFCode BlockId +lookupLabel :: FastString -> CmmParse BlockId lookupLabel name = do env <- getEnv return $ @@ -181,7 +175,7 @@ lookupLabel name = do -- Unknown names are treated as if they had been 'import'ed from the runtime system. -- This saves us a lot of bother in the RTS sources, at the expense of -- deferring some errors to link time. -lookupName :: FastString -> ExtFCode CmmExpr +lookupName :: FastString -> CmmParse CmmExpr lookupName name = do env <- getEnv return $ @@ -191,51 +185,40 @@ lookupName name = do _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) --- | Lift an FCode computation into the ExtFCode monad -code :: FCode a -> ExtFCode a +-- | Lift an FCode computation into the CmmParse monad +code :: FCode a -> CmmParse a code fc = EC $ \_ s -> do r <- fc return (s, r) +emit :: CmmAGraph -> CmmParse () +emit = code . F.emit -code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c -code2 f (EC ec) - = EC $ \e s -> do - ((s', _),c) <- f (ec e s) - return (s',c) +emitLabel :: BlockId -> CmmParse () +emitLabel = code. F.emitLabel +emitAssign :: CmmReg -> CmmExpr -> CmmParse () +emitAssign l r = code (F.emitAssign l r) --- | Do nothing in the ExtFCode monad. -nopEC :: ExtFCode () -nopEC = code nopC +emitStore :: CmmExpr -> CmmExpr -> CmmParse () +emitStore l r = code (F.emitStore l r) +getCode :: CmmParse a -> CmmParse CmmAGraph +getCode (EC ec) = EC $ \e s -> do + ((s',_), gr) <- F.getCodeR (ec e s) + return (s', gr) --- | Accumulate a CmmStmt into the monad state. -stmtEC :: CmmStmt -> ExtFCode () -stmtEC stmt = code (stmtC stmt) +getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph) +getCodeR (EC ec) = EC $ \e s -> do + ((s', r), gr) <- F.getCodeR (ec e s) + return (s', (r,gr)) +emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse () +emitOutOfLine l g = code (F.emitOutOfLine l g) --- | Accumulate some CmmStmts into the monad state. -stmtsEC :: [CmmStmt] -> ExtFCode () -stmtsEC stmts = code (stmtsC stmts) - - --- | Get the generated statements out of the monad state. -getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts -getCgStmtsEC = code2 getCgStmts' - - --- | Get the generated statements, and the return value out of the monad state. -getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts) -getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f) - where f ((decl, b), c) = return ((decl, b), (b, c)) - - --- | Emit a chunk of code outside the instruction stream, --- and return its block id. -forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId -forkLabelledCodeEC ec = do - stmts <- getCgStmtsEC ec - code (forkCgStmts stmts) - +withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse () +withUpdFrameOff size inner + = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s +getUpdFrameOff :: CmmParse UpdFrameOffset +getUpdFrameOff = code $ F.getUpdFrameOff diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 9e4db9cdaa..1830f7b6d6 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -9,9 +9,10 @@ module StgCmmForeign ( cgForeignCall, loadThreadState, saveThreadState, emitPrimCall, emitCCall, + emitForeignCall, -- For CmmParse emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto - emitOpenNursery, + emitCloseNursery, emitOpenNursery ) where #include "HsVersions.h" @@ -24,10 +25,8 @@ import StgCmmUtils import StgCmmClosure import StgCmmLayout -import BlockId import Cmm import CmmUtils -import OldCmm ( CmmReturnInfo(..) ) import MkGraph import Type import TysPrim @@ -85,7 +84,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty DynamicTarget -> case cmm_args of (fn,_):rest -> (unzip rest, fn) [] -> panic "cgForeignCall []" - fc = ForeignConvention cconv arg_hints res_hints + fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn call_target = ForeignTarget cmm_target fc -- we want to emit code for the call, and then emitReturn. @@ -100,12 +99,10 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty ; sequel <- getSequel ; case sequel of AssignTo assign_to_these _ -> - emitForeignCall safety assign_to_these call_target - call_args CmmMayReturn + emitForeignCall safety assign_to_these call_target call_args _something_else -> - do { _ <- emitForeignCall safety res_regs call_target - call_args CmmMayReturn + do { _ <- emitForeignCall safety res_regs call_target call_args ; emitReturn (map (CmmReg . CmmLocal) res_regs) } } @@ -183,17 +180,17 @@ emitCCall :: [(CmmFormal,ForeignHint)] -> [(CmmActual,ForeignHint)] -> FCode () emitCCall hinted_results fn hinted_args - = void $ emitForeignCall PlayRisky results target args CmmMayReturn + = void $ emitForeignCall PlayRisky results target args where (args, arg_hints) = unzip hinted_args (results, result_hints) = unzip hinted_results target = ForeignTarget fn fc - fc = ForeignConvention CCallConv arg_hints result_hints + fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args - = void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn + = void $ emitForeignCall PlayRisky res (PrimTarget op) args -- alternative entry point, used by CmmParse emitForeignCall @@ -201,10 +198,8 @@ emitForeignCall -> [CmmFormal] -- where to put the results -> ForeignTarget -- the op -> [CmmActual] -- arguments - -> CmmReturnInfo -- This can say "never returns" - -- only RTS procedures do this -> FCode ReturnKind -emitForeignCall safety results target args _ret +emitForeignCall safety results target args | not (playSafe safety) = do dflags <- getDynFlags let (caller_save, caller_load) = callerSaveVolatileRegs dflags @@ -218,7 +213,7 @@ emitForeignCall safety results target args _ret updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target k <- newLabelC - let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results + let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results [] -- see Note [safe foreign call convention] emit $ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) @@ -285,17 +280,15 @@ saveThreadState dflags = mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS else mkNop -emitSaveThreadState :: BlockId -> FCode () -emitSaveThreadState bid = do +emitSaveThreadState :: FCode () +emitSaveThreadState = do dflags <- getDynFlags + emit (saveThreadState dflags) - -- CurrentTSO->stackobj->sp = Sp; - emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) - (CmmStackSlot (Young bid) (widthInBytes (typeWidth (gcWord dflags)))) - emit $ closeNursery dflags - -- and save the current cost centre stack in the TSO when profiling: - when (dopt Opt_SccProfilingOn dflags) $ - emitStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS +emitCloseNursery :: FCode () +emitCloseNursery = do + df <- getDynFlags + emit (closeNursery df) -- CurrentNursery->free = Hp+1; closeNursery :: DynFlags -> CmmAGraph @@ -303,8 +296,6 @@ closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags st loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph loadThreadState dflags tso stack = do - -- tso <- newTemp (gcWord dflags) -- TODO FIXME NOW - -- stack <- newTemp (gcWord dflags) -- TODO FIXME NOW catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, @@ -321,9 +312,18 @@ loadThreadState dflags tso stack = do storeCurCCS (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags)) else mkNop] -emitLoadThreadState :: LocalReg -> LocalReg -> FCode () -emitLoadThreadState tso stack = do dflags <- getDynFlags - emit $ loadThreadState dflags tso stack + +emitLoadThreadState :: FCode () +emitLoadThreadState = do + dflags <- getDynFlags + load_tso <- newTemp (gcWord dflags) + load_stack <- newTemp (gcWord dflags) + emit $ loadThreadState dflags load_tso load_stack + +emitOpenNursery :: FCode () +emitOpenNursery = do + df <- getDynFlags + emit (openNursery df) openNursery :: DynFlags -> CmmAGraph openNursery dflags = catAGraphs [ @@ -345,9 +345,6 @@ openNursery dflags = catAGraphs [ ) ) ] -emitOpenNursery :: FCode () -emitOpenNursery = do dflags <- getDynFlags - emit $ openNursery dflags nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs index 2abca3fe16..fe00d7c384 100644 --- a/compiler/codeGen/StgCmmGran.hs +++ b/compiler/codeGen/StgCmmGran.hs @@ -53,7 +53,7 @@ staticGranHdr = [] doGranAllocate :: CmmExpr -> Code -- macro DO_GRAN_ALLOCATE doGranAllocate hp - | not opt_GranMacros = nopC + | not opt_GranMacros = return () | otherwise = panic "doGranAllocate" @@ -75,7 +75,7 @@ granFetchAndReschedule regs node_reqd = do { fetch ; reschedule liveness node_reqd } | otherwise - = nopC + = return () where liveness = mkRegLiveness regs 0 0 @@ -109,7 +109,7 @@ granYield :: [(Id,GlobalReg)] -- Live registers granYield regs node_reqd | opt_GranMacros && node_reqd = yield liveness - | otherwise = nopC + | otherwise = return () where liveness = mkRegLiveness regs 0 0 diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index b7cca48f5a..c133ab00d4 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -11,6 +11,8 @@ module StgCmmHeap ( getHpRelOffset, hpRel, entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo, + heapStackCheckGen, + entryHeapCheck', mkVirtHeapOffsets, mkVirtConstrOffsets, mkStaticClosureFields, mkStaticClosure, @@ -47,6 +49,7 @@ import FastString( mkFastString, fsLit ) import Util import Control.Monad (when) +import Data.Maybe (isJust) ----------------------------------------------------------- -- Initialise dynamic heap objects @@ -334,16 +337,28 @@ entryHeapCheck :: ClosureInfo -> FCode () entryHeapCheck cl_info nodeSet arity args code + = entryHeapCheck' is_fastf node arity args code + where + node = case nodeSet of + Just r -> CmmReg (CmmLocal r) + Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info) + + is_fastf = case closureFunInfo cl_info of + Just (_, ArgGen _) -> False + _otherwise -> True + +-- | lower-level version for CmmParse +entryHeapCheck' :: Bool -- is a known function pattern + -> CmmExpr -- expression for the closure pointer + -> Int -- Arity -- not same as len args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) + -> FCode () + -> FCode () +entryHeapCheck' is_fastf node arity args code = do dflags <- getDynFlags let is_thunk = arity == 0 - is_fastf = case closureFunInfo cl_info of - Just (_, ArgGen _) -> False - _otherwise -> True args' = map (CmmReg . CmmLocal) args - node = case nodeSet of - Just r -> CmmReg (CmmLocal r) - Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info) stg_gc_fun = CmmReg (CmmGlobal GCFun) stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) @@ -373,50 +388,6 @@ entryHeapCheck cl_info nodeSet arity args code emitLabel loop_id heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code -{- - -- This code is slightly outdated now and we could easily keep the above - -- GC methods. However, there may be some performance gains to be made by - -- using more specialised GC entry points. Since the semi generic GCFun - -- entry needs to check the node and figure out what registers to save... - -- if we provided and used more specialised GC entry points then these - -- runtime decisions could be turned into compile time decisions. - - args' = case fun of Just f -> f : args - Nothing -> args - arg_exprs = map (CmmReg . CmmLocal) args' - gc_call updfr_sz - | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz - | otherwise = - case gc_lbl args' of - Just _lbl -> panic "StgCmmHeap.entryHeapCheck: not finished" - -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) - -- arg_exprs updfr_sz - Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz - - gc_lbl :: [LocalReg] -> Maybe FastString - gc_lbl [reg] - | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p" - | isFloatType ty = case width of - W32 -> Just (sLit "stg_gc_f1") - W64 -> Just (sLit "stg_gc_d1") - _other -> Nothing - | width == wordWidth dflags = Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 = Just (mkGcLabel "stg_gc_l1") - | otherwise = Nothing - where - ty = localRegType reg - width = typeWidth ty - - gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs) - - gc_lbl_ptrs :: [Bool] -> Maybe FastString - -- JD: TEMPORARY -- UNTIL THESE FUNCTIONS EXIST... - --gc_lbl_ptrs [True,True] = Just (sLit "stg_gc_fun_2p") - --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p") - gc_lbl_ptrs _ = Nothing --} - - -- ------------------------------------------------------------ -- A heap/stack check in a case alternative @@ -445,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do Nothing -> genericGC checkYield code Just gc -> do lret <- newLabelC - let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs + let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] lcont <- newLabelC emitOutOfLine lret (copyin <*> mkBranch lcont) emitLabel lcont @@ -475,23 +446,29 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code reg_exprs = map (CmmReg . CmmLocal) regs -- Note [stg_gc arguments] + -- NB. we use the NativeReturn convention for passing arguments + -- to the canned heap-check routines, because we are in a case + -- alternative and hence the [LocalReg] was passed to us in the + -- NativeReturn convention. gc_call dflags label sp - | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp - | otherwise = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[]) + | cont_on_stack + = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp + | otherwise + = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp [] genericGC :: Bool -> FCode a -> FCode a genericGC checkYield code = do updfr_sz <- getUpdFrameOff lretry <- newLabelC emitLabel lretry - call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[]) + call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] heapCheck False checkYield (call <*> mkBranch lretry) code cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr cannedGCEntryPoint dflags regs - = case regs of + = case map localRegType regs of [] -> Just (mkGcLabel "stg_gc_noregs") - [reg] + [ty] | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1") | isFloatType ty -> case width of W32 -> Just (mkGcLabel "stg_gc_f1") @@ -502,8 +479,19 @@ cannedGCEntryPoint dflags regs | width == W64 -> Just (mkGcLabel "stg_gc_l1") | otherwise -> Nothing where - ty = localRegType reg width = typeWidth ty + [ty1,ty2] + | isGcPtrType ty1 + && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp") + [ty1,ty2,ty3] + | isGcPtrType ty1 + && isGcPtrType ty2 + && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp") + [ty1,ty2,ty3,ty4] + | isGcPtrType ty1 + && isGcPtrType ty2 + && isGcPtrType ty3 + && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp") _otherwise -> Nothing -- Note [stg_gc arguments] @@ -538,51 +526,70 @@ heapCheck checkStack checkYield do_gc code = getHeapUsage $ \ hpHw -> -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole - do { codeOnly $ do_checks checkStack checkYield hpHw do_gc + do { dflags <- getDynFlags + ; let mb_alloc_bytes + | hpHw > 0 = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags))) + | otherwise = Nothing + stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) + | otherwise = Nothing + ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc ; tickyAllocHeap hpHw ; doGranAllocate hpHw ; setRealHp hpHw ; code } -do_checks :: Bool -- Should we check the stack? +heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode () +heapStackCheckGen stk_hwm mb_bytes + = do updfr_sz <- getUpdFrameOff + lretry <- newLabelC + emitLabel lretry + call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] + do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry) + +do_checks :: Maybe CmmExpr -- Should we check the stack? -> Bool -- Should we check for preemption? - -> WordOff -- Heap headroom + -> Maybe CmmExpr -- Heap headroom (bytes) -> CmmAGraph -- What to do on failure -> FCode () -do_checks checkStack checkYield alloc do_gc = do +do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do dflags <- getDynFlags + gc_id <- newLabelC + let - alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes - bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit + Just alloc_lit = mb_alloc_lit + + bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit -- Sp overflow if (Sp - CmmHighStack < SpLim) - sp_oflo = CmmMachOp (mo_wordULt dflags) + sp_oflo sp_hwm = + CmmMachOp (mo_wordULt dflags) [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) - [CmmReg spReg, CmmLit CmmHighStackMark], + [CmmReg spReg, sp_hwm], CmmReg spLimReg] -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. hp_oflo = CmmMachOp (mo_wordUGt dflags) - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - - -- Yielding if HpLim == 0 - yielding = CmmMachOp (mo_wordEq dflags) - [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit dflags)] + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit - gc_id <- newLabelC - when checkStack $ do - emit =<< mkCmmIfGoto sp_oflo gc_id + case mb_stk_hwm of + Nothing -> return () + Just stk_hwm -> emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id - if (alloc /= 0) + if (isJust mb_alloc_lit) then do - emitAssign hpReg bump_hp - emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) + emitAssign hpReg bump_hp + emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) else do - when (not (dopt Opt_OmitYields dflags) && checkYield) (emit =<< mkCmmIfGoto yielding gc_id) + when (not (dopt Opt_OmitYields dflags) && checkYield) $ do + -- Yielding if HpLim == 0 + let yielding = CmmMachOp (mo_wordEq dflags) + [CmmReg (CmmGlobal HpLim), + CmmLit (zeroCLit dflags)] + emit =<< mkCmmIfGoto yielding gc_id emitOutOfLine gc_id $ do_gc -- this is expected to jump back somewhere diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index cb60e9dd71..85f4c161ad 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -19,6 +19,8 @@ import StgCmmUtils import HscTypes import DynFlags +import Control.Monad + mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph mkTickBox dflags mod n = mkStore tick_box (CmmMachOp (MO_Add W64) @@ -36,7 +38,7 @@ initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = do dflags <- getDynFlags - whenC (dopt Opt_Hpc dflags) $ + when (dopt Opt_Hpc dflags) $ do emitDataLits (mkHpcTicksLabel this_mod) [ (CmmInt 0 W64) | _ <- take tickCount [0 :: Int ..] diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 75d8d1c38f..4742332107 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -111,7 +111,7 @@ emitCall convs fun args -- emitCallWithExtraStack :: (Convention, Convention) -> CmmExpr -> [CmmExpr] - -> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind + -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack = do { dflags <- getDynFlags ; adjustHpBackwards @@ -124,7 +124,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack AssignTo res_regs _ -> do k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area res_regs + (off, copyin) = copyInOflow dflags retConv area res_regs [] copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off extra_stack emit (copyout <*> mkLabel k <*> copyin) @@ -222,7 +222,7 @@ direct_call caller call_conv lbl arity args emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (mkStkOffsets dflags (stack_args dflags)) + (nonVArgs (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -326,32 +326,7 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) ------------------------------------------------------------------------- --- Fix the byte-offsets of a bunch of things to push on the stack - --- This is used for pushing slow-call continuations. --- See Note [over-saturated calls]. - -mkStkOffsets - :: DynFlags - -> [(ArgRep, Maybe CmmExpr)] -- things to make offsets for - -> ( ByteOff -- OUTPUTS: Topmost allocated word - , [(CmmExpr, ByteOff)] ) -- things with offsets (voids filtered out) -mkStkOffsets dflags things - = loop 0 [] (reverse things) - where - loop offset offs [] = (offset,offs) - loop offset offs ((_,Nothing):things) = loop offset offs things - -- ignore Void arguments - loop offset offs ((rep,Just thing):things) - = loop thing_off ((thing, thing_off):offs) things - where - thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags - -- offset of thing is offset+size, because we're - -- growing the stack *downwards* as the offsets increase. - - -------------------------------------------------------------------------- --- Classifying arguments: ArgRep +-- Classifying arguments: ArgRep ------------------------------------------------------------------------- -- ArgRep is not exported (even abstractly) @@ -472,7 +447,7 @@ mkArgDescr _nm args let arg_bits = argBits dflags arg_reps arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern dflags arg_reps of + case stdPattern arg_reps of Just spec_id -> return (ArgSpec spec_id) Nothing -> return (ArgGen arg_bits) @@ -483,10 +458,9 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) ++ argBits dflags args ---------------------- -stdPattern :: DynFlags -> [ArgRep] -> Maybe StgHalfWord -stdPattern dflags reps - = fmap (toStgHalfWord dflags) - $ case reps of +stdPattern :: [ArgRep] -> Maybe Int +stdPattern reps + = case reps of [] -> Just ARG_NONE -- just void args, probably [N] -> Just ARG_N [P] -> Just ARG_P @@ -545,7 +519,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body ; let args' = if node_points then (node : arg_regs) else arg_regs conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall else NativeDirectCall - (offset, _) = mkCallEntry dflags conv args' + (offset, _) = mkCallEntry dflags conv args' [] ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index fb290d8e96..b7797bdae6 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -18,15 +18,16 @@ module StgCmmMonad ( FCode, -- type initC, runC, thenC, thenFC, listCs, - returnFC, nopC, whenC, + returnFC, fixC, newUnique, newUniqSupply, newLabelC, emitLabel, - emit, emitDecl, emitProc, emitProcWithConvention, emitSimpleProc, + emit, emitDecl, emitProc, + emitProcWithConvention, emitProcWithStackFrame, emitOutOfLine, emitAssign, emitStore, emitComment, - getCmm, cgStmtsToBlocks, + getCmm, aGraphToGraph, getCodeR, getCode, getHeapUsage, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, @@ -89,7 +90,30 @@ infixr 9 `thenFC` -------------------------------------------------------- --- The FCode monad and its types +-- The FCode monad and its types +-- +-- FCode is the monad plumbed through the Stg->Cmm code generator, and +-- the Cmm parser. It contains the following things: +-- +-- - A writer monad, collecting: +-- - code for the current function, in the form of a CmmAGraph. +-- The function "emit" appends more code to this. +-- - the top-level CmmDecls accumulated so far +-- +-- - A state monad with: +-- - the local bindings in scope +-- - the current heap usage +-- - a UniqSupply +-- +-- - A reader monad, for CgInfoDownwards, containing +-- - DynFlags, +-- - the current Module +-- - the static top-level environmnet +-- - the update-frame offset +-- - the ticky counter label +-- - the Sequel (the continuation to return to) + + -------------------------------------------------------- newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #)) @@ -120,13 +144,6 @@ thenC (FCode m) (FCode k) = FCode $ \info_down state -> case m info_down state of (# _,new_state #) -> k info_down new_state -nopC :: FCode () -nopC = return () - -whenC :: Bool -> FCode () -> FCode () -whenC True code = code -whenC False _code = nopC - listCs :: [FCode ()] -> FCode () listCs [] = return () listCs (fc:fcs) = do @@ -141,6 +158,15 @@ thenFC (FCode m) k = FCode $ case k m_result of FCode kcode -> kcode info_down new_state +fixC :: (a -> FCode a) -> FCode a +fixC fcode = FCode ( + \info_down state -> + let + (v,s) = doFCode (fcode v) info_down state + in + (# v, s #) + ) + -------------------------------------------------------- -- The code generator environment -------------------------------------------------------- @@ -478,7 +504,7 @@ getSequel = do { info <- getInfoDown -- Note: I'm including the size of the original return address -- in the size of the update frame -- hence the default case on `get'. -withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode () +withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code = do { info <- getInfoDown ; withInfoDown code (info {cgd_updfr_off = size }) } @@ -675,31 +701,60 @@ emitDecl decl emitOutOfLine :: BlockId -> CmmAGraph -> FCode () emitOutOfLine l stmts = emitCgStmt (CgFork l stmts) +emitProcWithStackFrame + :: Convention -- entry convention + -> Maybe CmmInfoTable -- info table? + -> CLabel -- label for the proc + -> [CmmFormal] -- stack frame + -> [CmmFormal] -- arguments + -> CmmAGraph -- code + -> Bool -- do stack layout? + -> FCode () + +emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False + = do { dflags <- getDynFlags + ; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False + } +emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout + = do { dflags <- getDynFlags + ; let (offset, entry) = mkCallEntry dflags conv args stk_args + ; emitProc_ mb_info lbl (entry <*> blocks) offset True + } +emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame" + emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel - -> [CmmFormal] -> CmmAGraph -> FCode () + -> [CmmFormal] + -> CmmAGraph + -> FCode () emitProcWithConvention conv mb_info lbl args blocks + = emitProcWithStackFrame conv mb_info lbl [] args blocks True + +emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode () +emitProc mb_info lbl blocks offset + = emitProc_ mb_info lbl blocks offset True + +emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool + -> FCode () +emitProc_ mb_info lbl blocks offset do_layout = do { dflags <- getDynFlags - ; us <- newUniqSupply - ; let (offset, entry) = mkCallEntry dflags conv args - blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks - ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)} - tinfo = TopInfo {info_tbls = infos, stack_info=sinfo} - proc_block = CmmProc tinfo lbl blks + ; l <- newLabelC + ; let + blks = labelAGraph l blocks - infos | Just info <- mb_info - = mapSingleton (g_entry blks) info - | otherwise - = mapEmpty + infos | Just info <- mb_info = mapSingleton (g_entry blks) info + | otherwise = mapEmpty - ; state <- getState - ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } + sinfo = StackInfo { arg_space = offset + , updfr_space = Just (initUpdFrameOff dflags) + , do_layout = do_layout } + + tinfo = TopInfo { info_tbls = infos + , stack_info=sinfo} -emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () -emitProc = emitProcWithConvention NativeNodeCall + proc_block = CmmProc tinfo lbl blks -emitSimpleProc :: CLabel -> CmmAGraph -> FCode () -emitSimpleProc lbl code = - emitProc Nothing lbl [] code + ; state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } getCmm :: FCode () -> FCode CmmGroup -- Get all the CmmTops (there should be no stmts) @@ -735,29 +790,25 @@ mkCmmIfThen e tbranch = do mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] - -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph + -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags k <- newLabelC let area = Young k - (off, copyin) = copyInOflow dflags retConv area results + (off, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack return (copyout <*> mkLabel k <*> copyin) mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> FCode CmmAGraph mkCmmCall f results actuals updfr_off - = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[]) + = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off [] -- ---------------------------------------------------------------------------- --- CgStmts - --- These functions deal in terms of CgStmts, which is an abstract type --- representing the code in the current proc. +-- turn CmmAGraph into CmmGraph, for making a new proc. --- turn CgStmts into [CmmBasicBlock], for making a new proc. -cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph -cgStmtsToBlocks stmts - = do { us <- newUniqSupply - ; return (initUs_ us (lgraphOfAGraph stmts)) } +aGraphToGraph :: CmmAGraph -> FCode CmmGraph +aGraphToGraph stmts + = do { l <- newLabelC + ; return (labelAGraph l stmts) } diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index cbb2aa70bd..97104ce4a2 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -97,7 +97,7 @@ cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args } + ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args @@ -130,7 +130,7 @@ cgOpApp (StgPrimOp primop) args res_ty cgOpApp (StgPrimCallOp primcall) args _res_ty = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) - ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args } + ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } --------------------------------------------------- cgPrimOp :: [LocalReg] -- where to put the results diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index b666554403..1b218462e1 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -82,24 +82,22 @@ costCentreFrom :: DynFlags -> CmmExpr -- The cost centre from that closure costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) +-- | The profiling header words in a static closure staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] --- The profiling header words in a static closure --- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] +-- | Profiling header words in a dynamic closure dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] --- Profiling header words in a dynamic closure dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] -initUpdFrameProf :: ByteOff -> FCode () --- Initialise the profiling field of an update frame -initUpdFrameProf frame_off +-- | Initialise the profiling field of an update frame +initUpdFrameProf :: CmmExpr -> FCode () +initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS do dflags <- getDynFlags - emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags)) - curCCS - -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) + emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS + -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. --------------------------------------------------------------------------- @@ -200,7 +198,7 @@ ifProfiling code = do dflags <- getDynFlags if dopt Opt_SccProfilingOn dflags then code - else nopC + else return () ifProfilingL :: DynFlags -> [a] -> [a] ifProfilingL dflags xs @@ -216,7 +214,7 @@ initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) = do dflags <- getDynFlags - whenC (dopt Opt_SccProfilingOn dflags) $ + when (dopt Opt_SccProfilingOn dflags) $ do mapM_ emitCostCentreDecl local_CCs mapM_ emitCostCentreStackDecl singleton_CCSs @@ -283,7 +281,7 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push = do dflags <- getDynFlags if not (dopt Opt_SccProfilingOn dflags) - then nopC + then return () else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW pushCostCentre tmp curCCS cc when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) @@ -321,7 +319,7 @@ dynLdvInit :: DynFlags -> CmmExpr dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], - CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags)) + CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) ] -- @@ -350,8 +348,8 @@ ldvEnter cl_ptr = do let -- don't forget to substract node's tag ldv_wd = ldvWord dflags cl_ptr new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) - (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags)))) - (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags)))) + (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | @@ -371,10 +369,3 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) -lDV_CREATE_MASK :: DynFlags -> StgWord -lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags) -lDV_STATE_CREATE :: DynFlags -> StgWord -lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags) -lDV_STATE_USE :: DynFlags -> StgWord -lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags) - diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 79ad3ff822..01babb212f 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -333,7 +333,7 @@ tickyAllocHeap hp ifTicky :: FCode () -> FCode () ifTicky code = do dflags <- getDynFlags if dopt Opt_Ticky dflags then code - else nopC + else return () -- All the ticky-ticky counters are declared "unsigned long" in C bumpTickyCounter :: FastString -> FCode () diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 386e7f46d6..138e00ee52 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -36,7 +36,6 @@ module StgCmmUtils ( addToMem, addToMemE, addToMemLbl, mkWordCLit, newStringCLit, newByteStringCLit, - packHalfWordsCLit, blankWord ) where @@ -196,9 +195,9 @@ emitRtsCallGen res pkg fun args safe call updfr_off = if safe then emit =<< mkCmmCall fun_expr res' args' updfr_off - else - emit $ mkUnsafeCall (ForeignTarget fun_expr - (ForeignConvention CCallConv arg_hints res_hints)) res' args' + else do + let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn + emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 6d83150eb6..888ff1a0be 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -214,7 +214,6 @@ Library CgClosure CgCon CgExpr - CgExtCode CgForeignCall CgHeapery CgHpc @@ -244,6 +243,7 @@ Library StgCmmProf StgCmmTicky StgCmmUtils + StgCmmExtCode ClosureInfo SMRep CoreArity diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 448bd4d94c..207a237b7e 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -274,7 +274,6 @@ genCall env target res args ret = do CCallConv -> CC_Ccc CApiConv -> CC_Ccc PrimCallConv -> CC_Ccc - CmmCallConv -> panic "CmmCallConv not supported here!" {- Some of the possibilities here are a worry with the use of a custom diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 04f89bf63e..62a472037b 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1349,7 +1349,11 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - rawCmms <- cmmToRawCmm dflags (Stream.yield cmm) + us <- mkSplitUniqSupply 'S' + let initTopSRT = initUs_ us emptySRT + dumpIfSet_dyn dflags Opt_D_dump_cmmz "Parsed Cmm" (ppr cmm) + (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm + rawCmms <- cmmToRawCmm dflags (Stream.yield (cmmOfZgraph cmmgroup)) _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 47fd96c426..d0e4a17746 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -971,12 +971,13 @@ cmmStmtConFold stmt cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = do dflags <- getDynFlags - -- Skip constant folding if new code generator is running - -- (this optimization is done in Hoopl) - -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off - let expr' = if False -- dopt Opt_TryNewCodeGen dflags + + -- With -O1 and greater, the cmmSink pass does constant-folding, so + -- we don't need to do it again here. + let expr' = if optLevel dflags >= 1 then expr else cmmExprCon dflags expr + cmmExprNative referenceKind expr' cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index a15bca07e7..3f1efe5824 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -434,10 +434,21 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) - raInsn _ _ _ instr = pprPanic "raInsn" (text "no match for:" <> ppr instr) +-- ToDo: what can we do about +-- +-- R1 = x +-- jump I64[x] // [R1] +-- +-- where x is mapped to the same reg as R1. We want to coalesce x and +-- R1, but the register allocator doesn't know whether x will be +-- assigned to again later, in which case x and R1 should be in +-- different registers. Right now we assume the worst, and the +-- assignment to R1 will clobber x, so we'll spill x into another reg, +-- generating another reg->reg move. + isInReg :: Reg -> RegMap Loc -> Bool isInReg src assig | Just (InReg _) <- lookupUFM assig src = True diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index b3a2ad3ff1..b53ae7cf50 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -156,8 +156,7 @@ platforms. See: http://www.programmersheaven.com/2/Calling-conventions \begin{code} -data CCallConv = CCallConv | CApiConv | StdCallConv - | CmmCallConv | PrimCallConv +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv deriving (Eq, Data, Typeable) {-! derive: Binary !-} @@ -165,7 +164,6 @@ instance Outputable CCallConv where ppr StdCallConv = ptext (sLit "stdcall") ppr CCallConv = ptext (sLit "ccall") ppr CApiConv = ptext (sLit "capi") - ppr CmmCallConv = ptext (sLit "C--") ppr PrimCallConv = ptext (sLit "prim") defaultCCallConv :: CCallConv @@ -175,7 +173,6 @@ ccallConvToInt :: CCallConv -> Int ccallConvToInt StdCallConv = 0 ccallConvToInt CCallConv = 1 ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" -ccallConvToInt (CmmCallConv {}) = panic "ccallConvToInt CmmCallConv" ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" \end{code} @@ -187,7 +184,6 @@ ccallConvAttribute :: CCallConv -> SDoc ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" ccallConvAttribute CCallConv = empty ccallConvAttribute CApiConv = empty -ccallConvAttribute (CmmCallConv {}) = panic "ccallConvAttribute CmmCallConv" ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" \end{code} @@ -326,17 +322,14 @@ instance Binary CCallConv where putByte bh 1 put_ bh PrimCallConv = do putByte bh 2 - put_ bh CmmCallConv = do - putByte bh 3 put_ bh CApiConv = do - putByte bh 4 + putByte bh 3 get bh = do h <- getByte bh case h of 0 -> do return CCallConv 1 -> do return StdCallConv 2 -> do return PrimCallConv - 3 -> do return CmmCallConv _ -> do return CApiConv instance Binary CType where diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 90a174081c..9c8b9807f2 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -464,7 +464,6 @@ checkCConv StdCallConv = do dflags <- getDynFlags return CCallConv checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") return PrimCallConv -checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} Warnings |