CmmCallConv.hs 6.34 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1
2
3
4
5
6
7
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

8
9
module CmmCallConv (
  ParamLocation(..),
10
11
  assignArgumentsPos,
  globalArgRegs
12
13
14
15
) where

#include "HsVersions.h"

16
import CmmExpr
17
import SMRep
18
19
import Cmm (Convention(..))
import PprCmm ()
20
21

import Constants
22
import qualified Data.List as L
23
import DynFlags
24
import Outputable
25

26
27
28
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.

29
data ParamLocation
30
  = RegisterParam GlobalReg
31
  | StackParam ByteOff
32

33
instance Outputable ParamLocation where
34
35
36
  ppr (RegisterParam g) = ppr g
  ppr (StackParam p)    = ppr p

37
38
39
-- | 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.
40
assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
41
                      [(a, ParamLocation)]
42
43
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
44
assignArgumentsPos dflags conv arg_ty reps = assignments
45
    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
46
      regs = case (reps, conv) of
47
48
               (_,   NativeNodeCall)   -> getRegsWithNode dflags
               (_,   NativeDirectCall) -> getRegsWithoutNode dflags
49
               ([_], NativeReturn)     -> allRegs
50
               (_,   NativeReturn)     -> getRegsWithNode dflags
51
52
               -- GC calling convention *must* put values in registers
               (_,   GC)               -> allRegs
53
54
               (_,   PrimOpCall)       -> allRegs
               ([_], PrimOpReturn)     -> allRegs
55
               (_,   PrimOpReturn)     -> getRegsWithNode dflags
56
               (_,   Slow)             -> noRegs
57
58
      -- The calling conventions first assign arguments to registers,
      -- then switch to the stack when we first run out of registers
dias@cs.tufts.edu's avatar
dias@cs.tufts.edu committed
59
      -- (even if there are still available registers for args of a different type).
60
61
62
63
64
      -- When returning an unboxed tuple, we also separate the stack
      -- arguments by pointerhood.
      (reg_assts, stk_args) = assign_regs [] reps regs
      stk_args' = case conv of NativeReturn -> part
                               PrimOpReturn -> part
65
                               GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
                               _            -> stk_args
                  where part = uncurry (++)
                                       (L.partition (not . isGcPtrType . arg_ty) stk_args)
      stk_assts = assign_stk 0 [] (reverse stk_args')
      assignments = reg_assts ++ stk_assts

      assign_regs assts []     _    = (assts, [])
      assign_regs assts (r:rs) regs = if isFloatType ty then float else int
        where float = case (w, regs) of
                        (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
                        (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
                        (W80, _) -> panic "F80 unsupported register type"
                        _ -> (assts, (r:rs))
              int = case (w, regs) of
                      (W128, _) -> panic "W128 unsupported register type"
                      (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls))
                      (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
                          -> k (RegisterParam l, (vs, fs, ds, ls))
                      _   -> (assts, (r:rs))
              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
              ty = arg_ty r
              w  = typeWidth ty
              gcp | isGcPtrType ty = VGcPtr
                  | otherwise  	   = VNonGcPtr

dias@cs.tufts.edu's avatar
dias@cs.tufts.edu committed
92
      assign_stk _      assts [] = assts
93
94
95
96
      assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
        where w    = typeWidth (arg_ty r)
              size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE
              off' = offset + size
97
98
99

-----------------------------------------------------------------------------
-- Local information about the registers available
100

101
type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
dias@cs.tufts.edu's avatar
dias@cs.tufts.edu committed
102
103
104
105
                 , [GlobalReg]   -- floats
                 , [GlobalReg]   -- doubles
                 , [GlobalReg]   -- longs (int64 and word64)
                 )
106
107
108
109
110
111
112

-- 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.

113
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
114
115
116
117
118
119
120
121
122
123
124
125
getRegsWithoutNode _dflags =
  ( filter (\r -> r VGcPtr /= node) realVanillaRegs
  , realFloatRegs
  , realDoubleRegs
  , realLongRegs )

-- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode _dflags =
  ( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs
  , realFloatRegs
  , realDoubleRegs
  , realLongRegs )
126

127
128
129
130
131
132
133
allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
allVanillaRegs :: [VGcPtr -> GlobalReg]

allVanillaRegs = map VanillaReg $ regList mAX_Vanilla_REG
allFloatRegs   = map FloatReg   $ regList mAX_Float_REG
allDoubleRegs  = map DoubleReg  $ regList mAX_Double_REG
allLongRegs    = map LongReg    $ regList mAX_Long_REG
134

135
136
137
138
139
140
141
142
realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg]
realVanillaRegs :: [VGcPtr -> GlobalReg]

realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG
realFloatRegs   = map FloatReg   $ regList mAX_Real_Float_REG
realDoubleRegs  = map DoubleReg  $ regList mAX_Real_Double_REG
realLongRegs    = map LongReg    $ regList mAX_Real_Long_REG

143
144
145
146
regList :: Int -> [Int]
regList n = [1 .. n]

allRegs :: AvailRegs
147
allRegs  = (allVanillaRegs, allFloatRegs, allDoubleRegs, allLongRegs)
Ian Lynagh's avatar
Ian Lynagh committed
148
149

noRegs :: AvailRegs
150
151
152
153
154
155
156
noRegs  = ([], [], [], [])

globalArgRegs :: [GlobalReg]
globalArgRegs = map ($VGcPtr) allVanillaRegs ++
                allFloatRegs ++
                allDoubleRegs ++
                allLongRegs