diff options
Diffstat (limited to 'compiler/codeGen/StgCmmLayout.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 121 |
1 files changed, 64 insertions, 57 deletions
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 9c17716b1b..0e9cebfea4 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -53,6 +53,7 @@ import Id import Name import TyCon ( PrimRep(..) ) import BasicTypes ( RepArity ) +import DynFlags import StaticFlags import Module @@ -206,12 +207,15 @@ direct_call caller call_conv lbl arity args = emitCall (call_conv, NativeReturn) target (nonVArgs args) | otherwise -- Note [over-saturated calls] - = emitCallWithExtraStack (call_conv, NativeReturn) - target (nonVArgs fast_args) (mkStkOffsets stack_args) + = do dflags <- getDynFlags + emitCallWithExtraStack (call_conv, NativeReturn) + target + (nonVArgs fast_args) + (mkStkOffsets (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args - stack_args = slowArgs rest_args + stack_args dflags = slowArgs dflags rest_args real_arity = case call_conv of NativeNodeCall -> arity+1 _ -> arity @@ -273,11 +277,12 @@ just more arguments that we are passing on the stack (cml_args). -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] -slowArgs [] = [] -slowArgs args -- careful: reps contains voids (V), but args does not - | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest_args - | otherwise = this_pat ++ slowArgs rest_args +slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] +slowArgs _ [] = [] +slowArgs dflags args -- careful: reps contains voids (V), but args does not + | dopt Opt_SccProfilingOn dflags + = save_cccs ++ this_pat ++ slowArgs dflags rest_args + | otherwise = this_pat ++ slowArgs dflags rest_args where (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args @@ -396,7 +401,8 @@ getHpRelOffset virtual_offset ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } mkVirtHeapOffsets - :: Bool -- True <=> is a thunk + :: DynFlags + -> Bool -- True <=> is a thunk -> [(PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* @@ -412,7 +418,7 @@ mkVirtHeapOffsets -- mkVirtHeapOffsets always returns boxed things with smaller offsets -- than the unboxed things -mkVirtHeapOffsets is_thunk things +mkVirtHeapOffsets dflags is_thunk things = let non_void_things = filterOut (isVoidRep . fst) things (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs @@ -420,16 +426,16 @@ mkVirtHeapOffsets is_thunk things in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where - hdr_size | is_thunk = thunkHdrSize - | otherwise = fixedHdrSize + hdr_size | is_thunk = thunkHdrSize dflags + | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) = (wds_so_far + argRepSizeW (toArgRep rep), (NonVoid thing, hdr_size + wds_so_far)) -mkVirtConstrOffsets :: [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) +mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) -- Just like mkVirtHeapOffsets, but for constructors -mkVirtConstrOffsets = mkVirtHeapOffsets False +mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False ------------------------------------------------------------------------- @@ -519,11 +525,12 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body -- top-level binding, which this binding would incorrectly shadow. ; node <- if top_lvl then return $ idToReg (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info - ; let node_points = nodeMustPointToIt lf_info + ; dflags <- getDynFlags + ; let node_points = nodeMustPointToIt dflags lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - conv = if nodeMustPointToIt lf_info then NativeNodeCall - else NativeDirectCall + conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall + else NativeDirectCall (offset, _) = mkCallEntry conv args' ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } @@ -544,32 +551,32 @@ emitClosureAndInfoTable info_tbl conv args body -- ----------------------------------------------------------------------------- -stdInfoTableSizeW :: WordOff +stdInfoTableSizeW :: DynFlags -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable -stdInfoTableSizeW +stdInfoTableSizeW dflags = size_fixed + size_prof where size_fixed = 2 -- layout, type - size_prof | opt_SccProfilingOn = 2 + size_prof | dopt Opt_SccProfilingOn dflags = 2 | otherwise = 0 -stdInfoTableSizeB :: ByteOff -stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff +stdInfoTableSizeB :: DynFlags -> ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE :: ByteOff -stdSrtBitmapOffset :: ByteOff +stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit -stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE +stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE -stdClosureTypeOffset :: ByteOff +stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE -stdPtrsOffset, stdNonPtrsOffset :: ByteOff -stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE -stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -587,65 +594,65 @@ entryCode :: CmmExpr -> CmmExpr entryCode e | tablesNextToCode = e | otherwise = CmmLoad e bWord -getConstrTag :: CmmExpr -> CmmExpr +getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs). -getConstrTag closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table] +getConstrTag dflags closure_ptr + = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] where - info_table = infoTable (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr closure_ptr) -cmmGetClosureType :: CmmExpr -> CmmExpr +cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table -cmmGetClosureType closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table] +cmmGetClosureType dflags closure_ptr + = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] where - info_table = infoTable (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr closure_ptr) -infoTable :: CmmExpr -> CmmExpr +infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) -infoTable info_ptr - | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB) +infoTable dflags info_ptr + | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer -infoTableConstrTag :: CmmExpr -> CmmExpr +infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag -- field of the info table (same as the srt_bitmap field) infoTableConstrTag = infoTableSrtBitmap -infoTableSrtBitmap :: CmmExpr -> CmmExpr +infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table -infoTableSrtBitmap info_tbl - = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord +infoTableSrtBitmap dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord -infoTableClosureType :: CmmExpr -> CmmExpr +infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. -infoTableClosureType info_tbl - = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord +infoTableClosureType dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord -infoTablePtrs :: CmmExpr -> CmmExpr -infoTablePtrs info_tbl - = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord +infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTablePtrs dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord -infoTableNonPtrs :: CmmExpr -> CmmExpr -infoTableNonPtrs info_tbl - = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord +infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr +infoTableNonPtrs dflags info_tbl + = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord -funInfoTable :: CmmExpr -> CmmExpr +funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, -- and returns a pointer to the first word of the StgFunInfoExtra struct -- in the info table. -funInfoTable info_ptr +funInfoTable dflags info_ptr | tablesNextToCode - = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW) + = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer |