diff options
Diffstat (limited to 'compiler/cmm')
-rw-r--r-- | compiler/cmm/CLabel.hs | 15 | ||||
-rw-r--r-- | compiler/cmm/Cmm.hs | 7 | ||||
-rw-r--r-- | compiler/cmm/CmmBuildInfoTables.hs | 7 | ||||
-rw-r--r-- | compiler/cmm/CmmCallConv.hs | 66 | ||||
-rw-r--r-- | compiler/cmm/CmmContFlowOpt.hs | 12 | ||||
-rw-r--r-- | compiler/cmm/CmmCvt.hs | 33 | ||||
-rw-r--r-- | compiler/cmm/CmmInfo.hs | 46 | ||||
-rw-r--r-- | compiler/cmm/CmmLayoutStack.hs | 6 | ||||
-rw-r--r-- | compiler/cmm/CmmLex.x | 16 | ||||
-rw-r--r-- | compiler/cmm/CmmMachOp.hs | 9 | ||||
-rw-r--r-- | compiler/cmm/CmmNode.hs | 46 | ||||
-rw-r--r-- | compiler/cmm/CmmOpt.hs | 21 | ||||
-rw-r--r-- | compiler/cmm/CmmParse.y | 1279 | ||||
-rw-r--r-- | compiler/cmm/CmmPipeline.hs | 13 | ||||
-rw-r--r-- | compiler/cmm/CmmProcPoint.hs | 7 | ||||
-rw-r--r-- | compiler/cmm/CmmSink.hs | 58 | ||||
-rw-r--r-- | compiler/cmm/CmmType.hs | 18 | ||||
-rw-r--r-- | compiler/cmm/CmmUtils.hs | 18 | ||||
-rw-r--r-- | compiler/cmm/MkGraph.hs | 148 | ||||
-rw-r--r-- | compiler/cmm/OldCmm.hs | 9 | ||||
-rw-r--r-- | compiler/cmm/OldPprCmm.hs | 8 | ||||
-rw-r--r-- | compiler/cmm/PprC.hs | 1 | ||||
-rw-r--r-- | compiler/cmm/PprCmm.hs | 17 | ||||
-rw-r--r-- | compiler/cmm/SMRep.lhs | 37 |
24 files changed, 1118 insertions, 779 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] |