compiler/cmm/CmmCallConv.hs

   1 module CmmCallConv (
   2   ParamLocation(..),
   3   assignArgumentsPos
   4 ) where
   5
   6 #include "HsVersions.h"
   7
   8 import CmmExpr
   9 import SMRep
  10 import Cmm (Convention(..))
  11 import PprCmm ()
  12
  13 import Constants
  14 import qualified Data.List as L
  15 import StaticFlags (opt_Unregisterised)
  16 import Outputable
  17
  18 -- Calculate the 'GlobalReg' or stack locations for function call
  19 -- parameters as used by the Cmm calling convention.
  20
  21 data ParamLocation
  22   = RegisterParam GlobalReg
  23   | StackParam ByteOff
  24
  25 instance Outputable ParamLocation where
  26   ppr (RegisterParam g) = ppr g
  27   ppr (StackParam p)    = ppr p
  28
  29 -- | JD: For the new stack story, I want arguments passed on the stack to manifest as
  30 -- positive offsets in a CallArea, not negative offsets from the stack pointer.
  31 -- Also, I want byte offsets, not word offsets.
  32 assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] ->
  33                       [(a, ParamLocation)]
  34 -- Given a list of arguments, and a function that tells their types,
  35 -- return a list showing where each argument is passed
  36 assignArgumentsPos conv arg_ty reps = assignments
  37     where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
  38       regs = case (reps, conv) of
  39                (_,   NativeNodeCall)   -> getRegsWithNode
  40                (_,   NativeDirectCall) -> getRegsWithoutNode
  41                ([_], NativeReturn)     -> allRegs
  42                (_,   NativeReturn)     -> getRegsWithNode
  43                -- GC calling convention *must* put values in registers
  44                (_,   GC)               -> allRegs
  45                (_,   PrimOpCall)       -> allRegs
  46                ([_], PrimOpReturn)     -> allRegs
  47                (_,   PrimOpReturn)     -> getRegsWithNode
  48                (_,   Slow)             -> noRegs
  49                _ -> pprPanic "Unknown calling convention" (ppr conv)
  50       -- The calling conventions first assign arguments to registers,
  51       -- then switch to the stack when we first run out of registers
  52       -- (even if there are still available registers for args of a different type).
  53       -- When returning an unboxed tuple, we also separate the stack
  54       -- arguments by pointerhood.
  55       (reg_assts, stk_args) = assign_regs [] reps regs
  56       stk_args' = case conv of NativeReturn -> part
  57                                PrimOpReturn -> part
  58                                GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
  59                                _            -> stk_args
  60                   where part = uncurry (++)
  61                                        (L.partition (not . isGcPtrType . arg_ty) stk_args)
  62       stk_assts = assign_stk 0 [] (reverse stk_args')
  63       assignments = reg_assts ++ stk_assts
  64
  65       assign_regs assts []     _    = (assts, [])
  66       assign_regs assts (r:rs) regs = if isFloatType ty then float else int
  67         where float = case (w, regs) of
  68                         (W32, (vs, f:fs, ds, ls)) -> k (RegisterParam f, (vs, fs, ds, ls))
  69                         (W64, (vs, fs, d:ds, ls)) -> k (RegisterParam d, (vs, fs, ds, ls))
  70                         (W80, _) -> panic "F80 unsupported register type"
  71                         _ -> (assts, (r:rs))
  72               int = case (w, regs) of
  73                       (W128, _) -> panic "W128 unsupported register type"
  74                       (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth
  75                           -> k (RegisterParam (v gcp), (vs, fs, ds, ls))
  76                       (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth
  77                           -> k (RegisterParam l, (vs, fs, ds, ls))
  78                       _   -> (assts, (r:rs))
  79               k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
  80               ty = arg_ty r
  81               w  = typeWidth ty
  82               gcp | isGcPtrType ty = VGcPtr
  83                   | otherwise      = VNonGcPtr
  84
  85       assign_stk _      assts [] = assts
  86       assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
  87         where w    = typeWidth (arg_ty r)
  88               size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE
  89               off' = offset + size
  90
  91 -----------------------------------------------------------------------------
  92 -- Local information about the registers available
  93
  94 type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
  95                  , [GlobalReg]   -- floats
  96                  , [GlobalReg]   -- doubles
  97                  , [GlobalReg]   -- longs (int64 and word64)
  98                  )
  99
 100 -- Vanilla registers can contain pointers, Ints, Chars.
 101 -- Floats and doubles have separate register supplies.
 102 --
 103 -- We take these register supplies from the *real* registers, i.e. those
 104 -- that are guaranteed to map to machine registers.
 105
 106 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 107 vanillaRegNos | opt_Unregisterised = []
 108               | otherwise          = regList mAX_Real_Vanilla_REG
 109 floatRegNos       | opt_Unregisterised = []
 110               | otherwise          = regList mAX_Real_Float_REG
 111 doubleRegNos  | opt_Unregisterised = []
 112               | otherwise          = regList mAX_Real_Double_REG
 113 longRegNos        | opt_Unregisterised = []
 114               | otherwise          = regList mAX_Real_Long_REG
 115
 116 --
 117 getRegsWithoutNode, getRegsWithNode :: AvailRegs
 118 getRegsWithoutNode =
 119   (filter (\r -> r VGcPtr /= node) intRegs,
 120    map FloatReg  floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
 121     where intRegs = map VanillaReg vanillaRegNos
 122 getRegsWithNode =
 123   (intRegs, map FloatReg  floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos)
 124     where intRegs = map VanillaReg vanillaRegNos
 125
 126 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 127 allVanillaRegNos = regList mAX_Vanilla_REG
 128 allFloatRegNos   = regList mAX_Float_REG
 129 allDoubleRegNos  = regList mAX_Double_REG
 130 allLongRegNos      = regList mAX_Long_REG
 131
 132 regList :: Int -> [Int]
 133 regList n = [1 .. n]
 134
 135 allRegs :: AvailRegs
 136 allRegs = (map VanillaReg allVanillaRegNos, map FloatReg allFloatRegNos,
 137            map DoubleReg  allDoubleRegNos,  map LongReg  allLongRegNos)
 138
 139 noRegs :: AvailRegs
 140 noRegs    = ([], [], [], [])