{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
--
-- Stg to C-- code generation: the binding environment
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
module GHC.StgToCmm.Env (
        CgIdInfo,

        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
        idInfoToAmode,

        addBindC, addBindsC,

        bindArgsToRegs, bindToReg, rebindToReg,
        bindArgToReg, idToReg,
        getArgAmode, getNonVoidArgAmodes,
        getCgIdInfo,
        maybeLetNoEscape,
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Core.TyCon
import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure

import GHC.Cmm.CLabel

import GHC.Cmm.BlockId
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.Driver.Session
import GHC.Types.Id
import GHC.Cmm.Graph
import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Stg.Syntax
import GHC.Core.Type
import GHC.Builtin.Types.Prim
import GHC.Types.Unique.FM
import GHC.Utils.Misc
import GHC.Types.Var.Env

-------------------------------------
--        Manipulating CgIdInfo
-------------------------------------

mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo Id
id LambdaFormInfo
lf CmmExpr
expr
  = CgIdInfo :: Id -> LambdaFormInfo -> CgLoc -> CgIdInfo
CgIdInfo { cg_id :: Id
cg_id = Id
id, cg_lf :: LambdaFormInfo
cg_lf = LambdaFormInfo
lf
             , cg_loc :: CgLoc
cg_loc = CmmExpr -> CgLoc
CmmLoc CmmExpr
expr }

litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
id LambdaFormInfo
lf CmmLit
lit
  = CgIdInfo :: Id -> LambdaFormInfo -> CgLoc -> CgIdInfo
CgIdInfo { cg_id :: Id
cg_id = Id
id, cg_lf :: LambdaFormInfo
cg_lf = LambdaFormInfo
lf
             , cg_loc :: CgLoc
cg_loc = CmmExpr -> CgLoc
CmmLoc (Platform -> CmmExpr -> DynTag -> CmmExpr
addDynTag Platform
platform (CmmLit -> CmmExpr
CmmLit CmmLit
lit) DynTag
tag) }
  where
    tag :: DynTag
tag = DynFlags -> LambdaFormInfo -> DynTag
lfDynTag DynFlags
dflags LambdaFormInfo
lf
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
lneIdInfo Platform
platform Id
id [NonVoid Id]
regs
  = CgIdInfo :: Id -> LambdaFormInfo -> CgLoc -> CgIdInfo
CgIdInfo { cg_id :: Id
cg_id = Id
id, cg_lf :: LambdaFormInfo
cg_lf = LambdaFormInfo
lf
             , cg_loc :: CgLoc
cg_loc = BlockId -> [LocalReg] -> CgLoc
LneLoc BlockId
blk_id ((NonVoid Id -> LocalReg) -> [NonVoid Id] -> [LocalReg]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform) [NonVoid Id]
regs) }
  where
    lf :: LambdaFormInfo
lf     = LambdaFormInfo
mkLFLetNoEscape
    blk_id :: BlockId
blk_id = Unique -> BlockId
mkBlockId (Id -> Unique
idUnique Id
id)


rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
id LambdaFormInfo
lf_info
  = do Platform
platform <- FCode Platform
getPlatform
       LocalReg
reg <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
gcWord Platform
platform)
       (CgIdInfo, LocalReg) -> FCode (CgIdInfo, LocalReg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo Id
id LambdaFormInfo
lf_info (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
reg)), LocalReg
reg)

mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit DynFlags
dflags LocalReg
reg LambdaFormInfo
lf_info CmmExpr
expr
  = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) (Platform -> CmmExpr -> DynTag -> CmmExpr
addDynTag Platform
platform CmmExpr
expr (DynFlags -> LambdaFormInfo -> DynTag
lfDynTag DynFlags
dflags LambdaFormInfo
lf_info))
  where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

idInfoToAmode :: CgIdInfo -> CmmExpr
-- Returns a CmmExpr for the *tagged* pointer
idInfoToAmode :: CgIdInfo -> CmmExpr
idInfoToAmode (CgIdInfo { cg_loc :: CgIdInfo -> CgLoc
cg_loc = CmmLoc CmmExpr
e }) = CmmExpr
e
idInfoToAmode CgIdInfo
cg_info
  = String -> SDoc -> CmmExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"idInfoToAmode" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CgIdInfo -> Id
