compiler/codeGen/CgInfoTbls.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Building info tables.
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgInfoTbls (
  10         emitClosureCodeAndInfoTable,
  11         emitInfoTableAndCode,
  12         dataConTagZ,
  13         emitReturnTarget, emitAlgReturnTarget,
  14         emitReturnInstr,
  15         stdInfoTableSizeB,
  16         entryCode, closureInfoPtr,
  17         getConstrTag,
  18         cmmGetClosureType,
  19         infoTable, infoTableClosureType,
  20         infoTablePtrs, infoTableNonPtrs,
  21         funInfoTable, makeRelativeRefTo
  22   ) where
  23
  24
  25 #include "HsVersions.h"
  26
  27 import ClosureInfo
  28 import SMRep
  29 import CgBindery
  30 import CgCallConv
  31 import CgUtils
  32 import CgMonad
  33
  34 import CmmUtils
  35 import Cmm
  36 import CLabel
  37 import Name
  38 import DataCon
  39 import Unique
  40 import StaticFlags
  41
  42 import Maybes
  43 import Constants
  44 import Util
  45 import Outputable
  46
  47 -------------------------------------------------------------------------
  48 --
  49 --      Generating the info table and code for a closure
  50 --
  51 -------------------------------------------------------------------------
  52
  53 -- Here we make an info table of type 'CmmInfo'.  The concrete
  54 -- representation as a list of 'CmmAddr' is handled later
  55 -- in the pipeline by 'cmmToRawCmm'.
  56
  57 emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code
  58 emitClosureCodeAndInfoTable cl_info args body
  59  = do   { blks <- cgStmtsToBlocks body
  60         ; info <- mkCmmInfo cl_info
  61         ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks }
  62   where
  63     info_lbl  = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info
  64
  65 -- We keep the *zero-indexed* tag in the srt_len field of the info
  66 -- table of a data constructor.
  67 dataConTagZ :: DataCon -> ConTagZ
  68 dataConTagZ con = dataConTag con - fIRST_TAG
  69
  70 -- Convert from 'ClosureInfo' to 'CmmInfo'.
  71 -- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
  72 mkCmmInfo :: ClosureInfo -> FCode CmmInfo
  73 mkCmmInfo cl_info = do
  74   prof <-
  75       if opt_SccProfilingOn
  76       then do ty_descr_lit <- mkStringCLit (closureTypeDescr cl_info)
  77               cl_descr_lit <- mkStringCLit (closureValDescr cl_info)
  78               return $ ProfilingInfo ty_descr_lit cl_descr_lit
  79       else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
  80
  81   case cl_info of
  82     ConInfo { closureCon = con } -> do
  83        cstr <- mkByteStringCLit $ dataConIdentity con
  84        let conName = makeRelativeRefTo info_lbl cstr
  85            info = ConstrInfo (ptrs, nptrs)
  86                              (fromIntegral (dataConTagZ con))
  87                              conName
  88        return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
  89
  90     ClosureInfo { closureName   = name,
  91                   closureLFInfo = lf_info,
  92                   closureSRT    = srt } ->
  93        return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
  94        where
  95          info =
  96              case lf_info of
  97                LFReEntrant _ arity _ arg_descr ->
  98                    FunInfo (ptrs, nptrs)
  99                            srt
 100                            (fromIntegral arity)
 101                            arg_descr
 102                            (CmmLabel (mkSlowEntryLabel name has_caf_refs))
 103                LFThunk _ _ _ (SelectorThunk offset) _ ->
 104                    ThunkSelectorInfo (fromIntegral offset) srt
 105                LFThunk _ _ _ _ _ ->
 106                    ThunkInfo (ptrs, nptrs) srt
 107                _ -> panic "unexpected lambda form in mkCmmInfo"
 108   where
 109     info_lbl = infoTableLabelFromCI cl_info has_caf_refs
 110     has_caf_refs = clHasCafRefs cl_info
 111
 112     cl_type  = smRepClosureTypeInt (closureSMRep cl_info)
 113
 114     ptrs     = fromIntegral $ closurePtrsSize cl_info
 115     size     = fromIntegral $ closureNonHdrSize cl_info
 116     nptrs    = size - ptrs
 117
 118     -- The gc_target is to inform the CPS pass when it inserts a stack check.
 119     -- Since that pass isn't used yet we'll punt for now.
 120     -- When the CPS pass is fully integrated, this should
 121     -- be replaced by the label that any heap check jumped to,
 122     -- so that branch can be shared by both the heap (from codeGen)
 123     -- and stack checks (from the CPS pass).
 124     gc_target = panic "TODO: gc_target"
 125
 126 -------------------------------------------------------------------------
 127 --
 128 --      Generating the info table and code for a return point
 129 --
 130 -------------------------------------------------------------------------
 131
 132 -- The concrete representation as a list of 'CmmAddr' is handled later
 133 -- in the pipeline by 'cmmToRawCmm'.
 134
 135 emitReturnTarget
 136    :: Name
 137    -> CgStmts                   -- The direct-return code (if any)
 138    -> FCode CLabel
 139 emitReturnTarget name stmts
 140   = do  { srt_info   <- getSRTInfo
 141         ; blks <- cgStmtsToBlocks stmts
 142         ; frame <- mkStackLayout
 143         ; let info = CmmInfo
 144                        gc_target
 145                        Nothing
 146                        (CmmInfoTable False
 147                         (ProfilingInfo zeroCLit zeroCLit)
 148                         rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
 149                         (ContInfo frame srt_info))
 150         ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks
 151         ; return info_lbl }
 152   where
 153     args      = {- trace "emitReturnTarget: missing args" -} []
 154     uniq      = getUnique name
 155     info_lbl  = mkReturnInfoLabel uniq
 156
 157     -- The gc_target is to inform the CPS pass when it inserts a stack check.
 158     -- Since that pass isn't used yet we'll punt for now.
 159     -- When the CPS pass is fully integrated, this should
 160     -- be replaced by the label that any heap check jumped to,
 161     -- so that branch can be shared by both the heap (from codeGen)
 162     -- and stack checks (from the CPS pass).
 163     gc_target = panic "TODO: gc_target"
 164
 165
 166 -- Build stack layout information from the state of the 'FCode' monad.
 167 -- Should go away once 'codeGen' starts using the CPS conversion
 168 -- pass to handle the stack.  Until then, this is really just
 169 -- here to convert from the 'codeGen' representation of the stack
 170 -- to the 'CmmInfo' representation of the stack.
 171 --
 172 -- See 'CmmInfo.mkLiveness' for where this is converted to a bitmap.
 173
 174 {-
 175 This seems to be a very error prone part of the code.
 176 It is surprisingly prone to off-by-one errors, because
 177 it converts between offset form (codeGen) and list form (CmmInfo).
 178 Thus a bit of explanation is in order.
 179 Fortunately, this code should go away once the code generator
 180 starts using the CPS conversion pass to handle the stack.
 181
 182 The stack looks like this:
 183
 184              |             |
 185              |-------------|
 186 frame_sp --> | return addr |
 187              |-------------|
 188              | dead slot   |
 189              |-------------|
 190              | live ptr b  |
 191              |-------------|
 192              | live ptr a  |
 193              |-------------|
 194 real_sp  --> | return addr |
 195              +-------------+
 196
 197 Both 'frame_sp' and 'real_sp' are measured downwards
 198 (i.e. larger frame_sp means smaller memory address).
 199
 200 For that frame we want a result like: [Just a, Just b, Nothing]
 201 Note that the 'head' of the list is the top
 202 of the stack, and that the return address
 203 is not present in the list (it is always assumed).
 204 -}
 205 mkStackLayout :: FCode [Maybe LocalReg]
 206 mkStackLayout = do
 207   StackUsage { realSp = real_sp,
 208                frameSp = frame_sp } <- getStkUsage
 209   binds <- getLiveStackBindings
 210   let frame_size = real_sp - frame_sp - retAddrSizeW
 211       rel_binds = reverse $ sortWith fst
 212                     [(offset - frame_sp - retAddrSizeW, b)
 213                     | (offset, b) <- binds]
 214
 215   WARN( not (all (\bind -> fst bind >= 0) rel_binds),
 216         ppr binds $$ ppr rel_binds $$
 217         ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
 218     return $ stack_layout rel_binds frame_size
 219
 220 stack_layout :: [(VirtualSpOffset, CgIdInfo)]
 221              -> WordOff
 222              -> [Maybe LocalReg]
 223 stack_layout [] sizeW = replicate sizeW Nothing
 224 stack_layout ((off, bind):binds) sizeW | off == sizeW - 1 =
 225   (Just stack_bind) : (stack_layout binds (sizeW - rep_size))
 226   where
 227     rep_size = cgRepSizeW (cgIdInfoArgRep bind)
 228     stack_bind = LocalReg unique machRep
 229     unique = getUnique (cgIdInfoId bind)
 230     machRep = argMachRep (cgIdInfoArgRep bind)
 231 stack_layout binds@(_:_) sizeW | otherwise =
 232   Nothing : (stack_layout binds (sizeW - 1))
 233
 234 {- Another way to write the function that might be less error prone (untested)
 235 stack_layout offsets sizeW = result
 236   where
 237     y = map (flip lookup offsets) [0..]
 238       -- offsets -> nothing and just (each slot is one word)
 239     x = take sizeW y -- set the frame size
 240     z = clip x -- account for multi-word slots
 241     result = map mk_reg z
 242
 243     clip [] = []
 244     clip list@(x : _) = x : clip (drop count list)
 245       ASSERT(all isNothing (tail (take count list)))
 246
 247     count Nothing = 1
 248     count (Just x) = cgRepSizeW (cgIdInfoArgRep x)
 249
 250     mk_reg Nothing = Nothing
 251     mk_reg (Just x) = LocalReg unique machRep kind
 252       where
 253         unique = getUnique (cgIdInfoId x)
 254         machRep = argMachrep (cgIdInfoArgRep bind)
 255         kind = if isFollowableArg (cgIdInfoArgRep bind)
 256            then GCKindPtr
 257            else GCKindNonPtr
 258 -}
 259
 260 emitAlgReturnTarget
 261         :: Name                         -- Just for its unique
 262         -> [(ConTagZ, CgStmts)]         -- Tagged branches
 263         -> Maybe CgStmts                -- Default branch (if any)
 264         -> Int                          -- family size
 265         -> FCode (CLabel, SemiTaggingStuff)
 266
 267 emitAlgReturnTarget name branches mb_deflt fam_sz
 268   = do  { blks <- getCgStmts $
 269                     -- is the constructor tag in the node reg?
 270                     if isSmallFamily fam_sz
 271                         then do -- yes, node has constr. tag
 272                           let tag_expr = cmmConstrTag1 (CmmReg nodeReg)
 273                               branches' = [(tag+1,branch)|(tag,branch)<-branches]
 274                           emitSwitch tag_expr branches' mb_deflt 1 fam_sz
 275                         else do -- no, get tag from info table
 276                           let -- Note that ptr _always_ has tag 1
 277                               -- when the family size is big enough
 278                               untagged_ptr = cmmRegOffB nodeReg (-1)
 279                               tag_expr = getConstrTag (untagged_ptr)
 280                           emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
 281         ; lbl <- emitReturnTarget name blks
 282         ; return (lbl, Nothing) }
 283                 -- Nothing: the internal branches in the switch don't have
 284                 -- global labels, so we can't use them at the 'call site'
 285
 286 --------------------------------
 287 emitReturnInstr :: Code
 288 emitReturnInstr
 289   = do  { info_amode <- getSequelAmode
 290         ; stmtC (CmmJump (entryCode info_amode) []) }
 291
 292 -----------------------------------------------------------------------------
 293 --
 294 --      Info table offsets
 295 --
 296 -----------------------------------------------------------------------------
 297
 298 stdInfoTableSizeW :: WordOff
 299 -- The size of a standard info table varies with profiling/ticky etc,
 300 -- so we can't get it from Constants
 301 -- It must vary in sync with mkStdInfoTable
 302 stdInfoTableSizeW
 303   = size_fixed + size_prof
 304   where
 305     size_fixed = 2      -- layout, type
 306     size_prof | opt_SccProfilingOn = 2
 307               | otherwise          = 0
 308
 309 stdInfoTableSizeB :: ByteOff
 310 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
 311
 312 stdSrtBitmapOffset :: ByteOff
 313 -- Byte offset of the SRT bitmap half-word which is
 314 -- in the *higher-addressed* part of the type_lit
 315 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
 316
 317 stdClosureTypeOffset :: ByteOff
 318 -- Byte offset of the closure type half-word
 319 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
 320
 321 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
 322 stdPtrsOffset    = stdInfoTableSizeB - 2*wORD_SIZE
 323 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
 324
 325 -------------------------------------------------------------------------
 326 --
 327 --      Accessing fields of an info table
 328 --
 329 -------------------------------------------------------------------------
 330
 331 closureInfoPtr :: CmmExpr -> CmmExpr
 332 -- Takes a closure pointer and returns the info table pointer
 333 closureInfoPtr e = CmmLoad e bWord
 334
 335 entryCode :: CmmExpr -> CmmExpr
 336 -- Takes an info pointer (the first word of a closure)
 337 -- and returns its entry code
 338 entryCode e | tablesNextToCode = e
 339             | otherwise        = CmmLoad e bWord
 340
 341 getConstrTag :: CmmExpr -> CmmExpr
 342 -- Takes a closure pointer, and return the *zero-indexed*
 343 -- constructor tag obtained from the info table
 344 -- This lives in the SRT field of the info table
 345 -- (constructors don't need SRTs).
 346 getConstrTag closure_ptr
 347   = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
 348   where
 349     info_table = infoTable (closureInfoPtr closure_ptr)
 350
 351 cmmGetClosureType :: CmmExpr -> CmmExpr
 352 -- Takes a closure pointer, and return the closure type
 353 -- obtained from the info table
 354 cmmGetClosureType closure_ptr
 355   = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
 356   where
 357     info_table = infoTable (closureInfoPtr closure_ptr)
 358
 359 infoTable :: CmmExpr -> CmmExpr
 360 -- Takes an info pointer (the first word of a closure)
 361 -- and returns a pointer to the first word of the standard-form
 362 -- info table, excluding the entry-code word (if present)
 363 infoTable info_ptr
 364   | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
 365   | otherwise        = cmmOffsetW info_ptr 1    -- Past the entry code pointer
 366
 367 infoTableConstrTag :: CmmExpr -> CmmExpr
 368 -- Takes an info table pointer (from infoTable) and returns the constr tag
 369 -- field of the info table (same as the srt_bitmap field)
 370 infoTableConstrTag = infoTableSrtBitmap
 371
 372 infoTableSrtBitmap :: CmmExpr -> CmmExpr
 373 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
 374 -- field of the info table
 375 infoTableSrtBitmap info_tbl
 376   = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
 377
 378 infoTableClosureType :: CmmExpr -> CmmExpr
 379 -- Takes an info table pointer (from infoTable) and returns the closure type
 380 -- field of the info table.
 381 infoTableClosureType info_tbl
 382   = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
 383
 384 infoTablePtrs :: CmmExpr -> CmmExpr
 385 infoTablePtrs info_tbl
 386   = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
 387
 388 infoTableNonPtrs :: CmmExpr -> CmmExpr
 389 infoTableNonPtrs info_tbl
 390   = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
 391
 392 funInfoTable :: CmmExpr -> CmmExpr
 393 -- Takes the info pointer of a function,
 394 -- and returns a pointer to the first word of the StgFunInfoExtra struct
 395 -- in the info table.
 396 funInfoTable info_ptr
 397   | tablesNextToCode
 398   = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
 399   | otherwise
 400   = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
 401                                 -- Past the entry code pointer
 402
 403 -------------------------------------------------------------------------
 404 --
 405 --      Emit the code for a closure (or return address)
 406 --      and its associated info table
 407 --
 408 -------------------------------------------------------------------------
 409
 410 -- The complication here concerns whether or not we can
 411 -- put the info table next to the code
 412
 413 emitInfoTableAndCode
 414         :: CLabel               -- Label of entry or ret
 415         -> CmmInfo              -- ...the info table
 416         -> CmmFormals   -- ...args
 417         -> [CmmBasicBlock]      -- ...and body
 418         -> Code
 419
 420 emitInfoTableAndCode entry_ret_lbl info args blocks
 421   = emitProc info entry_ret_lbl args blocks
 422
 423 -------------------------------------------------------------------------
 424 --
 425 --      Position independent code
 426 --
 427 -------------------------------------------------------------------------
 428 -- In order to support position independent code, we mustn't put absolute
 429 -- references into read-only space. Info tables in the tablesNextToCode
 430 -- case must be in .text, which is read-only, so we doctor the CmmLits
 431 -- to use relative offsets instead.
 432
 433 -- Note that this is done even when the -fPIC flag is not specified,
 434 -- as we want to keep binary compatibility between PIC and non-PIC.
 435
 436 makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
 437
 438 makeRelativeRefTo info_lbl (CmmLabel lbl)
 439   | tablesNextToCode
 440   = CmmLabelDiffOff lbl info_lbl 0
 441 makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
 442   | tablesNextToCode
 443   = CmmLabelDiffOff lbl info_lbl off
 444 makeRelativeRefTo _ lit = lit