ghc/compiler/codeGen/CgRetConv.lhs

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