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, 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
  45 import Id               ( Id, getDataConSig, fIRST_TAG, isDataCon,
  46                           DataCon(..), ConTag(..)
  47                         )
  48 import Maybes           ( catMaybes, Maybe(..) )
  49 import PrimKind
  50 import Util
  51 import Pretty
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 A @CtrlReturnConvention@ says how {\em control} is returned.
  61 \begin{code}
  62 data CtrlReturnConvention
  63   = VectoredReturn      Int     -- size of the vector table (family size)
  64   | UnvectoredReturn    Int     -- family size
  65 \end{code}
  66
  67 A @DataReturnConvention@ says how the data for a particular
  68 data-constructor is returned.
  69 \begin{code}
  70 data DataReturnConvention
  71   = ReturnInHeap
  72   | ReturnInRegs        [MagicId]
  73 \end{code}
  74 The register assignment given by a @ReturnInRegs@ obeys three rules:
  75 \begin{itemize}
  76 \item   R1 is dead.
  77 \item   R2 points to the info table for the phantom constructor
  78 \item   The list of @MagicId@ is in the same order as the arguments
  79         to the constructor.
  80 \end{itemize}
  81
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 \begin{code}
  90 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
  91 ctrlReturnConvAlg tycon
  92   = case (getTyConFamilySize tycon) of
  93       Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon)
  94                  UnvectoredReturn 0 -- e.g., w/ "data Bin"
  95
  96       Just size -> -- we're supposed to know...
  97         if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
  98             VectoredReturn size
  99         else
 100             UnvectoredReturn size
 101 \end{code}
 102
 103 @dataReturnConvAlg@ determines the return conventions from the
 104 (possibly specialised) data constructor.
 105
 106 (See also @getDataConReturnConv@ (in @Id@).)  We grab the types
 107 of the data constructor's arguments.  We feed them and a list of
 108 available registers into @assign_reg@, which sequentially assigns
 109 registers of the appropriate types to the arguments, based on the
 110 types.  If @assign_reg@ runs out of a particular kind of register,
 111 then it gives up, returning @ReturnInHeap@.
 112
 113 \begin{code}
 114 dataReturnConvAlg :: DataCon -> DataReturnConvention
 115
 116 dataReturnConvAlg data_con
 117   = ASSERT(isDataCon data_con)
 118     case leftover_kinds of
 119         []    ->        ReturnInRegs reg_assignment
 120         other ->        ReturnInHeap    -- Didn't fit in registers
 121   where
 122     (_, _, arg_tys, _) = getDataConSig data_con
 123     (reg_assignment, leftover_kinds) = assignRegs [node,infoptr]
 124                                                   (map kindFromType arg_tys)
 125 \end{code}
 126
 127 \begin{code}
 128 noLiveRegsMask :: Int   -- Mask indicating nothing live
 129 noLiveRegsMask = 0
 130
 131 mkLiveRegsBitMask
 132         :: [MagicId]    -- Candidate live regs; depends what they have in them
 133         -> Int
 134
 135 mkLiveRegsBitMask regs
 136   = foldl do_reg noLiveRegsMask regs
 137   where
 138     do_reg acc (VanillaReg kind reg_no)
 139       | isFollowableKind kind
 140       = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
 141
 142     do_reg acc anything_else = acc
 143
 144     reg_tbl -- ToDo: mk Array!
 145       = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
 146          lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
 147
 148 {-
 149 -- Completely opaque code.  ADR
 150 -- What's wrong with: (untested)
 151
 152 mkLiveRegsBitMask regs
 153   = foldl (+) noLiveRegsMask (map liveness_bit regs)
 154   where
 155     liveness_bit (VanillaReg kind reg_no)
 156       | isFollowableKind kind
 157       = reg_tbl !! (reg_no - 1)
 158
 159     liveness_bit anything_else
 160       = noLiveRegsBitMask
 161
 162     reg_tbl
 163       = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
 164          lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
 165 -}
 166 \end{code}
 167
 168
 169 %************************************************************************
 170 %*                                                                      *
 171 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
 172 %*                                                                      *
 173 %************************************************************************
 174
 175 WARNING! If you add a return convention which can return a pointer,
 176 make sure you alter CgCase (cgPrimDefault) to generate the right sort
 177 of heap check!
 178 \begin{code}
 179 dataReturnConvPrim :: PrimKind -> MagicId
 180
 181 #ifndef DPH
 182 dataReturnConvPrim IntKind      = VanillaReg IntKind  ILIT(1)
 183 dataReturnConvPrim WordKind     = VanillaReg WordKind ILIT(1)
 184 dataReturnConvPrim AddrKind     = VanillaReg AddrKind ILIT(1)
 185 dataReturnConvPrim CharKind     = VanillaReg CharKind ILIT(1)
 186 dataReturnConvPrim FloatKind    = FloatReg  ILIT(1)
 187 dataReturnConvPrim DoubleKind   = DoubleReg ILIT(1)
 188 dataReturnConvPrim VoidKind     = VoidReg
 189
 190 -- Return a primitive-array pointer in the usual register:
 191 dataReturnConvPrim ArrayKind     = VanillaReg ArrayKind ILIT(1)
 192 dataReturnConvPrim ByteArrayKind = VanillaReg ByteArrayKind ILIT(1)
 193
 194 dataReturnConvPrim StablePtrKind = VanillaReg StablePtrKind ILIT(1)
 195 dataReturnConvPrim MallocPtrKind = VanillaReg MallocPtrKind ILIT(1)
 196
 197 dataReturnConvPrim PtrKind      = panic "dataReturnConvPrim: PtrKind"
 198 dataReturnConvPrim _            = panic "dataReturnConvPrim: other"
 199
 200 #else
 201 dataReturnConvPrim VoidKind     = VoidReg
 202 dataReturnConvPrim PtrKind      = panic "dataReturnConvPrim: PtrKind"
 203 dataReturnConvPrim kind         = DataReg kind 2 -- Don't Hog a Modifier reg.
 204 #endif {- Data Parallel Haskell -}
 205 \end{code}
 206
 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 -> let cons        = getTyConDataCons tycon
 226                                 result_regs = concat (map get_return_regs cons)
 227                             in
 228                                 -- Since R1 is dead, it can hold the tag if necessary
 229                             case cons of
 230                                 [_]   -> result_regs
 231                                 other -> (VanillaReg IntKind ILIT(1)) : result_regs
 232
 233  where
 234    get_return_regs con = case (dataReturnConvAlg con) of
 235                               ReturnInHeap      -> panic "getPrimOpAlgResultRegs"
 236                               ReturnInRegs regs -> regs
 237 \end{code}
 238
 239 @assignPrimOpArgsRobust@ is used only for primitive ops which may
 240 trigger GC. [MAYBE (WDP 94/05)] For these, we pass all (nonRobust)
 241 arguments in registers.  This function assigns them and tells us which
 242 of those registers are now live (because we've shoved a followable
 243 argument into it).
 244
 245 Bug: it is assumed that robust amodes cannot contain pointers.  This
 246 seems reasonable but isn't true.  For example, \tr{Array#}'s
 247 \tr{MallocPtr#}'s are pointers.  (This is only known to bite on
 248 \tr{_ccall_GC_} with a MallocPtr argument.)
 249
 250 See after for some ADR comments...
 251
 252 \begin{code}
 253 makePrimOpArgsRobust
 254         :: PrimOp
 255         -> [CAddrMode]          -- Arguments
 256         -> ([CAddrMode],        -- Arg registers
 257             Int,                -- Liveness mask
 258             AbstractC)          -- Simultaneous assignments to assign args to regs
 259
 260 makePrimOpArgsRobust op arg_amodes
 261   = ASSERT (primOpCanTriggerGC op)
 262     let
 263         non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
 264         arg_kinds = map getAmodeKind non_robust_amodes
 265
 266         (arg_regs, extra_args) = assignRegs [{-nothing live-}] arg_kinds
 267
 268                 -- Check that all the args fit before returning arg_regs
 269         final_arg_regs = case extra_args of
 270                            []    -> arg_regs
 271                            other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
 272
 273         arg_assts = mkAbstractCs (zipWith assign_to_reg arg_regs non_robust_amodes)
 274         assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 275
 276         safe_arg regs arg
 277                 | amodeCanSurviveGC arg = (regs, arg)
 278                 | otherwise             = (tail regs, CReg (head regs))
 279         safe_amodes = snd (mapAccumL safe_arg arg_regs arg_amodes)
 280
 281         liveness_mask = mkLiveRegsBitMask arg_regs
 282     in
 283     (safe_amodes, liveness_mask, arg_assts)
 284 \end{code}
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsubsection[CgRetConv-regs]{Register assignment}
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 How to assign registers.
 293 Registers are assigned in order.
 294
 295 If we run out, we don't attempt to assign
 296 any further registers (even though we might have run out of only one kind of
 297 register); we just return immediately with the left-overs specified.
 298
 299 \begin{code}
 300 assignRegs  :: [MagicId]        -- Unavailable registers
 301             -> [PrimKind]       -- Arg or result kinds to assign
 302             -> ([MagicId],      -- Register assignment in same order
 303                                 -- for *initial segment of* input list
 304                 [PrimKind])-- leftover kinds
 305
 306 #ifndef DPH
 307 assignRegs regs_in_use kinds
 308  = assign_reg kinds [] (mkRegTbl regs_in_use)
 309  where
 310
 311     assign_reg  :: [PrimKind]  -- arg kinds being scrutinized
 312                 -> [MagicId]        -- accum. regs assigned so far (reversed)
 313                 -> ([Int], [Int], [Int])
 314                         -- regs still avail: Vanilla, Float, Double
 315                 -> ([MagicId], [PrimKind])
 316
 317     assign_reg (VoidKind:ks) acc supply
 318         = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody!
 319
 320     assign_reg (FloatKind:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs)
 321         = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs)
 322
 323     assign_reg (DoubleKind:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs)
 324         = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs)
 325
 326     assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs)
 327         | not (isFloatingKind k)
 328         = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs)
 329
 330     -- The catch-all.  It can happen because either
 331     --  (a) we've assigned all the regs so leftover_ks is []
 332     --  (b) we couldn't find a spare register in the appropriate supply
 333     --  or, I suppose,
 334     --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 335     assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
 336 #else
 337 assignRegs node_using_Ret1 kinds
 338  = if node_using_Ret1
 339    then assign_reg kinds [] (tail vanillaRegNos) (tail datRegNos)
 340    else assign_reg kinds [] vanillaRegNos        (tail datRegNos)
 341  where
 342     assign_reg:: [PrimKind]  -- arg kinds being scrutinized
 343               -> [MagicId]        -- accum. regs assigned so far (reversed)
 344               -> [Int]     -- Vanilla Regs (ptr, int, char, float or double)
 345               -> [Int]     -- Data Regs    (     int, char, float or double)
 346               -> ([MagicId], [PrimKind])
 347
 348     assign_reg (k:ks) acc (IBOX(p):ptr_regs) dat_regs
 349       | isFollowableKind k
 350       = assign_reg ks (VanillaReg k p:acc) ptr_regs dat_regs
 351
 352     assign_reg (CharKind:ks) acc ptr_regs (d:dat_regs)
 353       = assign_reg ks (DataReg CharKind d:acc) ptr_regs dat_regs
 354
 355     assign_reg (IntKind:ks) acc ptr_regs (d:dat_regs)
 356       = assign_reg ks (DataReg IntKind d:acc) ptr_regs dat_regs
 357
 358     assign_reg (WordKind:ks) acc ptr_regs (d:dat_regs)
 359       = assign_reg ks (DataReg WordKind d:acc) ptr_regs dat_regs
 360
 361     assign_reg (AddrKind:ks) acc ptr_regs (d:dat_regs)
 362       = assign_reg ks (DataReg AddrKind d:acc) ptr_regs dat_regs
 363
 364     assign_reg (FloatKind:ks) acc ptr_regs (d:dat_regs)
 365       = assign_reg ks (DataReg FloatKind d:acc) ptr_regs dat_regs
 366
 367     -- Notice how doubles take up two data registers....
 368     assign_reg (DoubleKind:ks)   acc ptr_regs (IBOX(d1):d2:dat_regs)
 369       = assign_reg ks (DoubleReg d1:acc) ptr_regs dat_regs
 370
 371     assign_reg (VoidKind:ks) acc ptr_regs dat_regs
 372       = assign_reg ks (VoidReg:acc) ptr_regs dat_regs
 373
 374     -- The catch-all.  It can happen because either
 375     --  (a) we've assigned all the regs so leftover_ks is []
 376     --  (b) we couldn't find a spare register in the appropriate supply
 377     --  or, I suppose,
 378     --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 379     --  ToDo Maybe when dataReg becomes empty, we can start using the
 380     --       vanilla registers ????
 381     assign_reg leftover_ks acc _ _ = (reverse acc, leftover_ks)
 382 #endif {- Data Parallel Haskell -}
 383 \end{code}
 384
 385 Register supplies.  Vanilla registers can contain pointers, Ints, Chars.
 386
 387 \begin{code}
 388 vanillaRegNos :: [Int]
 389 vanillaRegNos   = [1 .. mAX_Vanilla_REG]
 390 \end{code}
 391
 392 Only a subset of the registers on the DAP can be used to hold pointers (and most
 393 of these are taken up with things like the heap pointer and stack pointers).
 394 However the resulting registers can hold integers, floats or chars. We therefore
 395 allocate pointer like things into the @vanillaRegNos@ (and Ints Chars or Floats
 396 if the remaining registers are empty). See NOTE.regsiterMap for an outline of
 397 the global and local register allocation scheme.
 398
 399 \begin{code}
 400 #ifdef DPH
 401 datRegNos ::[Int]
 402 datRegNos = [1..mAX_Data_REG]           -- For Ints, Floats, Doubles or Chars
 403 #endif {- Data Parallel Haskell -}
 404 \end{code}
 405
 406 Floats and doubles have separate register supplies.
 407
 408 \begin{code}
 409 #ifndef DPH
 410 floatRegNos, doubleRegNos :: [Int]
 411 floatRegNos     = [1 .. mAX_Float_REG]
 412 doubleRegNos    = [1 .. mAX_Double_REG]
 413
 414 mkRegTbl :: [MagicId] -> ([Int], [Int], [Int])
 415 mkRegTbl regs_in_use = (ok_vanilla, ok_float, ok_double)
 416   where
 417     ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) vanillaRegNos)
 418     ok_float   = catMaybes (map (select FloatReg)              floatRegNos)
 419     ok_double  = catMaybes (map (select DoubleReg)             doubleRegNos)
 420
 421     select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
 422         -- one we've unboxed the Int, we make a MagicId
 423         -- and see if it is already in use; if not, return its number.
 424
 425     select mk_reg_fun cand@IBOX(i)
 426       = let
 427             reg = mk_reg_fun i
 428         in
 429         if reg `not_elem` regs_in_use
 430         then Just cand
 431         else Nothing
 432       where
 433         not_elem = isn'tIn "mkRegTbl"
 434
 435 #endif {- Data Parallel Haskell -}
 436 \end{code}