CmmCallConv.hs 6.25 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
  assignArgumentsPos
11 12 13 14
) where

#include "HsVersions.h"

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

import Constants
21
import qualified Data.List as L
22
import StaticFlags (opt_Unregisterised)
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 40
assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] ->
                      [(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
dias@cs.tufts.edu's avatar
dias@cs.tufts.edu committed
43
assignArgumentsPos conv arg_ty reps = assignments
44
    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
45 46 47 48 49
      regs = case (reps, conv) of
               (_,   NativeNodeCall)   -> getRegsWithNode
               (_,   NativeDirectCall) -> getRegsWithoutNode
               ([_], NativeReturn)     -> allRegs
               (_,   NativeReturn)     -> getRegsWithNode
50 51
               -- GC calling convention *must* put values in registers
               (_,   GC)               -> allRegs
52 53 54 55
               (_,   PrimOpCall)       -> allRegs
               ([_], PrimOpReturn)     -> allRegs
               (_,   PrimOpReturn)     -> getRegsWithNode
               (_,   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 80 81 82 83 84 85 86 87 88 89 90
                               _            -> 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
91
      assign_stk _      assts [] = assts
92 93 94 95
      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
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 113 114 115 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
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
144 145

noRegs :: AvailRegs
146
noRegs    = ([], [], [], [])