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