never executed always true always false
    1 
    2 
    3 -----------------------------------------------------------------------------
    4 --
    5 -- Stg to C--: code generation for constructors
    6 --
    7 -- This module provides the support code for StgToCmm to deal with
    8 -- constructors on the RHSs of let(rec)s.
    9 --
   10 -- (c) The University of Glasgow 2004-2006
   11 --
   12 -----------------------------------------------------------------------------
   13 
   14 module GHC.StgToCmm.DataCon (
   15         cgTopRhsCon, buildDynCon, bindConArgs
   16     ) where
   17 
   18 import GHC.Prelude
   19 
   20 import GHC.Platform
   21 import GHC.Platform.Profile
   22 
   23 import GHC.Stg.Syntax
   24 import GHC.Core  ( AltCon(..) )
   25 
   26 import GHC.StgToCmm.Monad
   27 import GHC.StgToCmm.Env
   28 import GHC.StgToCmm.Heap
   29 import GHC.StgToCmm.Layout
   30 import GHC.StgToCmm.Utils
   31 import GHC.StgToCmm.Closure
   32 
   33 import GHC.Cmm.Expr
   34 import GHC.Cmm.Utils
   35 import GHC.Cmm.CLabel
   36 import GHC.Cmm.Graph
   37 import GHC.Runtime.Heap.Layout
   38 import GHC.Types.CostCentre
   39 import GHC.Unit
   40 import GHC.Core.DataCon
   41 import GHC.Driver.Session
   42 import GHC.Data.FastString
   43 import GHC.Types.Id
   44 import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )
   45 import GHC.Types.Name (isInternalName)
   46 import GHC.Types.RepType (countConRepArgs)
   47 import GHC.Types.Literal
   48 import GHC.Builtin.Utils
   49 import GHC.Utils.Panic
   50 import GHC.Utils.Panic.Plain
   51 import GHC.Utils.Misc
   52 import GHC.Utils.Monad (mapMaybeM)
   53 
   54 import Control.Monad
   55 import Data.Char
   56 
   57 ---------------------------------------------------------------
   58 --      Top-level constructors
   59 ---------------------------------------------------------------
   60 
   61 cgTopRhsCon :: DynFlags
   62             -> Id               -- Name of thing bound to this RHS
   63             -> DataCon          -- Id
   64             -> ConstructorNumber
   65             -> [NonVoid StgArg] -- Args
   66             -> (CgIdInfo, FCode ())
   67 cgTopRhsCon dflags id con mn args
   68   | Just static_info <- precomputedStaticConInfo_maybe dflags id con args
   69   , let static_code | isInternalName name = pure ()
   70                     | otherwise           = gen_code
   71   = -- There is a pre-allocated static closure available; use it
   72     -- See Note [Precomputed static closures].
   73     -- For External bindings we must keep the binding,
   74     -- since importing modules will refer to it by name;
   75     -- but for Internal ones we can drop it altogether
   76     -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External
   77     (static_info, static_code)
   78 
   79   -- Otherwise generate a closure for the constructor.
   80   | otherwise
   81   = (id_Info, gen_code)
   82 
   83   where
   84    platform      = targetPlatform dflags
   85    id_Info       = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label)
   86    name          = idName id
   87    caffy         = idCafInfo id -- any stgArgHasCafRefs args
   88    closure_label = mkClosureLabel name caffy
   89 
   90    gen_code =
   91      do { profile <- getProfile
   92         ; this_mod <- getModuleName
   93         ; when (platformOS platform == OSMinGW32) $
   94               -- Windows DLLs have a problem with static cross-DLL refs.
   95               massert (not (isDllConApp dflags this_mod con (map fromNonVoid args)))
   96         ; assert (args `lengthIs` countConRepArgs con ) return ()
   97 
   98         -- LAY IT OUT
   99         ; let
  100             (tot_wds, --  #ptr_wds + #nonptr_wds
  101              ptr_wds, --  #ptr_wds
  102              nv_args_w_offsets) =
  103                  mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args)
  104 
  105         ; let
  106             -- Decompose padding into units of length 8, 4, 2, or 1 bytes to
  107             -- allow the implementation of mk_payload to use widthFromBytes,
  108             -- which only handles these cases.
  109             fix_padding (x@(Padding n off) : rest)
  110               | n == 0                 = fix_padding rest
  111               | n `elem` [1,2,4,8]     = x : fix_padding rest
  112               | n > 8                  = add_pad 8
  113               | n > 4                  = add_pad 4
  114               | n > 2                  = add_pad 2
  115               | otherwise              = add_pad 1
  116               where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest)
  117             fix_padding (x : rest)     = x : fix_padding rest
  118             fix_padding []             = []
  119 
  120             mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
  121             mk_payload (FieldOff arg _) = do
  122                 amode <- getArgAmode arg
  123                 case amode of
  124                   CmmLit lit -> return lit
  125                   _          -> panic "GHC.StgToCmm.DataCon.cgTopRhsCon"
  126 
  127             nonptr_wds = tot_wds - ptr_wds
  128 
  129              -- we're not really going to emit an info table, so having
  130              -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
  131              -- needs to poke around inside it.
  132             info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds
  133 
  134 
  135         ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
  136                 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
  137                 -- NB2: all the amodes should be Lits!
  138                 --      TODO (osa): Why?
  139 
  140                 -- BUILD THE OBJECT
  141                 --
  142             -- We're generating info tables, so we don't know and care about
  143             -- what the actual arguments are. Using () here as the place holder.
  144 
  145         ; emitDataCon closure_label info_tbl dontCareCCS payload }
  146 
  147 addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
  148 addModuleLoc this_mod mn = do
  149   case mn of
  150     NoNumber -> DefinitionSite
  151     Numbered n -> UsageSite this_mod n
  152 
  153 ---------------------------------------------------------------
  154 --      Lay out and allocate non-top-level constructors
  155 ---------------------------------------------------------------
  156 
  157 buildDynCon :: Id                 -- Name of the thing to which this constr will
  158                                   -- be bound
  159             -> ConstructorNumber
  160             -> Bool               -- is it genuinely bound to that name, or just
  161                                   -- for profiling?
  162             -> CostCentreStack    -- Where to grab cost centre from;
  163                                   -- current CCS if currentOrSubsumedCCS
  164             -> DataCon            -- The data constructor
  165             -> [NonVoid StgArg]   -- Its args
  166             -> FCode (CgIdInfo, FCode CmmAGraph)
  167                -- Return details about how to find it and initialization code
  168 buildDynCon binder mn actually_bound cc con args
  169     = do dflags <- getDynFlags
  170          buildDynCon' dflags binder mn actually_bound cc con args
  171 
  172 
  173 buildDynCon' :: DynFlags
  174              -> Id -> ConstructorNumber
  175              -> Bool
  176              -> CostCentreStack
  177              -> DataCon
  178              -> [NonVoid StgArg]
  179              -> FCode (CgIdInfo, FCode CmmAGraph)
  180 
  181 {- We used to pass a boolean indicating whether all the
  182 args were of size zero, so we could use a static
  183 constructor; but I concluded that it just isn't worth it.
  184 Now I/O uses unboxed tuples there just aren't any constructors
  185 with all size-zero args.
  186 
  187 The reason for having a separate argument, rather than looking at
  188 the addr modes of the args is that we may be in a "knot", and
  189 premature looking at the args will cause the compiler to black-hole!
  190 -}
  191 
  192 buildDynCon' dflags binder _ _ _cc con args
  193   | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args
  194   -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True
  195   = return (cgInfo, return mkNop)
  196 
  197 -------- buildDynCon': the general case -----------
  198 buildDynCon' _ binder mn actually_bound ccs con args
  199   = do  { (id_info, reg) <- rhsIdInfo binder lf_info
  200         ; return (id_info, gen_code reg)
  201         }
  202  where
  203   lf_info = mkConLFInfo con
  204 
  205   gen_code reg
  206     = do  { modu <- getModuleName
  207           ; profile <- getProfile
  208           ; let platform = profilePlatform profile
  209                 (tot_wds, ptr_wds, args_w_offsets)
  210                    = mkVirtConstrOffsets profile (addArgReps args)
  211                 nonptr_wds = tot_wds - ptr_wds
  212                 info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False
  213                                 ptr_wds nonptr_wds
  214           ; let ticky_name | actually_bound = Just binder
  215                            | otherwise = Nothing
  216 
  217           ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
  218                                           use_cc blame_cc args_w_offsets
  219           ; return (mkRhsInit platform reg lf_info hp_plus_n) }
  220     where
  221       use_cc      -- cost-centre to stick in the object
  222         | isCurrentCCS ccs = cccsExpr
  223         | otherwise        = panic "buildDynCon: non-current CCS not implemented"
  224 
  225       blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
  226 
  227 {- Note [Precomputed static closures]
  228    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  229 
  230 For Char/Int closures there are some value closures
  231 built into the RTS. This is the case for all values in
  232 the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE).
  233 See Note [CHARLIKE and INTLIKE closures.] in the RTS code.
  234 
  235 Similarly zero-arity constructors have a closure
  236 in their defining Module we can use.
  237 
  238 If possible we prefer to refer to those existing
  239 closure instead of building new ones.
  240 
  241 This is true at compile time where we do this replacement
  242 in this module.
  243 But also at runtime where the GC does the same (but only for
  244 INT/CHAR closures).
  245 
  246 `precomputedStaticConInfo_maybe` checks if a given constructor application
  247 can be replaced with a reference to a existing static closure.
  248 
  249 If so the code will reference the existing closure when accessing
  250 the binding.
  251 Unless the binding is visible to other modules we also generate
  252 no code for the binding itself. We can do this since then we can
  253 always reference the existing closure.
  254 
  255 See Note [About the NameSorts] for the definition of external names.
  256 For external bindings we must still generate a closure,
  257 but won't use it inside this module.
  258 This can sometimes reduce cache pressure. Since:
  259 * If somebody uses the exported binding:
  260   + This module will reference the existing closure.
  261   + GC will reference the existing closure.
  262   + The importing module will reference the built closure.
  263 * If nobody uses the exported binding:
  264   + This module will reference the RTS closures.
  265   + GC references the RTS closures
  266 
  267 In the later case we avoided loading the built closure into the cache which
  268 is what we optimize for here.
  269 
  270 Consider this example using Ints.
  271 
  272     module M(externalInt, foo, bar) where
  273 
  274     externalInt = 1 :: Int
  275     internalInt = 1 :: Int
  276     { -# NOINLINE foo #- }
  277     foo = Just internalInt :: Maybe Int
  278     bar = Just externalInt
  279 
  280     ==================== STG: ====================
  281     externalInt = I#! [1#];
  282 
  283     bar = Just! [externalInt];
  284 
  285     internalInt_rc = I#! [2#];
  286 
  287     foo = Just! [internalInt_rc];
  288 
  289 For externally visible bindings we must generate closures
  290 since those may be referenced by their symbol `<name>_closure`
  291 when imported.
  292 
  293 `externalInt` is visible to other modules so we generate a closure:
  294 
  295     [section ""data" . M.externalInt_closure" {
  296         M.externalInt_closure:
  297             const GHC.Types.I#_con_info;
  298             const 1;
  299     }]
  300 
  301 It will be referenced inside this module via `M.externalInt_closure+1`
  302 
  303 `internalInt` is however a internal name. As such we generate no code for
  304 it. References to it are replaced with references to the static closure as
  305 we can see in the closure built for `foo`:
  306 
  307     [section ""data" . M.foo_closure" {
  308         M.foo_closure:
  309             const GHC.Maybe.Just_con_info;
  310             const stg_INTLIKE_closure+289; // == I# 2
  311             const 3;
  312     }]
  313 
  314 This holds for both local and top level bindings.
  315 
  316 We don't support this optimization when compiling into Windows DLLs yet
  317 because they don't support cross package data references well.
  318 -}
  319 
  320 -- (precomputedStaticConInfo_maybe dflags id con args)
  321 --     returns (Just cg_id_info)
  322 -- if there is a precomputed static closure for (con args).
  323 -- In that case, cg_id_info addresses it.
  324 -- See Note [Precomputed static closures]
  325 precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
  326 precomputedStaticConInfo_maybe dflags binder con []
  327 -- Nullary constructors
  328   | isNullaryRepDataCon con
  329   = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con)
  330                 (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs))
  331 precomputedStaticConInfo_maybe dflags binder con [arg]
  332   -- Int/Char values with existing closures in the RTS
  333   | intClosure || charClosure
  334   , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
  335   , Just val <- getClosurePayload arg
  336   , inRange val
  337   = let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit label)
  338         val_int = fromIntegral val :: Int
  339         offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1)
  340                 -- INTLIKE/CHARLIKE closures consist of a header and one word payload
  341         static_amode = cmmLabelOffW platform intlike_lbl offsetW
  342     in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode
  343   where
  344     profile = targetProfile dflags
  345     platform = profilePlatform profile
  346     intClosure = maybeIntLikeCon con
  347     charClosure = maybeCharLikeCon con
  348     getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val
  349     getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val)
  350     getClosurePayload _ = Nothing
  351     -- Avoid over/underflow by comparisons at type Integer!
  352     inRange :: Integer -> Bool
  353     inRange val
  354       = val >= min_static_range && val <= max_static_range
  355 
  356     constants = platformConstants platform
  357 
  358     min_static_range :: Integer
  359     min_static_range
  360       | intClosure = fromIntegral (pc_MIN_INTLIKE constants)
  361       | charClosure = fromIntegral (pc_MIN_CHARLIKE constants)
  362       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
  363     max_static_range
  364       | intClosure = fromIntegral (pc_MAX_INTLIKE constants)
  365       | charClosure = fromIntegral (pc_MAX_CHARLIKE constants)
  366       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
  367     label
  368       | intClosure = "stg_INTLIKE"
  369       | charClosure =  "stg_CHARLIKE"
  370       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
  371 
  372 precomputedStaticConInfo_maybe _ _ _ _ = Nothing
  373 
  374 ---------------------------------------------------------------
  375 --      Binding constructor arguments
  376 ---------------------------------------------------------------
  377 
  378 bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
  379 -- bindConArgs is called from cgAlt of a case
  380 -- (bindConArgs con args) augments the environment with bindings for the
  381 -- binders args, assuming that we have just returned from a 'case' which
  382 -- found a con
  383 bindConArgs (DataAlt con) base args
  384   = assert (not (isUnboxedTupleDataCon con)) $
  385     do profile <- getProfile
  386        platform <- getPlatform
  387        let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
  388            tag = tagForCon platform con
  389 
  390            -- The binding below forces the masking out of the tag bits
  391            -- when accessing the constructor field.
  392            bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
  393            bind_arg (arg@(NonVoid b), offset)
  394              | isDeadBinder b  -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr
  395              = return Nothing
  396              | otherwise
  397              = do { emit $ mkTaggedObjectLoad platform (idToReg platform arg)
  398                                               base offset tag
  399                   ; Just <$> bindArgToReg arg }
  400 
  401        mapMaybeM bind_arg args_w_offsets
  402 
  403 bindConArgs _other_con _base args
  404   = assert (null args ) return []