ghc/compiler/codeGen/CgRetConv.lhs

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