never executed always true always false
    1 
    2 
    3 -----------------------------------------------------------------------------
    4 --
    5 -- Stg to C-- code generation: the binding environment
    6 --
    7 -- (c) The University of Glasgow 2004-2006
    8 --
    9 -----------------------------------------------------------------------------
   10 module GHC.StgToCmm.Env (
   11         CgIdInfo,
   12 
   13         litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
   14         idInfoToAmode,
   15 
   16         addBindC, addBindsC,
   17 
   18         bindArgsToRegs, bindToReg, rebindToReg,
   19         bindArgToReg, idToReg,
   20         getCgIdInfo,
   21         maybeLetNoEscape,
   22     ) where
   23 
   24 import GHC.Prelude
   25 
   26 import GHC.Platform
   27 import GHC.StgToCmm.Monad
   28 import GHC.StgToCmm.Closure
   29 
   30 import GHC.Cmm.CLabel
   31 
   32 import GHC.Cmm.BlockId
   33 import GHC.Cmm.Expr
   34 import GHC.Cmm.Utils
   35 import GHC.Types.Id
   36 import GHC.Cmm.Graph
   37 import GHC.Types.Name
   38 import GHC.Core.Type
   39 import GHC.Builtin.Types.Prim
   40 import GHC.Types.Unique.FM
   41 import GHC.Types.Var.Env
   42 
   43 import GHC.Utils.Outputable
   44 import GHC.Utils.Panic
   45 import GHC.Utils.Panic.Plain
   46 
   47 import GHC.Driver.Session
   48 
   49 
   50 -------------------------------------
   51 --        Manipulating CgIdInfo
   52 -------------------------------------
   53 
   54 mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
   55 mkCgIdInfo id lf expr
   56   = CgIdInfo { cg_id = id, cg_lf = lf
   57              , cg_loc = CmmLoc expr }
   58 
   59 litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
   60 litIdInfo platform id lf lit
   61   = CgIdInfo { cg_id = id, cg_lf = lf
   62              , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }
   63   where
   64     tag = lfDynTag platform lf
   65 
   66 lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
   67 lneIdInfo platform id regs
   68   = CgIdInfo { cg_id = id, cg_lf = lf
   69              , cg_loc = LneLoc blk_id (map (idToReg platform) regs) }
   70   where
   71     lf     = mkLFLetNoEscape
   72     blk_id = mkBlockId (idUnique id)
   73 
   74 
   75 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
   76 rhsIdInfo id lf_info
   77   = do platform <- getPlatform
   78        reg <- newTemp (gcWord platform)
   79        return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
   80 
   81 mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
   82 mkRhsInit platform reg lf_info expr
   83   = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info))
   84 
   85 idInfoToAmode :: CgIdInfo -> CmmExpr
   86 -- Returns a CmmExpr for the *tagged* pointer
   87 idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
   88 idInfoToAmode cg_info
   89   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc
   90 
   91 -- | A tag adds a byte offset to the pointer
   92 addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
   93 addDynTag platform expr tag = cmmOffsetB platform expr tag
   94 
   95 maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
   96 maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
   97 maybeLetNoEscape _other                                      = Nothing
   98 
   99 
  100 
  101 ---------------------------------------------------------
  102 --        The binding environment
  103 --
  104 -- There are three basic routines, for adding (addBindC),
  105 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
  106 ---------------------------------------------------------
  107 
  108 addBindC :: CgIdInfo -> FCode ()
  109 addBindC stuff_to_bind = do
  110         binds <- getBinds
  111         setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
  112 
  113 addBindsC :: [CgIdInfo] -> FCode ()
  114 addBindsC new_bindings = do
  115         binds <- getBinds
  116         let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)
  117                                binds
  118                                new_bindings
  119         setBinds new_binds
  120 
  121 getCgIdInfo :: Id -> FCode CgIdInfo
  122 getCgIdInfo id
  123   = do  { platform <- targetPlatform <$> getDynFlags
  124         ; local_binds <- getBinds -- Try local bindings first
  125         ; case lookupVarEnv local_binds id of {
  126             Just info -> return info ;
  127             Nothing   -> do {
  128 
  129                 -- Should be imported; make up a CgIdInfo for it
  130           let name = idName id
  131         ; if isExternalName name then
  132               let ext_lbl
  133                       | isBoxedType (idType id)
  134                       = mkClosureLabel name $ idCafInfo id
  135                       | isUnliftedType (idType id)
  136                           -- An unlifted external Id must refer to a top-level
  137                           -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
  138                       = assert (idType id `eqType` addrPrimTy) $
  139                         mkBytesLabel name
  140                       | otherwise
  141                       = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
  142               in return $
  143                   litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)
  144           else
  145               cgLookupPanic id -- Bug
  146         }}}
  147 
  148 cgLookupPanic :: Id -> FCode a
  149 cgLookupPanic id
  150   = do  local_binds <- getBinds
  151         pprPanic "GHC.StgToCmm.Env: variable not found"
  152                 (vcat [ppr id,
  153                 text "local binds for:",
  154                 pprUFM local_binds $ \infos ->
  155                   vcat [ ppr (cg_id info) | info <- infos ]
  156               ])
  157 
  158 
  159 ------------------------------------------------------------------------
  160 --        Interface functions for binding and re-binding names
  161 ------------------------------------------------------------------------
  162 
  163 bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
  164 -- Bind an Id to a fresh LocalReg
  165 bindToReg nvid@(NonVoid id) lf_info
  166   = do platform <- getPlatform
  167        let reg = idToReg platform nvid
  168        addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
  169        return reg
  170 
  171 rebindToReg :: NonVoid Id -> FCode LocalReg
  172 -- Like bindToReg, but the Id is already in scope, so
  173 -- get its LF info from the envt
  174 rebindToReg nvid@(NonVoid id)
  175   = do  { info <- getCgIdInfo id
  176         ; bindToReg nvid (cg_lf info) }
  177 
  178 bindArgToReg :: NonVoid Id -> FCode LocalReg
  179 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
  180 
  181 bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
  182 bindArgsToRegs args = mapM bindArgToReg args
  183 
  184 idToReg :: Platform -> NonVoid Id -> LocalReg
  185 -- Make a register from an Id, typically a function argument,
  186 -- free variable, or case binder
  187 --
  188 -- We re-use the Unique from the Id to make it easier to see what is going on
  189 --
  190 -- By now the Ids should be uniquely named; else one would worry
  191 -- about accidental collision
  192 idToReg platform (NonVoid id)
  193              = LocalReg (idUnique id)
  194                         (primRepCmmType platform (idPrimRep id))