never executed always true always false
    1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE CPP #-}
    3 
    4 -----------------------------------------------------------------------------
    5 --
    6 -- Building info tables.
    7 --
    8 -- (c) The University of Glasgow 2004-2006
    9 --
   10 -----------------------------------------------------------------------------
   11 
   12 module GHC.StgToCmm.Layout (
   13         mkArgDescr,
   14         emitCall, emitReturn, adjustHpBackwards,
   15 
   16         emitClosureProcAndInfoTable,
   17         emitClosureAndInfoTable,
   18 
   19         slowCall, directCall,
   20 
   21         FieldOffOrPadding(..),
   22         ClosureHeader(..),
   23         mkVirtHeapOffsets,
   24         mkVirtHeapOffsetsWithPadding,
   25         mkVirtConstrOffsets,
   26         mkVirtConstrSizes,
   27         getHpRelOffset,
   28 
   29         ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
   30         getArgAmode, getNonVoidArgAmodes
   31   ) where
   32 
   33 
   34 import GHC.Prelude hiding ((<*>))
   35 
   36 import GHC.Driver.Session
   37 import GHC.Driver.Ppr
   38 
   39 import GHC.StgToCmm.Closure
   40 import GHC.StgToCmm.Env
   41 import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )
   42 import GHC.StgToCmm.Ticky
   43 import GHC.StgToCmm.Monad
   44 import GHC.StgToCmm.Lit
   45 import GHC.StgToCmm.Utils
   46 
   47 import GHC.Cmm.Graph
   48 import GHC.Runtime.Heap.Layout
   49 import GHC.Cmm.BlockId
   50 import GHC.Cmm
   51 import GHC.Cmm.Utils
   52 import GHC.Cmm.Info
   53 import GHC.Cmm.CLabel
   54 import GHC.Stg.Syntax
   55 import GHC.Types.Id
   56 import GHC.Core.TyCon    ( PrimRep(..), primRepSizeB )
   57 import GHC.Types.Basic   ( RepArity )
   58 import GHC.Platform
   59 import GHC.Platform.Profile
   60 import GHC.Unit
   61 
   62 import GHC.Utils.Misc
   63 import Data.List (mapAccumL, partition)
   64 import GHC.Utils.Outputable
   65 import GHC.Utils.Panic
   66 import GHC.Utils.Panic.Plain
   67 import GHC.Utils.Constants (debugIsOn)
   68 import GHC.Data.FastString
   69 import Control.Monad
   70 
   71 ------------------------------------------------------------------------
   72 --                Call and return sequences
   73 ------------------------------------------------------------------------
   74 
   75 -- | Return multiple values to the sequel
   76 --
   77 -- If the sequel is @Return@
   78 --
   79 -- >     return (x,y)
   80 --
   81 -- If the sequel is @AssignTo [p,q]@
   82 --
   83 -- >    p=x; q=y;
   84 --
   85 emitReturn :: [CmmExpr] -> FCode ReturnKind
   86 emitReturn results
   87   = do { profile   <- getProfile
   88        ; platform  <- getPlatform
   89        ; sequel    <- getSequel
   90        ; updfr_off <- getUpdFrameOff
   91        ; case sequel of
   92            Return ->
   93              do { adjustHpBackwards
   94                 ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)
   95                 ; emit (mkReturn profile (entryCode platform e) results updfr_off)
   96                 }
   97            AssignTo regs adjust ->
   98              do { when adjust adjustHpBackwards
   99                 ; emitMultiAssign  regs results }
  100        ; return AssignedDirectly
  101        }
  102 
  103 
  104 -- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
  105 -- using the call/return convention @conv@, passing @args@, and
  106 -- returning the results to the current sequel.
  107 --
  108 emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
  109 emitCall convs fun args
  110   = emitCallWithExtraStack convs fun args noExtraStack
  111 
  112 
  113 -- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
  114 -- entry-code of @fun@, using the call/return convention @conv@,
  115 -- passing @args@, pushing some extra stack frames described by
  116 -- @stack@, and returning the results to the current sequel.
  117 --
  118 emitCallWithExtraStack
  119    :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
  120    -> [CmmExpr] -> FCode ReturnKind
  121 emitCallWithExtraStack (callConv, retConv) fun args extra_stack
  122   = do  { profile <- getProfile
  123         ; adjustHpBackwards
  124         ; sequel <- getSequel
  125         ; updfr_off <- getUpdFrameOff
  126         ; case sequel of
  127             Return -> do
  128               emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack
  129               return AssignedDirectly
  130             AssignTo res_regs _ -> do
  131               k <- newBlockId
  132               let area = Young k
  133                   (off, _, copyin) = copyInOflow profile retConv area res_regs []
  134                   copyout = mkCallReturnsTo profile fun callConv args k off updfr_off
  135                                    extra_stack
  136               tscope <- getTickScope
  137               emit (copyout <*> mkLabel k tscope <*> copyin)
  138               return (ReturnedTo k off)
  139       }
  140 
  141 
  142 adjustHpBackwards :: FCode ()
  143 -- This function adjusts the heap pointer just before a tail call or
  144 -- return.  At a call or return, the virtual heap pointer may be less
  145 -- than the real Hp, because the latter was advanced to deal with
  146 -- the worst-case branch of the code, and we may be in a better-case
  147 -- branch.  In that case, move the real Hp *back* and retract some
  148 -- ticky allocation count.
  149 --
  150 -- It *does not* deal with high-water-mark adjustment.  That's done by
  151 -- functions which allocate heap.
  152 adjustHpBackwards
  153   = do  { hp_usg <- getHpUsage
  154         ; let rHp = realHp hp_usg
  155               vHp = virtHp hp_usg
  156               adjust_words = vHp -rHp
  157         ; new_hp <- getHpRelOffset vHp
  158 
  159         ; emit (if adjust_words == 0
  160                 then mkNop
  161                 else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
  162 
  163         ; tickyAllocHeap False adjust_words -- ...ditto
  164 
  165         ; setRealHp vHp
  166         }
  167 
  168 
  169 -------------------------------------------------------------------------
  170 --        Making calls: directCall and slowCall
  171 -------------------------------------------------------------------------
  172 
  173 -- General plan is:
  174 --   - we'll make *one* fast call, either to the function itself
  175 --     (directCall) or to stg_ap_<pat>_fast (slowCall)
  176 --     Any left-over arguments will be pushed on the stack,
  177 --
  178 --     e.g. Sp[old+8]  = arg1
  179 --          Sp[old+16] = arg2
  180 --          Sp[old+32] = stg_ap_pp_info
  181 --          R2 = arg3
  182 --          R3 = arg4
  183 --          call f() return to Nothing updfr_off: 32
  184 
  185 
  186 directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
  187 -- (directCall f n args)
  188 -- calls f(arg1, ..., argn), and applies the result to the remaining args
  189 -- The function f has arity n, and there are guaranteed at least n args
  190 -- Both arity and args include void args
  191 directCall conv lbl arity stg_args
  192   = do  { argreps <- getArgRepsAmodes stg_args
  193         ; direct_call "directCall" conv lbl arity argreps }
  194 
  195 
  196 slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
  197 -- (slowCall fun args) applies fun to args, returning the results to Sequel
  198 slowCall fun stg_args
  199   = do  dflags <- getDynFlags
  200         profile <- getProfile
  201         let platform = profilePlatform profile
  202         argsreps <- getArgRepsAmodes stg_args
  203         let (rts_fun, arity) = slowCallPattern (map fst argsreps)
  204 
  205         (r, slow_code) <- getCodeR $ do
  206            r <- direct_call "slow_call" NativeNodeCall
  207                  (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
  208            emitComment $ mkFastString ("slow_call for " ++
  209                                       showSDoc dflags (pdoc platform fun) ++
  210                                       " with pat " ++ unpackFS rts_fun)
  211            return r
  212 
  213         -- Note [avoid intermediate PAPs]
  214         let n_args = length stg_args
  215         if n_args > arity && optLevel dflags >= 2
  216            then do
  217              ptr_opts <- getPtrOpts
  218              funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
  219              fun_iptr <- (CmmReg . CmmLocal) `fmap`
  220                     assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv))
  221 
  222              -- ToDo: we could do slightly better here by reusing the
  223              -- continuation from the slow call, which we have in r.
  224              -- Also we'd like to push the continuation on the stack
  225              -- before the branch, so that we only get one copy of the
  226              -- code that saves all the live variables across the
  227              -- call, but that might need some improvements to the
  228              -- special case in the stack layout code to handle this
  229              -- (see Note [diamond proc point]).
  230 
  231              fast_code <- getCode $
  232                 emitCall (NativeNodeCall, NativeReturn)
  233                   (entryCode platform fun_iptr)
  234                   (nonVArgs ((P,Just funv):argsreps))
  235 
  236              slow_lbl <- newBlockId
  237              fast_lbl <- newBlockId
  238              is_tagged_lbl <- newBlockId
  239              end_lbl <- newBlockId
  240 
  241              let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr)
  242                                                     (mkIntExpr platform n_args)
  243 
  244              tscope <- getTickScope
  245              emit (mkCbranch (cmmIsTagged platform funv)
  246                              is_tagged_lbl slow_lbl (Just True)
  247                    <*> mkLabel is_tagged_lbl tscope
  248                    <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
  249                    <*> mkLabel fast_lbl tscope
  250                    <*> fast_code
  251                    <*> mkBranch end_lbl
  252                    <*> mkLabel slow_lbl tscope
  253                    <*> slow_code
  254                    <*> mkLabel end_lbl tscope)
  255              return r
  256 
  257            else do
  258              emit slow_code
  259              return r
  260 
  261 
  262 -- Note [avoid intermediate PAPs]
  263 --
  264 -- A slow call which needs multiple generic apply patterns will be
  265 -- almost guaranteed to create one or more intermediate PAPs when
  266 -- applied to a function that takes the correct number of arguments.
  267 -- We try to avoid this situation by generating code to test whether
  268 -- we are calling a function with the correct number of arguments
  269 -- first, i.e.:
  270 --
  271 --   if (TAG(f) != 0} {  // f is not a thunk
  272 --      if (f->info.arity == n) {
  273 --         ... make a fast call to f ...
  274 --      }
  275 --   }
  276 --   ... otherwise make the slow call ...
  277 --
  278 -- We *only* do this when the call requires multiple generic apply
  279 -- functions, which requires pushing extra stack frames and probably
  280 -- results in intermediate PAPs.  (I say probably, because it might be
  281 -- that we're over-applying a function, but that seems even less
  282 -- likely).
  283 --
  284 -- This very rarely applies, but if it does happen in an inner loop it
  285 -- can have a severe impact on performance (#6084).
  286 
  287 
  288 --------------
  289 direct_call :: String
  290             -> Convention     -- e.g. NativeNodeCall or NativeDirectCall
  291             -> CLabel -> RepArity
  292             -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
  293 direct_call caller call_conv lbl arity args
  294   | debugIsOn && args `lengthLessThan` real_arity  -- Too few args
  295   = do -- Caller should ensure that there enough args!
  296        platform <- getPlatform
  297        pprPanic "direct_call" $
  298             text caller <+> ppr arity <+>
  299             pdoc platform lbl <+> ppr (length args) <+>
  300             pdoc platform (map snd args) <+> ppr (map fst args)
  301 
  302   | null rest_args  -- Precisely the right number of arguments
  303   = emitCall (call_conv, NativeReturn) target (nonVArgs args)
  304 
  305   | otherwise       -- Note [over-saturated calls]
  306   = do dflags <- getDynFlags
  307        emitCallWithExtraStack (call_conv, NativeReturn)
  308                               target
  309                               (nonVArgs fast_args)
  310                               (nonVArgs (stack_args dflags))
  311   where
  312     target = CmmLit (CmmLabel lbl)
  313     (fast_args, rest_args) = splitAt real_arity args
  314     stack_args dflags = slowArgs dflags rest_args
  315     real_arity = case call_conv of
  316                    NativeNodeCall -> arity+1
  317                    _              -> arity
  318 
  319 
  320 -- When constructing calls, it is easier to keep the ArgReps and the
  321 -- CmmExprs zipped together.  However, a void argument has no
  322 -- representation, so we need to use Maybe CmmExpr (the alternative of
  323 -- using zeroCLit or even undefined would work, but would be ugly).
  324 --
  325 getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
  326 getArgRepsAmodes args = do
  327    platform <- profilePlatform <$> getProfile
  328    mapM (getArgRepAmode platform) args
  329   where getArgRepAmode platform arg
  330            | V <- rep  = return (V, Nothing)
  331            | otherwise = do expr <- getArgAmode (NonVoid arg)
  332                             return (rep, Just expr)
  333            where rep = toArgRep platform (argPrimRep arg)
  334 
  335 nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
  336 nonVArgs [] = []
  337 nonVArgs ((_,Nothing)  : args) = nonVArgs args
  338 nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
  339 
  340 {-
  341 Note [over-saturated calls]
  342 
  343 The natural thing to do for an over-saturated call would be to call
  344 the function with the correct number of arguments, and then apply the
  345 remaining arguments to the value returned, e.g.
  346 
  347   f a b c d   (where f has arity 2)
  348   -->
  349   r = call f(a,b)
  350   call r(c,d)
  351 
  352 but this entails
  353   - saving c and d on the stack
  354   - making a continuation info table
  355   - at the continuation, loading c and d off the stack into regs
  356   - finally, call r
  357 
  358 Note that since there are a fixed number of different r's
  359 (e.g.  stg_ap_pp_fast), we can also pre-compile continuations
  360 that correspond to each of them, rather than generating a fresh
  361 one for each over-saturated call.
  362 
  363 Not only does this generate much less code, it is faster too.  We will
  364 generate something like:
  365 
  366 Sp[old+16] = c
  367 Sp[old+24] = d
  368 Sp[old+32] = stg_ap_pp_info
  369 call f(a,b) -- usual calling convention
  370 
  371 For the purposes of the CmmCall node, we count this extra stack as
  372 just more arguments that we are passing on the stack (cml_args).
  373 -}
  374 
  375 -- | 'slowArgs' takes a list of function arguments and prepares them for
  376 -- pushing on the stack for "extra" arguments to a function which requires
  377 -- fewer arguments than we currently have.
  378 slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
  379 slowArgs _ [] = []
  380 slowArgs dflags args -- careful: reps contains voids (V), but args does not
  381   | sccProfilingEnabled dflags
  382               = save_cccs ++ this_pat ++ slowArgs dflags rest_args
  383   | otherwise =              this_pat ++ slowArgs dflags rest_args
  384   where
  385     (arg_pat, n)            = slowCallPattern (map fst args)
  386     (call_args, rest_args)  = splitAt n args
  387 
  388     stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
  389     this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
  390     save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
  391     save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
  392 
  393 -------------------------------------------------------------------------
  394 ----        Laying out objects on the heap and stack
  395 -------------------------------------------------------------------------
  396 
  397 -- The heap always grows upwards, so hpRel is easy to compute
  398 hpRel :: VirtualHpOffset         -- virtual offset of Hp
  399       -> VirtualHpOffset         -- virtual offset of The Thing
  400       -> WordOff                -- integer word offset
  401 hpRel hp off = off - hp
  402 
  403 getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
  404 -- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad
  405 getHpRelOffset virtual_offset
  406   = do platform <- getPlatform
  407        hp_usg <- getHpUsage
  408        return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset))
  409 
  410 data FieldOffOrPadding a
  411     = FieldOff (NonVoid a) -- Something that needs an offset.
  412                ByteOff     -- Offset in bytes.
  413     | Padding ByteOff  -- Length of padding in bytes.
  414               ByteOff  -- Offset in bytes.
  415 
  416 -- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
  417 -- of header the object has.  This will be accounted for in the
  418 -- offsets of the fields returned.
  419 data ClosureHeader
  420   = NoHeader
  421   | StdHeader
  422   | ThunkHeader
  423 
  424 mkVirtHeapOffsetsWithPadding
  425   :: Profile
  426   -> ClosureHeader            -- What kind of header to account for
  427   -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
  428   -> ( WordOff                -- Total number of words allocated
  429      , WordOff                -- Number of words allocated for *pointers*
  430      , [FieldOffOrPadding a]  -- Either an offset or padding.
  431      )
  432 
  433 -- Things with their offsets from start of object in order of
  434 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
  435 -- First in list gets lowest offset, which is initial offset + 1.
  436 --
  437 -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
  438 -- than the unboxed things
  439 
  440 mkVirtHeapOffsetsWithPadding profile header things =
  441     assert (not (any (isVoidRep . fst . fromNonVoid) things))
  442     ( tot_wds
  443     , bytesToWordsRoundUp platform bytes_of_ptrs
  444     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
  445     )
  446   where
  447     platform = profilePlatform profile
  448     hdr_words = case header of
  449       NoHeader -> 0
  450       StdHeader -> fixedHdrSizeW profile
  451       ThunkHeader -> thunkHdrSize profile
  452     hdr_bytes = wordsToBytes platform hdr_words
  453 
  454     (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
  455 
  456     (bytes_of_ptrs, ptrs_w_offsets) =
  457        mapAccumL computeOffset 0 ptrs
  458     (tot_bytes, non_ptrs_w_offsets) =
  459        mapAccumL computeOffset bytes_of_ptrs non_ptrs
  460 
  461     tot_wds = bytesToWordsRoundUp platform tot_bytes
  462 
  463     final_pad_size = tot_wds * word_size - tot_bytes
  464     final_pad
  465         | final_pad_size > 0 = [(Padding final_pad_size
  466                                          (hdr_bytes + tot_bytes))]
  467         | otherwise          = []
  468 
  469     word_size = platformWordSizeInBytes platform
  470 
  471     computeOffset bytes_so_far nv_thing =
  472         (new_bytes_so_far, with_padding field_off)
  473       where
  474         (rep, thing) = fromNonVoid nv_thing
  475 
  476         -- Size of the field in bytes.
  477         !sizeB = primRepSizeB platform rep
  478 
  479         -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
  480         -- But not more than to a word.
  481         !align = min word_size sizeB
  482         !start = roundUpTo bytes_so_far align
  483         !padding = start - bytes_so_far
  484 
  485         -- Final offset is:
  486         --   size of header + bytes_so_far + padding
  487         !final_offset = hdr_bytes + bytes_so_far + padding
  488         !new_bytes_so_far = start + sizeB
  489         field_off = FieldOff (NonVoid thing) final_offset
  490 
  491         with_padding field_off
  492             | padding == 0 = [field_off]
  493             | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)
  494                              , field_off
  495                              ]
  496 
  497 
  498 mkVirtHeapOffsets
  499   :: Profile
  500   -> ClosureHeader            -- What kind of header to account for
  501   -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
  502   -> (WordOff,                -- _Total_ number of words allocated
  503       WordOff,                -- Number of words allocated for *pointers*
  504       [(NonVoid a, ByteOff)])
  505 mkVirtHeapOffsets profile header things =
  506     ( tot_wds
  507     , ptr_wds
  508     , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
  509     )
  510   where
  511    (tot_wds, ptr_wds, things_offsets) =
  512        mkVirtHeapOffsetsWithPadding profile header things
  513 
  514 -- | Just like mkVirtHeapOffsets, but for constructors
  515 mkVirtConstrOffsets
  516   :: Profile -> [NonVoid (PrimRep, a)]
  517   -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
  518 mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader
  519 
  520 -- | Just like mkVirtConstrOffsets, but used when we don't have the actual
  521 -- arguments. Useful when e.g. generating info tables; we just need to know
  522 -- sizes of pointer and non-pointer fields.
  523 mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
  524 mkVirtConstrSizes profile field_reps
  525   = (tot_wds, ptr_wds)
  526   where
  527     (tot_wds, ptr_wds, _) =
  528        mkVirtConstrOffsets profile
  529          (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)
  530 
  531 -------------------------------------------------------------------------
  532 --
  533 --        Making argument descriptors
  534 --
  535 --  An argument descriptor describes the layout of args on the stack,
  536 --  both for         * GC (stack-layout) purposes, and
  537 --                * saving/restoring registers when a heap-check fails
  538 --
  539 -- Void arguments aren't important, therefore (contrast constructSlowCall)
  540 --
  541 -------------------------------------------------------------------------
  542 
  543 -- bring in ARG_P, ARG_N, etc.
  544 #include "FunTypes.h"
  545 
  546 mkArgDescr :: Platform -> [Id] -> ArgDescr
  547 mkArgDescr platform args
  548   = let arg_bits = argBits platform arg_reps
  549         arg_reps = filter isNonV (map (idArgRep platform) args)
  550            -- Getting rid of voids eases matching of standard patterns
  551     in case stdPattern arg_reps of
  552          Just spec_id -> ArgSpec spec_id
  553          Nothing      -> ArgGen  arg_bits
  554 
  555 argBits :: Platform -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
  556 argBits _         []           = []
  557 argBits platform (P   : args) = False : argBits platform args
  558 argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True)
  559                                  ++ argBits platform args
  560 
  561 ----------------------
  562 stdPattern :: [ArgRep] -> Maybe Int
  563 stdPattern reps
  564   = case reps of
  565         []    -> Just ARG_NONE        -- just void args, probably
  566         [N]   -> Just ARG_N
  567         [P]   -> Just ARG_P
  568         [F]   -> Just ARG_F
  569         [D]   -> Just ARG_D
  570         [L]   -> Just ARG_L
  571         [V16] -> Just ARG_V16
  572         [V32] -> Just ARG_V32
  573         [V64] -> Just ARG_V64
  574 
  575         [N,N] -> Just ARG_NN
  576         [N,P] -> Just ARG_NP
  577         [P,N] -> Just ARG_PN
  578         [P,P] -> Just ARG_PP
  579 
  580         [N,N,N] -> Just ARG_NNN
  581         [N,N,P] -> Just ARG_NNP
  582         [N,P,N] -> Just ARG_NPN
  583         [N,P,P] -> Just ARG_NPP
  584         [P,N,N] -> Just ARG_PNN
  585         [P,N,P] -> Just ARG_PNP
  586         [P,P,N] -> Just ARG_PPN
  587         [P,P,P] -> Just ARG_PPP
  588 
  589         [P,P,P,P]     -> Just ARG_PPPP
  590         [P,P,P,P,P]   -> Just ARG_PPPPP
  591         [P,P,P,P,P,P] -> Just ARG_PPPPPP
  592 
  593         _ -> Nothing
  594 
  595 -------------------------------------------------------------------------
  596 --        Amodes for arguments
  597 -------------------------------------------------------------------------
  598 
  599 getArgAmode :: NonVoid StgArg -> FCode CmmExpr
  600 getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
  601 getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
  602 
  603 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
  604 -- NB: Filters out void args,
  605 --     so the result list may be shorter than the argument list
  606 getNonVoidArgAmodes [] = return []
  607 getNonVoidArgAmodes (arg:args)
  608   | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
  609   | otherwise = do { amode  <- getArgAmode (NonVoid arg)
  610                    ; amodes <- getNonVoidArgAmodes args
  611                    ; return ( amode : amodes ) }
  612 
  613 -------------------------------------------------------------------------
  614 --
  615 --        Generating the info table and code for a closure
  616 --
  617 -------------------------------------------------------------------------
  618 
  619 -- Here we make an info table of type 'CmmInfo'.  The concrete
  620 -- representation as a list of 'CmmAddr' is handled later
  621 -- in the pipeline by 'cmmToRawCmm'.
  622 -- When loading the free variables, a function closure pointer may be tagged,
  623 -- so we must take it into account.
  624 
  625 emitClosureProcAndInfoTable :: Bool                    -- top-level?
  626                             -> Id                      -- name of the closure
  627                             -> LambdaFormInfo
  628                             -> CmmInfoTable
  629                             -> [NonVoid Id]            -- incoming arguments
  630                             -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
  631                             -> FCode ()
  632 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
  633  = do   { profile <- getProfile
  634         ; platform <- getPlatform
  635         -- Bind the binder itself, but only if it's not a top-level
  636         -- binding. We need non-top let-bindings to refer to the
  637         -- top-level binding, which this binding would incorrectly shadow.
  638         ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)
  639                   else bindToReg (NonVoid bndr) lf_info
  640         ; let node_points = nodeMustPointToIt profile lf_info
  641         ; arg_regs <- bindArgsToRegs args
  642         ; let args' = if node_points then (node : arg_regs) else arg_regs
  643               conv  = if nodeMustPointToIt profile lf_info then NativeNodeCall
  644                                                           else NativeDirectCall
  645               (offset, _, _) = mkCallEntry profile conv args' []
  646         ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs)
  647         }
  648 
  649 -- Data constructors need closures, but not with all the argument handling
  650 -- needed for functions. The shared part goes here.
  651 emitClosureAndInfoTable
  652    :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
  653 emitClosureAndInfoTable platform info_tbl conv args body
  654   = do { (_, blks) <- getCodeScoped body
  655        ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)
  656        ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
  657        }