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