ghc/compiler/codeGen/CgRetConv.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgRetConv.lhs,v 1.28 2000/10/18 09:40:17 simonmar 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           ( catMaybes )
  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       0 -> panic "ctrlRetConvAlg"
  62       size -> -- we're supposed to know...
  63         if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
  64             VectoredReturn size
  65         else
  66             UnvectoredReturn size
  67 \end{code}
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 dataReturnConvPrim :: PrimRep -> MagicId
  77
  78 dataReturnConvPrim IntRep       = VanillaReg IntRep  (_ILIT 1)
  79 dataReturnConvPrim WordRep      = VanillaReg WordRep (_ILIT 1)
  80 dataReturnConvPrim Int64Rep     = LongReg Int64Rep  (_ILIT 1)
  81 dataReturnConvPrim Word64Rep    = LongReg Word64Rep (_ILIT 1)
  82 dataReturnConvPrim AddrRep      = VanillaReg AddrRep (_ILIT 1)
  83 dataReturnConvPrim CharRep      = VanillaReg CharRep (_ILIT 1)
  84 dataReturnConvPrim Int8Rep      = VanillaReg Int8Rep (_ILIT 1)
  85 dataReturnConvPrim FloatRep     = FloatReg  (_ILIT 1)
  86 dataReturnConvPrim DoubleRep    = DoubleReg (_ILIT 1)
  87 dataReturnConvPrim VoidRep      = VoidReg
  88
  89 -- Return a primitive-array pointer in the usual register:
  90 dataReturnConvPrim ArrayRep     = VanillaReg ArrayRep     (_ILIT 1)
  91 dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep (_ILIT 1)
  92 dataReturnConvPrim PrimPtrRep   = VanillaReg PrimPtrRep   (_ILIT 1)
  93 dataReturnConvPrim ThreadIdRep  = VanillaReg ThreadIdRep  (_ILIT 1)
  94
  95 dataReturnConvPrim StablePtrRep  = VanillaReg StablePtrRep  (_ILIT 1)
  96 dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep (_ILIT 1)
  97 dataReturnConvPrim WeakPtrRep    = VanillaReg WeakPtrRep    (_ILIT 1)
  98
  99 #ifdef DEBUG
 100 dataReturnConvPrim rep          = pprPanic "dataReturnConvPrim:" (ppr rep)
 101 #endif
 102 \end{code}
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsubsection[CgRetConv-regs]{Register assignment}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 How to assign registers for
 111
 112         1) Calling a fast entry point.
 113         2) Returning an unboxed tuple.
 114         3) Invoking an out-of-line PrimOp.
 115
 116 Registers are assigned in order.
 117
 118 If we run out, we don't attempt to assign any further registers (even
 119 though we might have run out of only one kind of register); we just
 120 return immediately with the left-overs specified.
 121
 122 The alternative version @assignAllRegs@ uses the complete set of
 123 registers, including those that aren't mapped to real machine
 124 registers.  This is used for calling special RTS functions and PrimOps
 125 which expect their arguments to always be in the same registers.
 126
 127 \begin{code}
 128 assignRegs, assignAllRegs
 129         :: [MagicId]    -- Unavailable registers
 130         -> [PrimRep]    -- Arg or result kinds to assign
 131         -> ([MagicId],  -- Register assignment in same order
 132                                 -- for *initial segment of* input list
 133             [PrimRep])-- leftover kinds
 134
 135 assignRegs regs_in_use kinds
 136  = assign_reg kinds [] (mkRegTbl regs_in_use)
 137
 138 assignAllRegs regs_in_use kinds
 139  = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
 140
 141 assign_reg
 142         :: [PrimRep]              -- arg kinds being scrutinized
 143         -> [MagicId]              -- accum. regs assigned so far (reversed)
 144         -> AvailRegs              -- regs still avail: Vanilla, Float, Double, longs
 145         -> ([MagicId], [PrimRep])
 146
 147 assign_reg (VoidRep:ks) acc supply
 148         = assign_reg ks (VoidReg:acc) supply
 149         -- one VoidReg is enough for everybody!
 150
 151 assign_reg (FloatRep:ks) acc (vanilla_rs, f:float_rs, double_rs, long_rs)
 152         = assign_reg ks (FloatReg (iUnbox f):acc)
 153                         (vanilla_rs, float_rs, double_rs, long_rs)
 154
 155 assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, d:double_rs, long_rs)
 156         = assign_reg ks (DoubleReg (iUnbox d):acc)
 157                         (vanilla_rs, float_rs, double_rs, long_rs)
 158
 159 assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, u:long_rs)
 160         = assign_reg ks (LongReg Word64Rep (iUnbox u):acc)
 161                         (vanilla_rs, float_rs, double_rs, long_rs)
 162
 163 assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, l:long_rs)
 164         = assign_reg ks (LongReg Int64Rep (iUnbox l):acc)
 165                         (vanilla_rs, float_rs, double_rs, long_rs)
 166
 167 assign_reg (k:ks) acc (v:vanilla_rs, float_rs, double_rs, long_rs)
 168         | not (isFloatingRep k || is64BitRep k)
 169         = assign_reg ks (VanillaReg k (iUnbox v):acc)
 170                         (vanilla_rs, float_rs, double_rs, long_rs)
 171
 172 -- The catch-all.  It can happen because either
 173 --      (a) we've assigned all the regs so leftover_ks is []
 174 --  (b) we couldn't find a spare register in the appropriate supply
 175 --  or, I suppose,
 176 --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 177 assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
 178
 179 \end{code}
 180
 181 Register supplies.  Vanilla registers can contain pointers, Ints, Chars.
 182 Floats and doubles have separate register supplies.
 183
 184 We take these register supplies from the *real* registers, i.e. those
 185 that are guaranteed to map to machine registers.
 186
 187 \begin{code}
 188 useVanillaRegs | opt_Unregisterised = 0
 189                | otherwise          = mAX_Real_Vanilla_REG
 190 useFloatRegs   | opt_Unregisterised = 0
 191                | otherwise          = mAX_Real_Float_REG
 192 useDoubleRegs  | opt_Unregisterised = 0
 193                | otherwise          = mAX_Real_Double_REG
 194 useLongRegs    | opt_Unregisterised = 0
 195                | otherwise          = mAX_Real_Long_REG
 196
 197 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 198 vanillaRegNos    = regList useVanillaRegs
 199 floatRegNos      = regList useFloatRegs
 200 doubleRegNos     = regList useDoubleRegs
 201 longRegNos       = regList useLongRegs
 202
 203 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 204 allVanillaRegNos = regList mAX_Vanilla_REG
 205 allFloatRegNos   = regList mAX_Float_REG
 206 allDoubleRegNos  = regList mAX_Double_REG
 207 allLongRegNos    = regList mAX_Long_REG
 208
 209 regList 0 = []
 210 regList n = [1 .. n]
 211
 212 type AvailRegs = ( [Int]   -- available vanilla regs.
 213                  , [Int]   -- floats
 214                  , [Int]   -- doubles
 215                  , [Int]   -- longs (int64 and word64)
 216                  )
 217
 218 mkRegTbl :: [MagicId] -> AvailRegs
 219 mkRegTbl regs_in_use
 220   = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
 221
 222 mkRegTbl_allRegs :: [MagicId] -> AvailRegs
 223 mkRegTbl_allRegs regs_in_use
 224   = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
 225
 226 mkRegTbl' regs_in_use vanillas floats doubles longs
 227   = (ok_vanilla, ok_float, ok_double, ok_long)
 228   where
 229     ok_vanilla = catMaybes (map (select (VanillaReg VoidRep))  vanillas)
 230     ok_float   = catMaybes (map (select FloatReg)              floats)
 231     ok_double  = catMaybes (map (select DoubleReg)             doubles)
 232     ok_long    = catMaybes (map (select (LongReg Int64Rep))    longs)
 233                                     -- rep isn't looked at, hence we can use any old rep.
 234
 235     select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int
 236         -- one we've unboxed the Int, we make a MagicId
 237         -- and see if it is already in use; if not, return its number.
 238
 239     select mk_reg_fun cand
 240       = let
 241             reg = mk_reg_fun (iUnbox cand)
 242         in
 243         if reg `not_elem` regs_in_use
 244         then Just cand
 245         else Nothing
 246       where
 247         not_elem = isn'tIn "mkRegTbl"
 248 \end{code}