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