cg_id CgIdInfo
cg_info))        -- LneLoc

-- | A tag adds a byte offset to the pointer
addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
addDynTag Platform
platform CmmExpr
expr DynTag
tag = Platform -> CmmExpr -> DynTag -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
expr DynTag
tag

maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape (CgIdInfo { cg_loc :: CgIdInfo -> CgLoc
cg_loc = LneLoc BlockId
blk_id [LocalReg]
args}) = (BlockId, [LocalReg]) -> Maybe (BlockId, [LocalReg])
forall a. a -> Maybe a
Just (BlockId
blk_id, [LocalReg]
args)
maybeLetNoEscape CgIdInfo
_other                                      = Maybe (BlockId, [LocalReg])
forall a. Maybe a
Nothing



---------------------------------------------------------
--        The binding environment
--
-- There are three basic routines, for adding (addBindC),
-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
---------------------------------------------------------

addBindC :: CgIdInfo -> FCode ()
addBindC :: CgIdInfo -> FCode ()
addBindC CgIdInfo
stuff_to_bind = do
        CgBindings
binds <- FCode CgBindings
getBinds
        CgBindings -> FCode ()
setBinds (CgBindings -> FCode ()) -> CgBindings -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgBindings -> Id -> CgIdInfo -> CgBindings
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv CgBindings
binds (CgIdInfo -> Id
cg_id CgIdInfo
stuff_to_bind) CgIdInfo
stuff_to_bind

addBindsC :: [CgIdInfo] -> FCode ()
addBindsC :: [CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
new_bindings = do
        CgBindings
binds <- FCode CgBindings
getBinds
        let new_binds :: CgBindings
new_binds = (CgBindings -> CgIdInfo -> CgBindings)
-> CgBindings -> [CgIdInfo] -> CgBindings
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ CgBindings
binds CgIdInfo
info -> CgBindings -> Id -> CgIdInfo -> CgBindings
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv CgBindings
binds (CgIdInfo -> Id
cg_id CgIdInfo
info) CgIdInfo
info)
                               CgBindings
binds
                               [CgIdInfo]
new_bindings
        CgBindings -> FCode ()
setBinds CgBindings
new_binds

getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo Id
id
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; CgBindings
local_binds <- FCode CgBindings
getBinds -- Try local bindings first
        ; case CgBindings -> Id -> Maybe CgIdInfo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CgBindings
local_binds Id
id of {
            Just CgIdInfo
info -> CgIdInfo -> FCode CgIdInfo
forall (m :: * -> *) a. Monad m => a -> m a
return CgIdInfo
info ;
            Maybe CgIdInfo
Nothing   -> do {

                -- Should be imported; make up a CgIdInfo for it
          let name :: Name
name = Id -> Name
idName Id
id
        ; if Name -> Bool
isExternalName Name
name then
              let ext_lbl :: CLabel
ext_lbl
                      | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
id) =
                          -- An unlifted external Id must refer to a top-level
                          -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
                          ASSERT( idType id `eqType` addrPrimTy )
                          Name -> CLabel
mkBytesLabel Name
name
                      | Bool
otherwise = Name -> CafInfo -> CLabel
mkClosureLabel Name
name (CafInfo -> CLabel) -> CafInfo -> CLabel
forall a b. (a -> b) -> a -> b
$ Id -> CafInfo
idCafInfo Id
id
              in CgIdInfo -> FCode CgIdInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo -> FCode CgIdInfo) -> CgIdInfo -> FCode CgIdInfo
forall a b. (a -> b) -> a -> b
$
                  DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
id (Id -> LambdaFormInfo
mkLFImported Id
id) (CLabel -> CmmLit
CmmLabel CLabel
ext_lbl)
          else
              Id -> FCode CgIdInfo
forall a. Id -> FCode a
cgLookupPanic Id
id -- Bug
        }}}

cgLookupPanic :: Id -> FCode a
cgLookupPanic :: forall a. Id -> FCode a
cgLookupPanic Id
id
  = do  CgBindings
