ghc/compiler/codeGen/CgRetConv.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $
   5 %
   6 \section[CgRetConv]{Return conventions for the code generator}
   7
   8 The datatypes and functions here encapsulate what there is to know
   9 about return conventions.
  10
  11 \begin{code}
  12 module CgRetConv (
  13         CtrlReturnConvention(..),
  14         ctrlReturnConvAlg,
  15         dataReturnConvPrim,
  16         assignRegs, assignAllRegs
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import AbsCSyn          -- quite a few things
  22 import Constants        ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
  23                           mAX_Vanilla_REG, mAX_Float_REG,
  24                           mAX_Double_REG, mAX_Long_REG,
  25                           mAX_Real_Vanilla_REG, mAX_Real_Float_REG,
  26                           mAX_Real_Double_REG, mAX_Real_Long_REG
  27                         )
  28 import CmdLineOpts      ( opt_Unregisterised )
  29 import Maybes           ( mapCatMaybes )
  30 import PrimRep          ( isFloatingRep, PrimRep(..), is64BitRep )
  31 import TyCon            ( TyCon, tyConFamilySize )
  32 import Util             ( isn'tIn )
  33 import FastTypes
  34 import Outputable
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 A @CtrlReturnConvention@ says how {\em control} is returned.
  44 \begin{code}
  45 data CtrlReturnConvention
  46   = VectoredReturn      Int     -- size of the vector table (family size)
  47   | UnvectoredReturn    Int     -- family size
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 \begin{code}
  57 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
  58
  59 ctrlReturnConvAlg tycon
  60   = case (tyConFamilySize tycon) of
  61       size -> -- we're supposed to know...
  62         if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
  63             VectoredReturn size
  64         else
  65             UnvectoredReturn size
  66   -- NB: unvectored returns Include size 0 (no constructors), so that
  67   --     the following perverse code compiles (it crashed GHC in 5.02)
  68   --        data T1
  69   --        data T2 = T2 !T1 Int
  70   --     The only value of type T1 is bottom, which never returns anyway.
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 dataReturnConvPrim :: PrimRep -> MagicId
  81
  82 dataReturnConvPrim PtrRep       = VanillaReg PtrRep  (_ILIT 1)
  83 dataReturnConvPrim IntRep       = VanillaReg IntRep  (_ILIT 1)
  84 dataReturnConvPrim WordRep      = VanillaReg WordRep (_ILIT 1)
  85 dataReturnConvPrim Int32Rep     = VanillaReg Int32Rep (_ILIT 1)
  86 dataReturnConvPrim Word32Rep    = VanillaReg Word32Rep (_ILIT 1)
  87 dataReturnConvPrim Int64Rep     = LongReg Int64Rep  (_ILIT 1)
  88 dataReturnConvPrim Word64Rep    = LongReg Word64Rep (_ILIT 1)
  89 dataReturnConvPrim AddrRep      = VanillaReg AddrRep (_ILIT 1)
  90 dataReturnConvPrim CharRep      = VanillaReg CharRep (_ILIT 1)
  91 dataReturnConvPrim Int8Rep      = VanillaReg Int8Rep (_ILIT 1)
  92 dataReturnConvPrim FloatRep     = FloatReg  (_ILIT 1)
  93 dataReturnConvPrim DoubleRep    = DoubleReg (_ILIT 1)
  94 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep  (_ILIT 1)
  95 dataReturnConvPrim VoidRep      = VoidReg
  96
  97 #ifdef DEBUG
  98 dataReturnConvPrim rep          = pprPanic "dataReturnConvPrim:" (ppr rep)
  99 #endif
 100 \end{code}
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsubsection[CgRetConv-regs]{Register assignment}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 How to assign registers for
 109
 110         1) Calling a fast entry point.
 111         2) Returning an unboxed tuple.
 112         3) Invoking an out-of-line PrimOp.
 113
 114 Registers are assigned in order.
 115
 116 If we run out, we don't attempt to assign any further registers (even
 117 though we might have run out of only one kind of register); we just
 118 return immediately with the left-overs specified.
 119
 120 The alternative version @assignAllRegs@ uses the complete set of
 121 registers, including those that aren't mapped to real machine
 122 registers.  This is used for calling special RTS functions and PrimOps
 123 which expect their arguments to always be in the same registers.
 124
 125 \begin{code}
 126 assignRegs, assignAllRegs
 127         :: [MagicId]    -- Unavailable registers
 128         -> [PrimRep]    -- Arg or result kinds to assign
 129         -> ([MagicId],  -- Register assignment in same order
 130                                 -- for *initial segment of* input list
 131             [PrimRep])-- leftover kinds
 132
 133 assignRegs regs_in_use kinds
 134  = assign_reg kinds [] (mkRegTbl regs_in_use)
 135
 136 assignAllRegs regs_in_use kinds
 137  = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
 138
 139 assign_reg
 140         :: [PrimRep]              -- arg kinds being scrutinized
 141         -> [MagicId]              -- accum. regs assigned so far (reversed)
 142         -> AvailRegs              -- regs still avail: Vanilla, Float, Double, longs
 143         -> ([MagicId], [PrimRep])
 144
 145 assign_reg (VoidRep:ks) acc supply
 146         = assign_reg ks (VoidReg:acc) supply
 147         -- one VoidReg is enough for everybody!
 148
 149 assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs)
 150         = assign_reg ks (FloatReg (iUnbox f):acc)
 151                         (vanilla_rs, float_rs, double_rs, long_rs)
 152
 153 assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs)
 154         = assign_reg ks (DoubleReg (iUnbox d):acc)
 155                         (vanilla_rs, float_rs, double_rs, long_rs)
 156
 157 assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs)
 158         = assign_reg ks (LongReg Word64Rep (iUnbox u):acc)
 159                         (vanilla_rs, float_rs, double_rs, long_rs)
 160
 161 assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs)
 162         = assign_reg ks (LongReg Int64Rep (iUnbox l):acc)
 163                         (vanilla_rs, float_rs, double_rs, long_rs)
 164
 165 assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs)
 166         | not (isFloatingRep k || is64BitRep k)
 167         = assign_reg ks (VanillaReg k (iUnbox v):acc)
 168                         (vanilla_rs, float_rs, double_rs, long_rs)
 169
 170 -- The catch-all.  It can happen because either
 171 --      (a) we've assigned all the regs so leftover_ks is []
 172 --  (b) we couldn't find a spare register in the appropriate supply
 173 --  or, I suppose,
 174 --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 175 assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
 176
 177 \end{code}
 178
 179 Register supplies.  Vanilla registers can contain pointers, Ints, Chars.
 180 Floats and doubles have separate register supplies.
 181
 182 We take these register supplies from the *real* registers, i.e. those
 183 that are guaranteed to map to machine registers.
 184
 185 \begin{code}
 186 useVanillaRegs | opt_Unregisterised = 0
 187                | otherwise          = mAX_Real_Vanilla_REG
 188 useFloatRegs   | opt_Unregisterised = 0
 189                | otherwise          = mAX_Real_Float_REG
 190 useDoubleRegs  | opt_Unregisterised = 0
 191                | otherwise          = mAX_Real_Double_REG
 192 useLongRegs    | opt_Unregisterised = 0
 193                | otherwise          = mAX_Real_Long_REG
 194
 195 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 196 vanillaRegNos    = regList useVanillaRegs
 197 floatRegNos      = regList useFloatRegs
 198 doubleRegNos     = regList useDoubleRegs
 199 longRegNos       = regList useLongRegs
 200
 201 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 202 allVanillaRegNos = regList mAX_Vanilla_REG
 203 allFloatRegNos   = regList mAX_Float_REG
 204 allDoubleRegNos  = regList mAX_Double_REG
 205 allLongRegNos    = regList mAX_Long_REG
 206
 207 regList 0 = []
 208 regList n = [1 .. n]
 209
 210 type AvailRegs = ( [Int]   -- available vanilla regs.
 211                  , [Int]   -- floats
 212                  , [Int]   -- doubles
 213                  , [Int]   -- longs (int64 and word64)
 214                  )
 215
 216 mkRegTbl :: [MagicId] -> AvailRegs
 217 mkRegTbl regs_in_use
 218   = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
 219
 220 mkRegTbl_allRegs :: [MagicId] -> AvailRegs
 221 mkRegTbl_allRegs regs_in_use
 222   = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
 223
 224 mkRegTbl' regs_in_use vanillas floats doubles longs
 225   = (ok_vanilla, ok_float, ok_double, ok_long)
 226   where
 227     ok_vanilla = mapCatMaybes (select (VanillaReg VoidRep)) vanillas
 228     ok_float   = mapCatMaybes (select FloatReg)             floats
 229     ok_double  = mapCatMaybes (select DoubleReg)            doubles
 230     ok_long    = mapCatMaybes (select (LongReg Int64Rep))   longs
 231                                     -- rep isn't looked at, hence we can use any old rep.
 232
 233     select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int
 234         -- one we've unboxed the Int, we make a MagicId
 235         -- and see if it is already in use; if not, return its number.
 236
 237     select mk_reg_fun cand
 238       = let
 239             reg = mk_reg_fun (iUnbox cand)
 240         in
 241         if reg `not_elem` regs_in_use
 242         then Just cand
 243         else Nothing
 244       where
 245         not_elem = isn'tIn "mkRegTbl"
 246 \end{code}