ghc/compiler/codeGen/CgRetConv.lhs

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