CmmCallConv.hs 8.47 KB
Newer Older
1 2 3 4
module CmmCallConv (
  ParamLocation(..),
  ArgumentFormat,
  assignArguments,
5
  assignArgumentsPos,
6
  argumentsSize,
7 8 9 10 11 12
) where

#include "HsVersions.h"

import Cmm
import SMRep
13
import ZipCfgCmmRep (Convention(..))
14 15 16

import Constants
import StaticFlags (opt_Unregisterised)
17
import Outputable
18 19
import Panic

20 21 22
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.

23
data ParamLocation a
24
  = RegisterParam GlobalReg
25
  | StackParam a
26

27 28 29 30
instance (Outputable a) => Outputable (ParamLocation a) where
  ppr (RegisterParam g) = ppr g
  ppr (StackParam p)    = ppr p

31
type ArgumentFormat a b = [(a, ParamLocation b)]
32

33 34
-- Stack parameters are returned as word offsets.
assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
35
assignArguments f reps = assignments
36
    where
37
      availRegs = getRegsWithNode
38
      (sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs
Ian Lynagh's avatar
Ian Lynagh committed
39
      assignArguments' [] _ _ = []
40
      assignArguments' (r:rs) offset availRegs =
41
          (size,(r,assignment)):assignArguments' rs new_offset remaining
42
          where 
43
            (assignment, new_offset, size, remaining) =
44
                assign_reg assign_slot_neg (f r) offset availRegs
45 46 47 48 49

-- | 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.
-- The first argument tells us whether we are assigning positions for call arguments
50 51 52 53 54 55
-- or return results. The distinction matters because some conventions use different
-- global registers in each case. In particular, the native calling convention
-- uses the `node' register to pass the closure environment.
assignArgumentsPos :: (Outputable a) => Convention -> Bool -> (a -> CmmType) -> [a] ->
                      ArgumentFormat a ByteOff
assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
56 57 58
    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
      regs = if isCall then
               case (reps, conv) of
59 60
                 (_, NativeNodeCall)   -> getRegsWithNode
                 (_, NativeDirectCall) -> getRegsWithoutNode
61
                 (_, GC    ) -> getRegsWithNode
62
                 (_, PrimOpCall) -> allRegs
63
                 (_, Slow  ) -> noRegs
64
                 _ -> pprPanic "Unknown calling convention" (ppr conv)
65 66 67
             else
               case (reps, conv) of
                 ([_], _)    -> allRegs
68 69
                 (_, NativeNodeCall)   -> getRegsWithNode
                 (_, NativeDirectCall) -> getRegsWithoutNode
70
                 (_, NativeReturn) -> getRegsWithNode
71
                 (_, GC    ) -> getRegsWithNode
72
                 (_, PrimOpReturn) -> getRegsWithNode
73
                 (_, Slow  ) -> noRegs
74
                 _ -> pprPanic "Unknown calling convention" (ppr conv)
75 76 77 78 79 80 81 82 83
           --       (_, NativeCall) -> getRegsWithoutNode
           --       (_, GC    ) -> getRegsWithNode
           --       (_, PrimOpCall) -> allRegs
           --       (_, Slow  ) -> noRegs
           --       _ -> panic "Unknown calling convention"
           --   else
           --     case (reps, conv) of
           --       ([_], _)    -> allRegs
           --       (_, NativeCall)   -> getRegsWithNode
84
      (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
85 86
      assignArguments' [] _ _ = []
      assignArguments' (r:rs) offset avails =
87
          (size, (r,assignment)):assignArguments' rs new_offset remaining
88 89
          where 
            (assignment, new_offset, size, remaining) =
90
                assign_reg assign_slot_pos (arg_ty r) offset avails
91 92
      cvt (l, RegisterParam r) = (l, RegisterParam r)
      cvt (l, StackParam off)  = (l, StackParam $ off * wORD_SIZE)
93

94
argumentsSize :: (a -> CmmType) -> [a] -> WordOff
95 96 97
argumentsSize f reps = maximum (0 : map arg_top args)
    where
      args = assignArguments f reps
Ian Lynagh's avatar
Ian Lynagh committed
98
      arg_top (_, StackParam offset) = -offset
99 100 101 102
      arg_top (_, RegisterParam _) = 0

-----------------------------------------------------------------------------
-- Local information about the registers available
103

104
type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
105 106 107 108 109 110 111 112 113 114 115
		 , [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.

116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
vanillaRegNos | opt_Unregisterised = []
              | otherwise          = regList mAX_Real_Vanilla_REG
floatRegNos	  | opt_Unregisterised = []
              | otherwise          = regList mAX_Real_Float_REG
doubleRegNos  | opt_Unregisterised = []
              | otherwise          = regList mAX_Real_Double_REG
longRegNos	  | opt_Unregisterised = []
              | otherwise          = regList mAX_Real_Long_REG

-- 
getRegsWithoutNode, getRegsWithNode :: AvailRegs
getRegsWithoutNode =
  (filter (\r -> r VGcPtr /= node) intRegs,
   map FloatReg  floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
    where intRegs = map VanillaReg vanillaRegNos
getRegsWithNode =
  (intRegs, map FloatReg  floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
    where intRegs = map VanillaReg vanillaRegNos

allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
allVanillaRegNos = regList mAX_Vanilla_REG
allFloatRegNos	 = regList mAX_Float_REG
allDoubleRegNos	 = regList mAX_Double_REG
allLongRegNos	   = regList mAX_Long_REG

regList :: Int -> [Int]
regList n = [1 .. n]

allRegs :: AvailRegs
allRegs = (map VanillaReg allVanillaRegNos, map FloatReg allFloatRegNos,
           map DoubleReg  allDoubleRegNos,  map LongReg  allLongRegNos)
Ian Lynagh's avatar
Ian Lynagh committed
148 149

noRegs :: AvailRegs
150
noRegs    = ([], [], [], [])
151

152
-- Round the size of a local register up to the nearest word.
Ian Lynagh's avatar
Ian Lynagh committed
153 154 155
{-
UNUSED 2008-12-29

156
slot_size :: LocalReg -> Int
157
slot_size reg = slot_size' (typeWidth (localRegType reg))
Ian Lynagh's avatar
Ian Lynagh committed
158
-}
159 160 161 162 163 164 165

slot_size' :: Width -> Int
slot_size' reg = ((widthInBytes reg - 1) `div` wORD_SIZE) + 1

type Assignment = (ParamLocation WordOff, WordOff, WordOff, AvailRegs)
type SlotAssigner = Width -> Int -> AvailRegs -> Assignment

166 167 168 169
assign_reg :: SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment
assign_reg slot ty off avails
  | isFloatType ty = assign_float_reg slot width off avails
  | otherwise      = assign_bits_reg  slot width off gcp avails
170 171 172 173 174
  where
    width = typeWidth ty
    gcp | isGcPtrType ty = VGcPtr
	| otherwise  	 = VNonGcPtr

175
-- Assigning a slot using negative offsets from the stack pointer.
176 177
-- JD: I don't know why this convention stops using all the registers
--     after running out of one class of registers.
178
assign_slot_neg :: SlotAssigner
Ian Lynagh's avatar
Ian Lynagh committed
179
assign_slot_neg width off _regs =
180 181
  (StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width

182 183
-- Assigning a slot using positive offsets into a CallArea.
assign_slot_pos :: SlotAssigner
Ian Lynagh's avatar
Ian Lynagh committed
184
assign_slot_pos width off _regs =
185
  (StackParam $ off, off - size, size, ([], [], [], []))
186 187
  where size = slot_size' width

188 189
-- On calls in the native convention, `node` is used to hold the environment
-- for the closure, so we can't pass arguments in that register.
190
assign_bits_reg :: SlotAssigner -> Width -> WordOff -> VGcPtr -> AvailRegs -> Assignment
191
assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type"
192 193 194 195 196 197 198 199
assign_bits_reg _ w off gcp (v:vs, fs, ds, ls)
  | widthInBits w <= widthInBits wordWidth =
        pprTrace "long regs" (ppr ls <+> ppr wordWidth <+> ppr mAX_Real_Long_REG) $ (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls))
assign_bits_reg _ w off _ (vs, fs, ds, l:ls)
  | widthInBits w > widthInBits wordWidth =
        pprTrace "long regs" (ppr ls <+> ppr wordWidth <+> ppr mAX_Real_Long_REG) $ (RegisterParam l, off, 0, (vs, fs, ds, ls))
assign_bits_reg assign_slot w off _ regs@(_, _, _, ls) =
  pprTrace "long regs" (ppr w <+> ppr ls <+> ppr wordWidth <+> ppr mAX_Real_Long_REG <+> ppr mAX_Long_REG) $ assign_slot w off regs
200

Ian Lynagh's avatar
Ian Lynagh committed
201
assign_float_reg :: SlotAssigner -> Width -> WordOff -> AvailRegs -> Assignment
202 203
assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls))
assign_float_reg _ W64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, 0, (vs, fs, ds, ls))
Ian Lynagh's avatar
Ian Lynagh committed
204
assign_float_reg _ W80 _   _                  = panic "F80 is not a supported register type"
205
assign_float_reg assign_slot width off r = assign_slot width off r