From 0e504ed52a791feb3fd265e5dfd141b5f4a8b1b6 Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Tue, 29 May 2007 15:06:16 +0000 Subject: [PATCH] Added early draft of parameter passing to the CPS converter --- compiler/cmm/CmmCPS.hs | 124 ++++++++++++++++++++++++++++--------------- compiler/cmm/CmmCallConv.hs | 82 ++++++++++++++++++++++++++++ compiler/cmm/CmmLive.hs | 1 + 3 files changed, 164 insertions(+), 43 deletions(-) create mode 100644 compiler/cmm/CmmCallConv.hs diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 2726ef8..4d90a4d 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -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)) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs new file mode 100644 index 0000000..ee16fe9 --- /dev/null +++ b/compiler/cmm/CmmCallConv.hs @@ -0,0 +1,82 @@ +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 diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index 4fb4a29..b379f2d 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -129,6 +129,7 @@ cmmBlockUpdate blocks node _ state = ----------------------------------------------------------------------------- -- Section: ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- -- CmmBlockLive, cmmStmtListLive and helpers ----------------------------------------------------------------------------- -- 1.7.10.4