-- Describes the layout of a stack frame for a continuation
data StackFormat
- = StackFormat
- (Maybe CLabel) -- The label occupying the top slot
- WordOff -- Total frame size in words
- [(CmmReg, WordOff)] -- local reg offsets from stack top
+ = StackFormat {
+ stack_label :: Maybe CLabel, -- The label occupying the top slot
+ stack_frame_size :: WordOff, -- Total frame size in words (not including arguments)
+ stack_live :: [(CmmReg, WordOff)] -- local reg offsets from stack top
+ -- TODO: see if the above can be LocalReg
+ }
-- A block can be a continuation of a call
-- A block can be a continuation of another block (w/ or w/o joins)
unknown_block = panic "unknown BlockId in continuationToProc"
prefix = case entry of
ControlEntry -> []
- FunctionEntry _ _ -> []
+ FunctionEntry _ formals -> -- TODO: gc_stack_check
+ function_entry formals curr_format
ContinuationEntry formals ->
- unpack_continuation curr_format
+ function_entry formals curr_format
postfix = case exit of
FinalBranch next -> [CmmBranch next]
FinalSwitch expr targets -> [CmmSwitch expr targets]
FinalReturn arguments ->
- exit_function curr_format
+ tail_call (stack_frame_size curr_format)
(CmmLoad (CmmReg spReg) wordRep)
arguments
FinalJump target arguments ->
- exit_function curr_format target arguments
+ tail_call (stack_frame_size curr_format) target arguments
FinalCall next (CmmForeignCall target CmmCallConv)
results arguments ->
pack_continuation curr_format cont_format ++
- [CmmJump target arguments]
+ tail_call (stack_frame_size curr_format - stack_frame_size cont_format)
+ target arguments
where
cont_format = maybe unknown_block id $
lookup (mkReturnPtLabel $ getUnique next) formats
-- for packing/unpacking continuations
-- and entering/exiting functions
-exit_function :: StackFormat -> CmmExpr -> CmmActuals -> [CmmStmt]
-exit_function (StackFormat curr_id curr_frame_size curr_offsets) target arguments
- = adjust_spReg ++ jump where
+tail_call :: WordOff -> CmmExpr -> CmmActuals -> [CmmStmt]
+tail_call spRel target arguments
+ = store_arguments ++ adjust_spReg ++ jump where
+ store_arguments =
+ [stack_put spRel expr offset
+ | ((expr, _), StackParam offset) <- argument_formats] ++
+ [global_put expr global
+ | ((expr, _), RegisterParam global) <- argument_formats]
adjust_spReg =
- if curr_frame_size == 0
+ if spRel == 0
then []
- else [CmmAssign spReg
- (CmmRegOff spReg (curr_frame_size*wORD_SIZE))]
+ else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
jump = [CmmJump target arguments]
-enter_function :: WordOff -> [CmmStmt]
-enter_function max_frame_size
+ argument_formats = assignArguments (cmmExprRep . fst) arguments
+
+gc_stack_check :: WordOff -> [CmmStmt]
+gc_stack_check max_frame_size
= check_stack_limit where
check_stack_limit = [
CmmCondBranch
-- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
-pack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
+pack_continuation (StackFormat curr_id curr_frame_size _)
(StackFormat cont_id cont_frame_size cont_offsets)
- = save_live_values ++ set_stack_header ++ adjust_spReg where
- -- TODO: only save variables when actually needed
- save_live_values =
- [CmmStore
- (CmmRegOff
- spReg (wORD_SIZE*(curr_frame_size - cont_frame_size + offset)))
- (CmmReg reg)
+ = store_live_values ++ set_stack_header where
+ -- TODO: only save variables when actually needed (may be handled by latter pass)
+ store_live_values =
+ [stack_put spRel (CmmReg reg) offset
| (reg, offset) <- cont_offsets]
- needs_header =
- case (curr_id, cont_id) of
- (Just x, Just y) -> x /= y
- _ -> isJust cont_id
set_stack_header =
- if not needs_header
- then []
- else [CmmStore (CmmRegOff spReg (wORD_SIZE*(curr_frame_size - cont_frame_size))) continuation_function]
- continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
- adjust_spReg =
- if curr_frame_size == cont_frame_size
+ if not needs_header
then []
- else [CmmAssign spReg (CmmRegOff spReg ((curr_frame_size - cont_frame_size)*wORD_SIZE))]
+ else [stack_put spRel continuation_function 0]
+
+ spRel = curr_frame_size - cont_frame_size
+ continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
+ needs_header =
+ case (curr_id, cont_id) of
+ (Just x, Just y) -> x /= y
+ _ -> isJust cont_id
-- Lazy adjustment of stack headers assumes all blocks
-- that could branch to eachother (i.e. control blocks)
-- have the same stack format (this causes a problem
-- only for proc-point).
-unpack_continuation :: StackFormat -> [CmmStmt]
-unpack_continuation (StackFormat curr_id curr_frame_size curr_offsets)
- = load_live_values where
- -- TODO: only save variables when actually needed
+function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
+function_entry formals (StackFormat _ _ curr_offsets)
+ = load_live_values ++ load_args where
+ -- TODO: only save variables when actually needed (may be handled by latter pass)
load_live_values =
- [CmmAssign
- reg
- (CmmLoad (CmmRegOff spReg (wORD_SIZE*offset)) (cmmRegRep reg))
+ [stack_get 0 reg offset
| (reg, offset) <- curr_offsets]
+ load_args =
+ [stack_get 0 reg offset
+ | ((reg, _), StackParam offset) <- argument_formats] ++
+ [global_get reg global
+ | ((reg, _), RegisterParam global) <- argument_formats]
+
+ argument_formats = assignArguments (cmmRegRep . fst) formals
+
+-----------------------------------------------------------------------------
+-- Section: Stack and argument register puts and gets
+-----------------------------------------------------------------------------
+-- TODO: document
+
+-- |Construct a 'CmmStmt' that will save a value on the stack
+stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
+ -- is relative to (added to offset)
+ -> CmmExpr -- ^ What to store onto the stack
+ -> WordOff -- ^ Where on the stack to store it
+ -- (positive <=> higher addresses)
+ -> CmmStmt
+stack_put spRel expr offset =
+ CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
+
+--------------------------------
+-- |Construct a
+stack_get :: WordOff
+ -> CmmReg
+ -> WordOff
+ -> CmmStmt
+stack_get spRel reg offset =
+ CmmAssign reg (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (cmmRegRep reg))
+global_put :: CmmExpr -> GlobalReg -> CmmStmt
+global_put expr global = CmmAssign (CmmGlobal global) expr
+global_get :: CmmReg -> GlobalReg -> CmmStmt
+global_get reg global = CmmAssign reg (CmmReg (CmmGlobal global))
--- /dev/null
+module CmmCallConv (
+ ParamLocation(..),
+ ArgumentFormat,
+ assignRegs,
+ assignArguments,
+) where
+
+#include "HsVersions.h"
+
+import Cmm
+import MachOp
+import SMRep
+
+import Constants
+import StaticFlags (opt_Unregisterised)
+import Panic
+
+data ParamLocation
+ = RegisterParam GlobalReg
+ | StackParam WordOff
+
+assignRegs :: [LocalReg] -> ArgumentFormat LocalReg
+assignRegs regs = assignRegs' regs 0 availRegs
+ where
+ assignRegs' (r:rs) offset availRegs = (r,assignment):assignRegs' rs new_offset remaining
+ where
+ (assignment, new_offset, remaining) = assign_reg (localRegRep r) offset availRegs
+
+assignArguments :: (a -> MachRep) -> [a] -> ArgumentFormat a
+assignArguments f reps = assignArguments' reps 0 availRegs
+ where
+ assignArguments' [] offset availRegs = []
+ assignArguments' (r:rs) offset availRegs = (r,assignment):assignArguments' rs new_offset remaining
+ where
+ (assignment, new_offset, remaining) = assign_reg (f r) offset availRegs
+
+type ArgumentFormat a = [(a, ParamLocation)]
+
+type AvailRegs = ( [GlobalReg] -- available vanilla regs.
+ , [GlobalReg] -- floats
+ , [GlobalReg] -- doubles
+ , [GlobalReg] -- longs (int64 and word64)
+ )
+
+-- Vanilla registers can contain pointers, Ints, Chars.
+-- Floats and doubles have separate register supplies.
+--
+-- We take these register supplies from the *real* registers, i.e. those
+-- that are guaranteed to map to machine registers.
+
+useVanillaRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Vanilla_REG
+useFloatRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Float_REG
+useDoubleRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Double_REG
+useLongRegs | opt_Unregisterised = 0
+ | otherwise = mAX_Real_Long_REG
+
+availRegs = (regList VanillaReg useVanillaRegs,
+ regList FloatReg useFloatRegs,
+ regList DoubleReg useDoubleRegs,
+ regList LongReg useLongRegs)
+ where
+ regList f max = map f [1 .. max]
+
+slot_size :: LocalReg -> Int
+slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
+
+slot_size' :: MachRep -> Int
+slot_size' reg = ((machRepByteWidth reg - 1) `div` wORD_SIZE) + 1
+
+assign_reg :: MachRep -> WordOff -> AvailRegs -> (ParamLocation, WordOff, AvailRegs)
+assign_reg I8 off (v:vs, fs, ds, ls) = (RegisterParam $ v, off, (vs, fs, ds, ls))
+assign_reg I16 off (v:vs, fs, ds, ls) = (RegisterParam $ v, off, (vs, fs, ds, ls))
+assign_reg I32 off (v:vs, fs, ds, ls) = (RegisterParam $ v, off, (vs, fs, ds, ls))
+assign_reg I64 off (vs, fs, ds, l:ls) = (RegisterParam $ l, off, (vs, fs, ds, ls))
+assign_reg I128 off _ = panic "I128 is not a supported register type"
+assign_reg F32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, (vs, fs, ds, ls))
+assign_reg F64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, (vs, fs, ds, ls))
+assign_reg F80 off _ = panic "F80 is not a supported register type"
+assign_reg reg off _ = (StackParam $ off - size, off - size, ([], [], [], [])) where size = slot_size' reg
projects / ghc-hetmet.git / commitdiff