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         MagicId, PrimKind, Id, CLabel, TyCon
  28     ) where
  29
  30 import AbsCSyn
  31
  32 import AbsPrel          ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
  33                           getPrimOpResultInfo, integerDataCon, PrimKind
  34                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  35                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  36                         )
  37 import AbsUniType       ( getTyConFamilySize, kindFromType, getTyConDataCons,
  38                           TyVarTemplate, TyCon, Class,
  39                           TauType(..), ThetaType(..), UniType
  40                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
  41                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  42                         )
  43 import CgCompInfo       -- various things
  44 import CgMonad          ( IntSwitchChecker(..) )
  45 import CmdLineOpts      ( GlobalSwitch(..) )
  46 import Id               ( Id, getDataConSig, fIRST_TAG, isDataCon,
  47                           DataCon(..), ConTag(..)
  48                         )
  49 import Maybes           ( catMaybes, Maybe(..) )
  50 import PrimKind
  51 import Util
  52 import Pretty
  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 (getTyConFamilySize tycon) of
  95       Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon)
  96                  UnvectoredReturn 0 -- e.g., w/ "data Bin"
  97
  98       Just 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 :: IntSwitchChecker -> DataCon -> DataReturnConvention
 117
 118 dataReturnConvAlg isw_chkr 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, _) = getDataConSig data_con
 125
 126     (reg_assignment, leftover_kinds)
 127       = assignRegs isw_chkr_to_use
 128                    [node, infoptr] -- taken...
 129                    (map kindFromType arg_tys)
 130
 131     isw_chkr_to_use = isw_chkr
 132 {-OLD:
 133       = if is_prim_result_ty {-and therefore *ignore* any return-in-regs threshold-}
 134         then \ x -> Nothing
 135         else isw_chkr
 136 -}
 137     is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
 138 \end{code}
 139
 140 \begin{code}
 141 noLiveRegsMask :: Int   -- Mask indicating nothing live
 142 noLiveRegsMask = 0
 143
 144 mkLiveRegsBitMask
 145         :: [MagicId]    -- Candidate live regs; depends what they have in them
 146         -> Int
 147
 148 mkLiveRegsBitMask regs
 149   = foldl do_reg noLiveRegsMask regs
 150   where
 151     do_reg acc (VanillaReg kind reg_no)
 152       | isFollowableKind kind
 153       = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
 154
 155     do_reg acc anything_else = acc
 156
 157     reg_tbl -- ToDo: mk Array!
 158       = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
 159          lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
 160
 161 {-
 162 -- Completely opaque code.  ADR
 163 -- What's wrong with: (untested)
 164
 165 mkLiveRegsBitMask regs
 166   = foldl (+) noLiveRegsMask (map liveness_bit regs)
 167   where
 168     liveness_bit (VanillaReg kind reg_no)
 169       | isFollowableKind kind
 170       = reg_tbl !! (reg_no - 1)
 171
 172     liveness_bit anything_else
 173       = noLiveRegsBitMask
 174
 175     reg_tbl
 176       = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
 177          lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
 178 -}
 179 \end{code}
 180
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 WARNING! If you add a return convention which can return a pointer,
 189 make sure you alter CgCase (cgPrimDefault) to generate the right sort
 190 of heap check!
 191 \begin{code}
 192 dataReturnConvPrim :: PrimKind -> MagicId
 193
 194 #ifndef DPH
 195 dataReturnConvPrim IntKind      = VanillaReg IntKind  ILIT(1)
 196 dataReturnConvPrim WordKind     = VanillaReg WordKind ILIT(1)
 197 dataReturnConvPrim AddrKind     = VanillaReg AddrKind ILIT(1)
 198 dataReturnConvPrim CharKind     = VanillaReg CharKind ILIT(1)
 199 dataReturnConvPrim FloatKind    = FloatReg  ILIT(1)
 200 dataReturnConvPrim DoubleKind   = DoubleReg ILIT(1)
 201 dataReturnConvPrim VoidKind     = VoidReg
 202
 203 -- Return a primitive-array pointer in the usual register:
 204 dataReturnConvPrim ArrayKind     = VanillaReg ArrayKind ILIT(1)
 205 dataReturnConvPrim ByteArrayKind = VanillaReg ByteArrayKind ILIT(1)
 206
 207 dataReturnConvPrim StablePtrKind = VanillaReg StablePtrKind ILIT(1)
 208 dataReturnConvPrim MallocPtrKind = VanillaReg MallocPtrKind ILIT(1)
 209
 210 dataReturnConvPrim PtrKind      = panic "dataReturnConvPrim: PtrKind"
 211 dataReturnConvPrim _            = panic "dataReturnConvPrim: other"
 212
 213 #else
 214 dataReturnConvPrim VoidKind     = VoidReg
 215 dataReturnConvPrim PtrKind      = panic "dataReturnConvPrim: PtrKind"
 216 dataReturnConvPrim kind         = DataReg kind 2 -- Don't Hog a Modifier reg.
 217 #endif {- Data Parallel Haskell -}
 218 \end{code}
 219
 220
 221 %********************************************************
 222 %*                                                      *
 223 \subsection[primop-stuff]{Argument and return conventions for Prim Ops}
 224 %*                                                      *
 225 %********************************************************
 226
 227 \begin{code}
 228 assignPrimOpResultRegs
 229     :: PrimOp           -- The constructors in canonical order
 230     -> [MagicId]        -- The return regs all concatenated to together,
 231                         -- (*including* one for the tag if necy)
 232
 233 assignPrimOpResultRegs op
 234  = case (getPrimOpResultInfo op) of
 235
 236         ReturnsPrim kind -> [dataReturnConvPrim kind]
 237
 238         ReturnsAlg tycon
 239           -> let
 240                 cons        = getTyConDataCons tycon
 241                 result_regs = concat (map get_return_regs cons)
 242              in
 243              -- As R1 is dead, it can hold the tag if necessary
 244              case cons of
 245                 [_]   -> result_regs
 246                 other -> (VanillaReg IntKind ILIT(1)) : result_regs
 247   where
 248     get_return_regs con
 249       = case (dataReturnConvAlg fake_isw_chkr con) of
 250           ReturnInRegs regs -> regs
 251           ReturnInHeap      -> panic "getPrimOpAlgResultRegs"
 252
 253     fake_isw_chkr :: IntSwitchChecker
 254     fake_isw_chkr x = Nothing
 255 \end{code}
 256
 257 @assignPrimOpArgsRobust@ is used only for primitive ops which may
 258 trigger GC. [MAYBE (WDP 94/05)] For these, we pass all (nonRobust)
 259 arguments in registers.  This function assigns them and tells us which
 260 of those registers are now live (because we've shoved a followable
 261 argument into it).
 262
 263 Bug: it is assumed that robust amodes cannot contain pointers.  This
 264 seems reasonable but isn't true.  For example, \tr{Array#}'s
 265 \tr{MallocPtr#}'s are pointers.  (This is only known to bite on
 266 \tr{_ccall_GC_} with a MallocPtr argument.)
 267
 268 See after for some ADR comments...
 269
 270 \begin{code}
 271 makePrimOpArgsRobust
 272         :: PrimOp
 273         -> [CAddrMode]          -- Arguments
 274         -> ([CAddrMode],        -- Arg registers
 275             Int,                -- Liveness mask
 276             AbstractC)          -- Simultaneous assignments to assign args to regs
 277
 278 makePrimOpArgsRobust op arg_amodes
 279   = ASSERT (primOpCanTriggerGC op)
 280     let
 281         non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
 282         arg_kinds = map getAmodeKind non_robust_amodes
 283
 284         (arg_regs, extra_args)
 285           = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds
 286
 287                 -- Check that all the args fit before returning arg_regs
 288         final_arg_regs = case extra_args of
 289                            []    -> arg_regs
 290                            other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
 291
 292         arg_assts = mkAbstractCs (zipWith assign_to_reg final_arg_regs non_robust_amodes)
 293         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 294
 295         safe_arg regs arg
 296                 | amodeCanSurviveGC arg = (regs, arg)
 297                 | otherwise             = (tail regs, CReg (head regs))
 298         safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
 299
 300         liveness_mask = mkLiveRegsBitMask final_arg_regs
 301     in
 302     (safe_amodes, liveness_mask, arg_assts)
 303   where
 304     fake_isw_chkr :: IntSwitchChecker
 305     fake_isw_chkr x = Nothing
 306 \end{code}
 307
 308 %************************************************************************
 309 %*                                                                      *
 310 \subsubsection[CgRetConv-regs]{Register assignment}
 311 %*                                                                      *
 312 %************************************************************************
 313
 314 How to assign registers.
 315 Registers are assigned in order.
 316
 317 If we run out, we don't attempt to assign
 318 any further registers (even though we might have run out of only one kind of
 319 register); we just return immediately with the left-overs specified.
 320
 321 \begin{code}
 322 assignRegs  :: IntSwitchChecker
 323             -> [MagicId]        -- Unavailable registers
 324             -> [PrimKind]       -- Arg or result kinds to assign
 325             -> ([MagicId],      -- Register assignment in same order
 326                                 -- for *initial segment of* input list
 327                 [PrimKind])-- leftover kinds
 328
 329 assignRegs isw_chkr regs_in_use kinds
 330  = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use)
 331  where
 332
 333     assign_reg  :: [PrimKind]  -- arg kinds being scrutinized
 334                 -> [MagicId]        -- accum. regs assigned so far (reversed)
 335                 -> ([Int], [Int], [Int])
 336                         -- regs still avail: Vanilla, Float, Double
 337                 -> ([MagicId], [PrimKind])
 338
 339     assign_reg (VoidKind:ks) acc supply
 340         = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
 341
 342     assign_reg (FloatKind:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
 343         = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs)
 344
 345     assign_reg (DoubleKind:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
 346         = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs)
 347
 348     assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs)
 349         | not (isFloatingKind k)
 350         = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs)
 351
 352     -- The catch-all.  It can happen because either
 353     --  (a) we've assigned all the regs so leftover_ks is []
 354     --  (b) we couldn't find a spare register in the appropriate supply
 355     --  or, I suppose,
 356     --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 357     assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
 358 \end{code}
 359
 360 Register supplies.  Vanilla registers can contain pointers, Ints, Chars.
 361
 362 \begin{code}
 363 vanillaRegNos :: [Int]
 364 vanillaRegNos   = [1 .. mAX_Vanilla_REG]
 365 \end{code}
 366
 367 Floats and doubles have separate register supplies.
 368
 369 \begin{code}
 370 floatRegNos, doubleRegNos :: [Int]
 371 floatRegNos     = [1 .. mAX_Float_REG]
 372 doubleRegNos    = [1 .. mAX_Double_REG]
 373
 374 mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int])
 375
 376 mkRegTbl isw_chkr regs_in_use
 377   = (ok_vanilla, ok_float, ok_double)
 378   where
 379     ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) (taker vanillaRegNos))
 380     ok_float   = catMaybes (map (select FloatReg)              floatRegNos)
 381     ok_double  = catMaybes (map (select DoubleReg)             doubleRegNos)
 382
 383     taker :: [Int] -> [Int]
 384     taker rs
 385       = case (isw_chkr ReturnInRegsThreshold) of
 386           Nothing -> rs -- no flag set; use all of them
 387           Just  n -> take n rs
 388
 389     select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
 390         -- one we've unboxed the Int, we make a MagicId
 391         -- and see if it is already in use; if not, return its number.
 392
 393     select mk_reg_fun cand@IBOX(i)
 394       = let
 395             reg = mk_reg_fun i
 396         in
 397         if reg `not_elem` regs_in_use
 398         then Just cand
 399         else Nothing
 400       where
 401         not_elem = isn'tIn "mkRegTbl"
 402 \end{code}