local_binds <- FCode CgBindings
getBinds
        String -> SDoc -> FCode a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.StgToCmm.Env: variable not found"
                ([SDoc] -> SDoc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id,
                String -> SDoc
text String
"local binds for:",
                CgBindings -> ([CgIdInfo] -> SDoc) -> SDoc
forall key a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM CgBindings
local_binds (([CgIdInfo] -> SDoc) -> SDoc) -> ([CgIdInfo] -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \[CgIdInfo]
infos ->
                  [SDoc] -> SDoc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CgIdInfo -> Id
cg_id CgIdInfo
info) | CgIdInfo
info <- [CgIdInfo]
infos ]
              ])


--------------------
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode :: NonVoid StgArg -> FCode CmmExpr
getArgAmode (NonVoid (StgVarArg Id
var)) = CgIdInfo -> CmmExpr
idInfoToAmode (CgIdInfo -> CmmExpr) -> FCode CgIdInfo -> FCode CmmExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> FCode CgIdInfo
getCgIdInfo Id
var
getArgAmode (NonVoid (StgLitArg Literal
lit)) = CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> FCode CmmLit -> FCode CmmExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> FCode CmmLit
cgLit Literal
lit

getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
-- NB: Filters out void args,
--     so the result list may be shorter than the argument list
getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [] = [CmmExpr] -> FCode [CmmExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getNonVoidArgAmodes (StgArg
arg:[StgArg]
args)
  | PrimRep -> Bool
isVoidRep (StgArg -> PrimRep
argPrimRep StgArg
arg) = [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
  | Bool
otherwise = do { CmmExpr
amode  <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
                   ; [CmmExpr]
amodes <- [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
                   ; [CmmExpr] -> FCode [CmmExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return ( CmmExpr
amode CmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
: [CmmExpr]
amodes ) }


------------------------------------------------------------------------
--        Interface functions for binding and re-binding names
------------------------------------------------------------------------

bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
-- Bind an Id to a fresh LocalReg
bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg nvid :: NonVoid Id
nvid@(NonVoid Id
id) LambdaFormInfo
lf_info
  = do Platform
platform <- FCode Platform
getPlatform
       let reg :: LocalReg
reg = Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform NonVoid Id
nvid
       CgIdInfo -> FCode ()
addBindC (Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo Id
id LambdaFormInfo
lf_info (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
reg)))
       LocalReg -> FCode LocalReg
forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg

rebindToReg :: NonVoid Id -> FCode LocalReg
-- Like bindToReg, but the Id is already in scope, so
-- get its LF info from the envt
rebindToReg :: NonVoid Id -> FCode LocalReg
rebindToReg nvid :: NonVoid Id
nvid@(NonVoid Id
id)
  = do  { CgIdInfo
info <- Id -> FCode CgIdInfo
getCgIdInfo Id
id
        ; NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg NonVoid Id
nvid (CgIdInfo -> LambdaFormInfo
cg_lf CgIdInfo
info) }

bindArgToReg :: NonVoid Id -> FCode LocalReg
bindArgToReg :: NonVoid Id -> FCode LocalReg
bindArgToReg nvid :: NonVoid Id
nvid@(NonVoid Id
id) = NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg NonVoid Id
nvid (Id -> LambdaFormInfo
mkLFArgument Id
id)

bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs [NonVoid Id]
args = (NonVoid Id -> FCode LocalReg) -> [NonVoid Id] -> FCode [LocalReg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonVoid Id -> FCode LocalReg
bindArgToReg [NonVoid Id]
args

idToReg :: Platform -> NonVoid Id -> LocalReg
-- Make a register from an Id, typically a function argument,
-- free variable, or case binder
--
-- We re-use the Unique from the Id to make it easier to see what is going on
--
-- By now the Ids should be uniquely named; else one would worry
-- about accidental collision
idToReg :: Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (NonVoid Id
id)
             = Unique -> CmmType -> LocalReg
LocalReg (Id -> Unique
idUnique Id
id)
                        (Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform (Id -> PrimRep
idPrimRep Id
id))