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