ghc/compiler/codeGen/CgRetConv.lhs

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