CmmCallConv.hs 6.81 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 qualified Data.List as L
22
import DynFlags
23
import Outputable
24

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

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

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

36 37 38
-- | 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.
39
assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
40
                      [(a, ParamLocation)]
41 42
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
43
assignArgumentsPos dflags conv arg_ty reps = assignments
44
    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
45
      regs = case (reps, conv) of
46 47
               (_,   NativeNodeCall)   -> getRegsWithNode dflags
               (_,   NativeDirectCall) -> getRegsWithoutNode dflags
48
               ([_], NativeReturn)     -> allRegs dflags
49
               (_,   NativeReturn)     -> getRegsWithNode dflags
50
               -- GC calling convention *must* put values in registers
51 52 53
               (_,   GC)               -> allRegs dflags
               (_,   PrimOpCall)       -> allRegs dflags
               ([_], PrimOpReturn)     -> allRegs dflags
54
               (_,   PrimOpReturn)     -> getRegsWithNode dflags
55
               (_,   Slow)             -> noRegs
56 57
      -- 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
58
      -- (even if there are still available registers for args of a different type).
59 60 61 62 63
      -- 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
64
                               GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
                               _            -> 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"
80
                      (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags)
81
                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls))
82
                      (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags)
83 84 85 86 87 88 89 90
                          -> 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
91
      assign_stk _      assts [] = assts
92 93
      assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
        where w    = typeWidth (arg_ty r)
94
              size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags
95
              off' = offset + size
96 97 98

-----------------------------------------------------------------------------
-- Local information about the registers available
99

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

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

112
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
113 114 115 116 117
getRegsWithoutNode dflags =
  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
  , realFloatRegs dflags
  , realDoubleRegs dflags
  , realLongRegs dflags)
118 119

-- getRegsWithNode uses R1/node even if it isn't a register
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
getRegsWithNode dflags =
  ( if null (realVanillaRegs dflags)
    then [VanillaReg 1]
    else realVanillaRegs dflags
  , realFloatRegs dflags
  , realDoubleRegs dflags
  , realLongRegs dflags)

allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]

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

realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]

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

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

147 148 149 150 151
allRegs :: DynFlags -> AvailRegs
allRegs dflags = (allVanillaRegs dflags,
                  allFloatRegs dflags,
                  allDoubleRegs dflags,
                  allLongRegs dflags)
Ian Lynagh's avatar
Ian Lynagh committed
152 153

noRegs :: AvailRegs
154 155
noRegs  = ([], [], [], [])

156 157 158 159 160
globalArgRegs :: DynFlags -> [GlobalReg]
globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
                       allFloatRegs dflags ++
                       allDoubleRegs dflags ++
                       allLongRegs dflags