ghc/compiler/codeGen/CgRetConv.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1995
   3 %
   4 \section[CgRetConv]{Return conventions for the code generator}
   5
   6 The datatypes and functions here encapsulate what there is to know
   7 about return conventions.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module CgRetConv (
  13         CtrlReturnConvention(..), DataReturnConvention(..),
  14
  15         ctrlReturnConvAlg,
  16         dataReturnConvAlg,
  17
  18         dataReturnConvPrim,
  19
  20         assignPrimOpResultRegs,
  21         makePrimOpArgsRobust,
  22         assignRegs
  23
  24         -- and to make the interface self-sufficient...
  25     ) where
  26
  27 import Ubiq{-uitous-}
  28 import AbsCLoop         -- paranoia checking
  29
  30 import AbsCSyn          -- quite a few things
  31 import AbsCUtils        ( mkAbstractCs, getAmodeRep,
  32                           amodeCanSurviveGC
  33                         )
  34 import CgCompInfo       ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
  35                           mAX_Vanilla_REG, mAX_Float_REG,
  36                           mAX_Double_REG
  37                         )
  38 import CmdLineOpts      ( opt_ReturnInRegsThreshold )
  39 import Id               ( isDataCon, dataConSig,
  40                           DataCon(..), GenId{-instance Eq-}
  41                         )
  42 import Maybes           ( catMaybes )
  43 import PprStyle         ( PprStyle(..) )
  44 import PprType          ( TyCon{-instance Outputable-} )
  45 import PrimOp           ( primOpCanTriggerGC,
  46                           getPrimOpResultInfo, PrimOpResultInfo(..),
  47                           PrimOp{-instance Outputable-}
  48                         )
  49 import PrimRep          ( isFloatingRep, PrimRep(..) )
  50 import TyCon            ( tyConDataCons, tyConFamilySize )
  51 import Type             ( typePrimRep )
  52 import Util             ( zipWithEqual, mapAccumL, isn'tIn,
  53                           pprError, pprTrace, panic, assertPanic
  54                         )
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 A @CtrlReturnConvention@ says how {\em control} is returned.
  64 \begin{code}
  65 data CtrlReturnConvention
  66   = VectoredReturn      Int     -- size of the vector table (family size)
  67   | UnvectoredReturn    Int     -- family size
  68 \end{code}
  69
  70 A @DataReturnConvention@ says how the data for a particular
  71 data-constructor is returned.
  72 \begin{code}
  73 data DataReturnConvention
  74   = ReturnInHeap
  75   | ReturnInRegs        [MagicId]
  76 \end{code}
  77 The register assignment given by a @ReturnInRegs@ obeys three rules:
  78 \begin{itemize}
  79 \item   R1 is dead.
  80 \item   R2 points to the info table for the phantom constructor
  81 \item   The list of @MagicId@ is in the same order as the arguments
  82         to the constructor.
  83 \end{itemize}
  84
  85
  86 %************************************************************************
  87 %*                                                                      *
  88 \subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
  89 %*                                                                      *
  90 %************************************************************************
  91
  92 \begin{code}
  93 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
  94
  95 ctrlReturnConvAlg tycon
  96   = case (tyConFamilySize tycon) of
  97       0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $
  98            UnvectoredReturn 0 -- e.g., w/ "data Bin"
  99
 100       size -> -- we're supposed to know...
 101         if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
 102             VectoredReturn size
 103         else
 104             UnvectoredReturn size
 105 \end{code}
 106
 107 @dataReturnConvAlg@ determines the return conventions from the
 108 (possibly specialised) data constructor.
 109
 110 (See also @getDataConReturnConv@ (in @Id@).)  We grab the types
 111 of the data constructor's arguments.  We feed them and a list of
 112 available registers into @assign_reg@, which sequentially assigns
 113 registers of the appropriate types to the arguments, based on the
 114 types.  If @assign_reg@ runs out of a particular kind of register,
 115 then it gives up, returning @ReturnInHeap@.
 116
 117 \begin{code}
 118 dataReturnConvAlg :: DataCon -> DataReturnConvention
 119
 120 dataReturnConvAlg data_con
 121   = ASSERT(isDataCon data_con)
 122     case leftover_kinds of
 123         []    ->        ReturnInRegs reg_assignment
 124         other ->        ReturnInHeap    -- Didn't fit in registers
 125   where
 126     (_, _, arg_tys, _) = dataConSig data_con
 127
 128     (reg_assignment, leftover_kinds)
 129       = assignRegs [node, infoptr] -- taken...
 130                    (map typePrimRep arg_tys)
 131 \end{code}
 132
 133 %************************************************************************
 134 %*                                                                      *
 135 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
 136 %*                                                                      *
 137 %************************************************************************
 138
 139 WARNING! If you add a return convention which can return a pointer,
 140 make sure you alter CgCase (cgPrimDefault) to generate the right sort
 141 of heap check!
 142 \begin{code}
 143 dataReturnConvPrim :: PrimRep -> MagicId
 144
 145 dataReturnConvPrim IntRep       = VanillaReg IntRep  ILIT(1)
 146 dataReturnConvPrim WordRep      = VanillaReg WordRep ILIT(1)
 147 dataReturnConvPrim AddrRep      = VanillaReg AddrRep ILIT(1)
 148 dataReturnConvPrim CharRep      = VanillaReg CharRep ILIT(1)
 149 dataReturnConvPrim FloatRep     = FloatReg  ILIT(1)
 150 dataReturnConvPrim DoubleRep    = DoubleReg ILIT(1)
 151 dataReturnConvPrim VoidRep      = VoidReg
 152
 153 -- Return a primitive-array pointer in the usual register:
 154 dataReturnConvPrim ArrayRep     = VanillaReg ArrayRep ILIT(1)
 155 dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
 156
 157 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
 158 dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
 159
 160 #ifdef DEBUG
 161 dataReturnConvPrim PtrRep       = panic "dataReturnConvPrim: PtrRep"
 162 dataReturnConvPrim _            = panic "dataReturnConvPrim: other"
 163 #endif
 164 \end{code}
 165
 166 %********************************************************
 167 %*                                                      *
 168 \subsection[primop-stuff]{Argument and return conventions for Prim Ops}
 169 %*                                                      *
 170 %********************************************************
 171
 172 \begin{code}
 173 assignPrimOpResultRegs
 174     :: PrimOp           -- The constructors in canonical order
 175     -> [MagicId]        -- The return regs all concatenated to together,
 176                         -- (*including* one for the tag if necy)
 177
 178 assignPrimOpResultRegs op
 179  = case (getPrimOpResultInfo op) of
 180
 181         ReturnsPrim kind -> [dataReturnConvPrim kind]
 182
 183         ReturnsAlg tycon
 184           -> let
 185                 cons        = tyConDataCons tycon
 186                 result_regs = concat (map get_return_regs cons)
 187              in
 188              -- As R1 is dead, it can hold the tag if necessary
 189              case cons of
 190                 [_]   -> result_regs
 191                 other -> (VanillaReg IntRep ILIT(1)) : result_regs
 192   where
 193     get_return_regs con
 194       = case (dataReturnConvAlg con) of
 195           ReturnInRegs regs -> regs
 196           ReturnInHeap      -> panic "getPrimOpAlgResultRegs"
 197 \end{code}
 198
 199 @assignPrimOpArgsRobust@ is used only for primitive ops which may
 200 trigger GC. [MAYBE (WDP 94/05)] For these, we pass all (nonRobust)
 201 arguments in registers.  This function assigns them and tells us which
 202 of those registers are now live (because we've shoved a followable
 203 argument into it).
 204
 205 Bug: it is assumed that robust amodes cannot contain pointers.  This
 206 seems reasonable but isn't true.  For example, \tr{Array#}'s
 207 \tr{ForeignObj#}'s are pointers.  (This is only known to bite on
 208 \tr{_ccall_GC_} with a ForeignObj argument.)
 209
 210 See after for some ADR comments...
 211
 212 \begin{code}
 213 makePrimOpArgsRobust
 214         :: PrimOp
 215         -> [CAddrMode]          -- Arguments
 216         -> ([CAddrMode],        -- Arg registers
 217             Int,                -- Liveness mask
 218             AbstractC)          -- Simultaneous assignments to assign args to regs
 219
 220 makePrimOpArgsRobust op arg_amodes
 221   = ASSERT (primOpCanTriggerGC op)
 222     let
 223         non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
 224         arg_kinds = map getAmodeRep non_robust_amodes
 225
 226         (arg_regs, extra_args)
 227           = assignRegs [{-nothing live-}] arg_kinds
 228
 229                 -- Check that all the args fit before returning arg_regs
 230         final_arg_regs = case extra_args of
 231                            []    -> arg_regs
 232                            other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op)
 233
 234         arg_assts
 235           = mkAbstractCs (zipWithEqual "assign_to_reg" assign_to_reg final_arg_regs non_robust_amodes)
 236
 237         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 238
 239         safe_arg regs arg
 240                 | amodeCanSurviveGC arg = (regs, arg)
 241                 | otherwise             = (tail regs, CReg (head regs))
 242         safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
 243
 244         liveness_mask = mkLiveRegsMask final_arg_regs
 245     in
 246     (safe_amodes, liveness_mask, arg_assts)
 247 \end{code}
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsubsection[CgRetConv-regs]{Register assignment}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 How to assign registers.
 256 Registers are assigned in order.
 257
 258 If we run out, we don't attempt to assign
 259 any further registers (even though we might have run out of only one kind of
 260 register); we just return immediately with the left-overs specified.
 261
 262 \begin{code}
 263 assignRegs  :: [MagicId]        -- Unavailable registers
 264             -> [PrimRep]        -- Arg or result kinds to assign
 265             -> ([MagicId],      -- Register assignment in same order
 266                                 -- for *initial segment of* input list
 267                 [PrimRep])-- leftover kinds
 268
 269 assignRegs regs_in_use kinds
 270  = assign_reg kinds [] (mkRegTbl regs_in_use)
 271  where
 272
 273     assign_reg  :: [PrimRep]  -- arg kinds being scrutinized
 274                 -> [MagicId]        -- accum. regs assigned so far (reversed)
 275                 -> ([Int], [Int], [Int])
 276                         -- regs still avail: Vanilla, Float, Double
 277                 -> ([MagicId], [PrimRep])
 278
 279     assign_reg (VoidRep:ks) acc supply
 280         = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
 281
 282     assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
 283         = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs)
 284
 285     assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
 286         = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs)
 287
 288     assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs)
 289         | not (isFloatingRep k)
 290         = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs)
 291
 292     -- The catch-all.  It can happen because either
 293     --  (a) we've assigned all the regs so leftover_ks is []
 294     --  (b) we couldn't find a spare register in the appropriate supply
 295     --  or, I suppose,
 296     --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 297     assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
 298 \end{code}
 299
 300 Register supplies.  Vanilla registers can contain pointers, Ints, Chars.
 301
 302 \begin{code}
 303 vanillaRegNos :: [Int]
 304 vanillaRegNos   = [1 .. mAX_Vanilla_REG]
 305 \end{code}
 306
 307 Floats and doubles have separate register supplies.
 308
 309 \begin{code}
 310 floatRegNos, doubleRegNos :: [Int]
 311 floatRegNos     = [1 .. mAX_Float_REG]
 312 doubleRegNos    = [1 .. mAX_Double_REG]
 313
 314 mkRegTbl :: [MagicId] -> ([Int], [Int], [Int])
 315
 316 mkRegTbl regs_in_use
 317   = (ok_vanilla, ok_float, ok_double)
 318   where
 319     ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
 320     ok_float   = catMaybes (map (select FloatReg)              floatRegNos)
 321     ok_double  = catMaybes (map (select DoubleReg)             doubleRegNos)
 322
 323     taker :: [Int] -> [Int]
 324     taker rs
 325       = case (opt_ReturnInRegsThreshold) of
 326           Nothing -> rs -- no flag set; use all of them
 327           Just  n -> take n rs
 328
 329     select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
 330         -- one we've unboxed the Int, we make a MagicId
 331         -- and see if it is already in use; if not, return its number.
 332
 333     select mk_reg_fun cand@IBOX(i)
 334       = let
 335             reg = mk_reg_fun i
 336         in
 337         if reg `not_elem` regs_in_use
 338         then Just cand
 339         else Nothing
 340       where
 341         not_elem = isn'tIn "mkRegTbl"
 342 \end{code}