ghc/compiler/codeGen/CgRetConv.lhs

   1 %
   2 % (c) The GRASP Project, Glasgow University, 1992-1998
   3 %
   4 % $Id: CgRetConv.lhs,v 1.20 2000/03/23 17:45:19 simonpj Exp $
   5 %
   6 \section[CgRetConv]{Return conventions for the code generator}
   7
   8 The datatypes and functions here encapsulate what there is to know
   9 about return conventions.
  10
  11 \begin{code}
  12 module CgRetConv (
  13         CtrlReturnConvention(..),
  14         ctrlReturnConvAlg,
  15         dataReturnConvPrim,
  16         assignRegs, assignAllRegs
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 import AbsCSyn          -- quite a few things
  22 import Constants        ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
  23                           mAX_Vanilla_REG, mAX_Float_REG,
  24                           mAX_Double_REG, mAX_Long_REG
  25                         )
  26 import CmdLineOpts      ( opt_UseVanillaRegs, opt_UseFloatRegs,
  27                           opt_UseDoubleRegs, opt_UseLongRegs
  28                         )
  29 import Maybes           ( catMaybes )
  30 import DataCon          ( DataCon )
  31 import PrimOp           ( PrimOp{-instance Outputable-} )
  32 import PrimRep          ( isFloatingRep, PrimRep(..), is64BitRep )
  33 import TyCon            ( TyCon, tyConDataCons, tyConFamilySize )
  34 import Type             ( Type, typePrimRep, isUnLiftedType,
  35                           splitAlgTyConApp_maybe )
  36 import Util             ( isn'tIn )
  37
  38 import Outputable
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection[CgRetConv-possibilities]{Data types that encode possible return conventions}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 A @CtrlReturnConvention@ says how {\em control} is returned.
  48 \begin{code}
  49 data CtrlReturnConvention
  50   = VectoredReturn      Int     -- size of the vector table (family size)
  51   | UnvectoredReturn    Int     -- family size
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
  62
  63 ctrlReturnConvAlg tycon
  64   = case (tyConFamilySize tycon) of
  65       0 -> panic "ctrlRetConvAlg"
  66       size -> -- we're supposed to know...
  67         if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
  68             VectoredReturn size
  69         else
  70             UnvectoredReturn size
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 dataReturnConvPrim :: PrimRep -> MagicId
  81
  82 dataReturnConvPrim IntRep       = VanillaReg IntRep  ILIT(1)
  83 dataReturnConvPrim WordRep      = VanillaReg WordRep ILIT(1)
  84 dataReturnConvPrim Int64Rep     = LongReg Int64Rep  ILIT(1)
  85 dataReturnConvPrim Word64Rep    = LongReg Word64Rep ILIT(1)
  86 dataReturnConvPrim AddrRep      = VanillaReg AddrRep ILIT(1)
  87 dataReturnConvPrim CharRep      = VanillaReg CharRep ILIT(1)
  88 dataReturnConvPrim FloatRep     = FloatReg  ILIT(1)
  89 dataReturnConvPrim DoubleRep    = DoubleReg ILIT(1)
  90 dataReturnConvPrim VoidRep      = VoidReg
  91
  92 -- Return a primitive-array pointer in the usual register:
  93 dataReturnConvPrim ArrayRep     = VanillaReg ArrayRep ILIT(1)
  94 dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
  95
  96 dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
  97 dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
  98 dataReturnConvPrim WeakPtrRep   = VanillaReg WeakPtrRep ILIT(1)
  99
 100 #ifdef DEBUG
 101 dataReturnConvPrim PtrRep       = panic "dataReturnConvPrim: PtrRep"
 102 dataReturnConvPrim _            = panic "dataReturnConvPrim: other"
 103 #endif
 104 \end{code}
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsubsection[CgRetConv-regs]{Register assignment}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 How to assign registers for
 113
 114         1) Calling a fast entry point.
 115         2) Returning an unboxed tuple.
 116         3) Invoking an out-of-line PrimOp.
 117
 118 Registers are assigned in order.
 119
 120 If we run out, we don't attempt to assign any further registers (even
 121 though we might have run out of only one kind of register); we just
 122 return immediately with the left-overs specified.
 123
 124 The alternative version @assignAllRegs@ uses the complete set of
 125 registers, including those that aren't mapped to real machine
 126 registers.  This is used for calling special RTS functions and PrimOps
 127 which expect their arguments to always be in the same registers.
 128
 129 \begin{code}
 130 assignRegs, assignAllRegs
 131         :: [MagicId]    -- Unavailable registers
 132         -> [PrimRep]    -- Arg or result kinds to assign
 133         -> ([MagicId],  -- Register assignment in same order
 134                                 -- for *initial segment of* input list
 135             [PrimRep])-- leftover kinds
 136
 137 assignRegs regs_in_use kinds
 138  = assign_reg kinds [] (mkRegTbl regs_in_use)
 139
 140 assignAllRegs regs_in_use kinds
 141  = assign_reg kinds [] (mkRegTbl_allRegs regs_in_use)
 142
 143 assign_reg
 144         :: [PrimRep]              -- arg kinds being scrutinized
 145         -> [MagicId]              -- accum. regs assigned so far (reversed)
 146         -> AvailRegs              -- regs still avail: Vanilla, Float, Double, longs
 147         -> ([MagicId], [PrimRep])
 148
 149 assign_reg (VoidRep:ks) acc supply
 150         = assign_reg ks (VoidReg:acc) supply
 151         -- one VoidReg is enough for everybody!
 152
 153 assign_reg (FloatRep:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs, long_rs)
 154         = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs, long_rs)
 155
 156 assign_reg (DoubleRep:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs, long_rs)
 157         = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs, long_rs)
 158
 159 assign_reg (Word64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(u):long_rs)
 160         = assign_reg ks (LongReg Word64Rep u:acc) (vanilla_rs, float_rs, double_rs, long_rs)
 161
 162 assign_reg (Int64Rep:ks) acc (vanilla_rs, float_rs, double_rs, IBOX(l):long_rs)
 163         = assign_reg ks (LongReg Int64Rep l:acc) (vanilla_rs, float_rs, double_rs, long_rs)
 164
 165 assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs, long_rs)
 166         | not (isFloatingRep k || is64BitRep k)
 167         = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs, long_rs)
 168
 169 -- The catch-all.  It can happen because either
 170 --      (a) we've assigned all the regs so leftover_ks is []
 171 --  (b) we couldn't find a spare register in the appropriate supply
 172 --  or, I suppose,
 173 --  (c) we came across a Kind we couldn't handle (this one shouldn't happen)
 174 assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
 175
 176 \end{code}
 177
 178 Register supplies.  Vanilla registers can contain pointers, Ints, Chars.
 179 Floats and doubles have separate register supplies.
 180
 181 We take these register supplies from the *real* registers, i.e. those
 182 that are guaranteed to map to machine registers.
 183
 184 \begin{code}
 185 vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int]
 186 vanillaRegNos    = regList opt_UseVanillaRegs
 187 floatRegNos      = regList opt_UseFloatRegs
 188 doubleRegNos     = regList opt_UseDoubleRegs
 189 longRegNos       = regList opt_UseLongRegs
 190
 191 allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int]
 192 allVanillaRegNos = regList mAX_Vanilla_REG
 193 allFloatRegNos   = regList mAX_Float_REG
 194 allDoubleRegNos  = regList mAX_Double_REG
 195 allLongRegNos    = regList mAX_Long_REG
 196
 197 regList 0 = []
 198 regList n = [1 .. n]
 199
 200 type AvailRegs = ( [Int]   -- available vanilla regs.
 201                  , [Int]   -- floats
 202                  , [Int]   -- doubles
 203                  , [Int]   -- longs (int64 and word64)
 204                  )
 205
 206 mkRegTbl :: [MagicId] -> AvailRegs
 207 mkRegTbl regs_in_use
 208   = mkRegTbl' regs_in_use vanillaRegNos floatRegNos doubleRegNos longRegNos
 209
 210 mkRegTbl_allRegs :: [MagicId] -> AvailRegs
 211 mkRegTbl_allRegs regs_in_use
 212   = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
 213
 214 mkRegTbl' regs_in_use vanillas floats doubles longs
 215   = (ok_vanilla, ok_float, ok_double, ok_long)
 216   where
 217     ok_vanilla = catMaybes (map (select (VanillaReg VoidRep))  vanillas)
 218     ok_float   = catMaybes (map (select FloatReg)              floats)
 219     ok_double  = catMaybes (map (select DoubleReg)             doubles)
 220     ok_long    = catMaybes (map (select (LongReg Int64Rep))    longs)
 221                                     -- rep isn't looked at, hence we can use any old rep.
 222
 223     select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
 224         -- one we've unboxed the Int, we make a MagicId
 225         -- and see if it is already in use; if not, return its number.
 226
 227     select mk_reg_fun cand@IBOX(i)
 228       = let
 229             reg = mk_reg_fun i
 230         in
 231         if reg `not_elem` regs_in_use
 232         then Just cand
 233         else Nothing
 234       where
 235         not_elem = isn'tIn "mkRegTbl"
 236 \end{code}