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

    module StgCmmEnv (
    	CgIdInfo,

    	cgIdInfoId, cgIdInfoLF,

    	litIdInfo, lneIdInfo, regIdInfo,
    	idInfoToAmode,

            NonVoid(..), isVoidId, nonVoidIds,

    	addBindC, addBindsC,

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

    #include "HsVersions.h"

    import TyCon
    import StgCmmMonad
    import StgCmmUtils
    import StgCmmClosure

    import CLabel

    import BlockId
    import Cmm
    import CmmUtils
    import FastString
    import PprCmm		( {- instance Outputable -} )
    import Id
    import VarEnv
    import Control.Monad
    import Name
    import StgSyn
    import Outputable

    -------------------------------------
    --	Non-void types
    -------------------------------------
    -- We frequently need the invariant that an Id or a an argument
    -- is of a non-void type. This type is a witness to the invariant.

    newtype NonVoid a = NonVoid a
      deriving (Eq, Show)

    instance (Outputable a) => Outputable (NonVoid a) where
      ppr (NonVoid a) = ppr a

    isVoidId :: Id -> Bool
    isVoidId = isVoidRep . idPrimRep

    nonVoidIds :: [Id] -> [NonVoid Id]
    nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]

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

    mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
    mkCgIdInfo id lf expr
      = CgIdInfo { cg_id = id, cg_loc = CmmLoc expr,
    	       cg_lf = lf, cg_rep = idPrimRep id,
    	       cg_tag = lfDynTag lf }

    lneIdInfo :: Id -> [LocalReg] -> CgIdInfo
    lneIdInfo id regs
      = CgIdInfo { cg_id = id, cg_loc = LneLoc blk_id regs,
    	       cg_lf = lf, cg_rep = idPrimRep id,
    	       cg_tag = lfDynTag lf }
      where
        lf     = mkLFLetNoEscape
        blk_id = mkBlockId (idUnique id)

    litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
    litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit)
      mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))

    regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
    regIdInfo id lf_info reg =
      mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))

    idInfoToAmode :: CgIdInfo -> CmmExpr
    -- Returns a CmmExpr for the *tagged* pointer
    idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
    idInfoToAmode cg_info
      = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))	-- LneLoc

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

    cgIdInfoId :: CgIdInfo -> Id
    cgIdInfoId = cg_id

    cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
    cgIdInfoLF = cg_lf

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

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

    addBindC :: Id -> CgIdInfo -> FCode ()
    addBindC name stuff_to_bind = do
    	binds <- getBinds
    	setBinds $ extendVarEnv binds name stuff_to_bind

    addBindsC :: [CgIdInfo] -> FCode ()
    addBindsC new_bindings = do
    	binds <- getBinds
    	let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
    			      binds
    			      new_bindings
    	setBinds new_binds

    getCgIdInfo :: Id -> FCode CgIdInfo
    getCgIdInfo id
      = do	{ 	-- Try local bindings first
    	; local_binds  <- getBinds
    	; case lookupVarEnv local_binds id of {
    	    Just info -> return info ;
    	    Nothing   -> do

    	{ 	-- Try top-level bindings
    	  static_binds <- getStaticBinds
    	; case lookupVarEnv static_binds id of {
    	    Just info -> return info ;
    	    Nothing   ->

    		-- Should be imported; make up a CgIdInfo for it
    	let
    	    name = idName id
    	in
    	if isExternalName name then do
    	    let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
    	    return (litIdInfo id (mkLFImported id) ext_lbl)
    	else
    	-- Bug
    	cgLookupPanic id
    	}}}}

    cgLookupPanic :: Id -> FCode a
    cgLookupPanic id
      = do	static_binds <- getStaticBinds
    	local_binds <- getBinds
    	srt <- getSRTLabel
    	pprPanic "StgCmmEnv: variable not found"
    		(vcat [ppr id,
    		ptext (sLit "static binds for:"),
    		vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
    		ptext (sLit "local binds for:"),
    		vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
    	        ptext (sLit "SRT label") <+> pprCLabel srt
    	      ])

    --------------------
    getArgAmode :: NonVoid StgArg -> FCode CmmExpr
    getArgAmode (NonVoid (StgVarArg var))  =
      do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
    getArgAmode (NonVoid (StgLitArg lit))  = liftM CmmLit $ cgLit lit
    getArgAmode (NonVoid (StgTypeArg _))   = panic "getArgAmode: type arg"

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

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

    bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
    -- Bind an Id to a fresh LocalReg
    bindToReg nvid@(NonVoid id) lf_info
      = do	{ let reg = idToReg nvid
    	; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
    	; return reg }

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

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

    bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
    bindArgsToRegs args = mapM bindArgToReg args

    idToReg :: 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 (NonVoid id) = LocalReg (idUnique id)
                            (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
                                                  _ -> primRepCmmType (idPrimRep id))