CmmCallConv.hs 7.22 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

-- | 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.
49
assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] ->
50
                      ArgumentFormat a ByteOff
51
assignArgumentsPos conv arg_ty reps = map cvt assignments
52
    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
53
54
55
56
57
58
59
60
61
62
63
      regs = case (reps, conv) of
               (_,   NativeNodeCall)   -> getRegsWithNode
               (_,   NativeDirectCall) -> getRegsWithoutNode
               ([_], NativeReturn)     -> allRegs
               (_,   NativeReturn)     -> getRegsWithNode
               (_,   GC)               -> getRegsWithNode
               (_,   PrimOpCall)       -> allRegs
               ([_], PrimOpReturn)     -> allRegs
               (_,   PrimOpReturn)     -> getRegsWithNode
               (_,   Slow)             -> noRegs
               _ -> pprPanic "Unknown calling convention" (ppr conv)
64
      (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
65
66
      assignArguments' [] _ _ = []
      assignArguments' (r:rs) offset avails =
67
          (size, (r,assignment)):assignArguments' rs new_offset remaining
68
69
          where 
            (assignment, new_offset, size, remaining) =
70
                assign_reg assign_slot_pos (arg_ty r) offset avails
71
72
      cvt (l, RegisterParam r) = (l, RegisterParam r)
      cvt (l, StackParam off)  = (l, StackParam $ off * wORD_SIZE)
73

74
argumentsSize :: (a -> CmmType) -> [a] -> WordOff
75
76
77
argumentsSize f reps = maximum (0 : map arg_top args)
    where
      args = assignArguments f reps
Ian Lynagh's avatar
Ian Lynagh committed
78
      arg_top (_, StackParam offset) = -offset
79
80
81
82
      arg_top (_, RegisterParam _) = 0

-----------------------------------------------------------------------------
-- Local information about the registers available
83

84
type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
85
86
87
88
89
90
91
92
93
94
95
		 , [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.

96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
128
129

noRegs :: AvailRegs
130
noRegs    = ([], [], [], [])
131

132
-- Round the size of a local register up to the nearest word.
Ian Lynagh's avatar
Ian Lynagh committed
133
134
135
{-
UNUSED 2008-12-29

136
slot_size :: LocalReg -> Int
137
slot_size reg = slot_size' (typeWidth (localRegType reg))
Ian Lynagh's avatar
Ian Lynagh committed
138
-}
139
140
141
142
143
144
145

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

146
147
148
149
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
150
151
152
153
154
  where
    width = typeWidth ty
    gcp | isGcPtrType ty = VGcPtr
	| otherwise  	 = VNonGcPtr

155
-- Assigning a slot using negative offsets from the stack pointer.
156
157
-- JD: I don't know why this convention stops using all the registers
--     after running out of one class of registers.
158
assign_slot_neg :: SlotAssigner
Ian Lynagh's avatar
Ian Lynagh committed
159
assign_slot_neg width off _regs =
160
161
  (StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width

162
163
-- Assigning a slot using positive offsets into a CallArea.
assign_slot_pos :: SlotAssigner
Ian Lynagh's avatar
Ian Lynagh committed
164
assign_slot_pos width off _regs =
165
  (StackParam $ off, off - size, size, ([], [], [], []))
166
167
  where size = slot_size' width

168
169
-- 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.
170
assign_bits_reg :: SlotAssigner -> Width -> WordOff -> VGcPtr -> AvailRegs -> Assignment
171
assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type"
172
173
assign_bits_reg _ w off gcp (v:vs, fs, ds, ls)
  | widthInBits w <= widthInBits wordWidth =
174
        (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls))
175
176
assign_bits_reg _ w off _ (vs, fs, ds, l:ls)
  | widthInBits w > widthInBits wordWidth =
177
        (RegisterParam l, off, 0, (vs, fs, ds, ls))
dias@eecs.tufts.edu's avatar
dias@eecs.tufts.edu committed
178
assign_bits_reg assign_slot w off _ regs@(_, _, _, _) = assign_slot w off regs
179

Ian Lynagh's avatar
Ian Lynagh committed
180
assign_float_reg :: SlotAssigner -> Width -> WordOff -> AvailRegs -> Assignment
181
182
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
183
assign_float_reg _ W80 _   _                  = panic "F80 is not a supported register type"
184
assign_float_reg assign_slot width off r = assign_slot width off r