Commit 0e504ed5 authored by Michael D. Adams's avatar Michael D. Adams
Browse files

Added early draft of parameter passing to the CPS converter

parent bdfa9495
......@@ -154,10 +154,12 @@ data Continuation =
-- 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)
......@@ -252,22 +254,24 @@ continuationToProc formats (Continuation is_entry info label formals blocks) =
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
......@@ -278,18 +282,24 @@ continuationToProc formats (Continuation is_entry info label formals blocks) =
-- 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
......@@ -300,41 +310,69 @@ enter_function max_frame_size
-- 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))
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
......@@ -129,6 +129,7 @@ cmmBlockUpdate blocks node _ state =
-----------------------------------------------------------------------------
-- Section:
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- CmmBlockLive, cmmStmtListLive and helpers
-----------------------------------------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment