{-# LANGUAGE CPP #-}

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

        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
        idInfoToAmode,

        addBindC, addBindsC,

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

#include "HsVersions.h"

import GhcPrelude

import TyCon
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure

import CLabel

import BlockId
import CmmExpr
import CmmUtils
import DynFlags
import Id
import MkGraph
import Name
import Outputable
import StgSyn
import Type
import TysPrim
import UniqFM
import Util
import VarEnv

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

mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
mkCgIdInfo id :: Id
id lf :: LambdaFormInfo
lf expr :: 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 dflags :: DynFlags
dflags id :: Id
id lf :: LambdaFormInfo
lf lit :: 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 (DynFlags -> CmmExpr -> DynTag -> CmmExpr
addDynTag DynFlags
dflags (CmmLit -> CmmExpr
CmmLit CmmLit
lit) DynTag
tag) }
  where
    tag :: DynTag
tag = DynFlags -> LambdaFormInfo -> DynTag
lfDynTag DynFlags
dflags LambdaFormInfo
lf

lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
lneIdInfo dflags :: DynFlags
dflags id :: Id
id regs :: [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 (DynFlags -> NonVoid Id -> LocalReg
idToReg DynFlags
dflags) [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
id lf_info :: LambdaFormInfo
lf_info
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       LocalReg
reg <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
       (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 dflags :: DynFlags
dflags reg :: LocalReg
reg lf_info :: LambdaFormInfo
lf_info expr :: CmmExpr
expr
  = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) (DynFlags -> CmmExpr -> DynTag -> CmmExpr
addDynTag DynFlags
dflags CmmExpr
expr (DynFlags -> LambdaFormInfo -> DynTag
lfDynTag DynFlags
dflags LambdaFormInfo
lf_info))

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

addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
-- A tag adds a byte offset to the pointer
addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
addDynTag dflags :: DynFlags
dflags expr :: CmmExpr
expr tag :: DynTag
tag = DynFlags -> CmmExpr -> DynTag -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr DynTag
tag

maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape (CgIdInfo { cg_loc :: CgIdInfo -> CgLoc
cg_loc = LneLoc blk_id :: BlockId
blk_id args :: [LocalReg]
args}) = (BlockId, [LocalReg]) -> Maybe (BlockId, [LocalReg])
forall a. a -> Maybe a
Just (BlockId
blk_id, [LocalReg]
args)
maybeLetNoEscape _other :: 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 stuff_to_bind :: 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 new_bindings :: [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' (\ binds :: CgBindings
binds info :: 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
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 info :: CgIdInfo
info -> CgIdInfo -> FCode CgIdInfo
forall (m :: * -> *) a. Monad m => a -> m a
return CgIdInfo
info ;
            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 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 :: Id -> FCode a
cgLookupPanic id :: Id
id
  = do  CgBindings
local_binds <- FCode CgBindings
getBinds
        String -> SDoc -> FCode a
forall a. HasCallStack => String -> SDoc -> a
pprPanic "StgCmmEnv: variable not found"
                ([SDoc] -> SDoc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id,
                String -> SDoc
text "local binds for:",
                CgBindings -> ([CgIdInfo] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM CgBindings
local_binds (([CgIdInfo] -> SDoc) -> SDoc) -> ([CgIdInfo] -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \infos :: [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 var :: 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 lit :: 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 (arg :: StgArg
arg:args :: [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
id) lf_info :: LambdaFormInfo
lf_info
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let reg :: LocalReg
reg = DynFlags -> NonVoid Id -> LocalReg
idToReg DynFlags
dflags 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
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
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 args :: [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 :: DynFlags -> 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 :: DynFlags -> NonVoid Id -> LocalReg
idToReg dflags :: DynFlags
dflags (NonVoid id :: Id
id)
             = Unique -> CmmType -> LocalReg
LocalReg (Id -> Unique
idUnique Id
id)
                        (DynFlags -> PrimRep -> CmmType
primRepCmmType DynFlags
dflags (Id -> PrimRep
idPrimRep Id
id))