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