+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgBindery]{Utility functions related to doing @CgBindings@}
-
-\begin{code}
-module CgBindery (
- CgBindings, CgIdInfo,
- StableLoc, VolatileLoc,
-
- cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
-
- stableIdInfo, heapIdInfo,
- letNoEscapeIdInfo, idInfoToAmode,
-
- addBindC, addBindsC,
-
- nukeVolatileBinds,
- nukeDeadBindings,
- getLiveStackSlots,
-
- bindArgsToStack, rebindToStack,
- bindNewToNode, bindNewToReg, bindArgsToRegs,
- bindNewToTemp,
- getArgAmode, getArgAmodes,
- getCgIdInfo,
- getCAddrModeIfVolatile, getVolatileRegs,
- maybeLetNoEscape,
- ) where
-
-#include "HsVersions.h"
-
-import CgMonad
-import CgHeapery ( getHpRelOffset )
-import CgStackery ( freeStackSlots, getSpRelOffset )
-import CgUtils ( cgLit, cmmOffsetW )
-import CLabel ( mkClosureLabel, pprCLabel )
-import ClosureInfo ( mkLFImported, mkLFArgument, LambdaFormInfo )
-
-import Cmm
-import PprCmm ( {- instance Outputable -} )
-import SMRep ( CgRep(..), WordOff, isFollowableArg,
- isVoidArg, cgRepSizeW, argMachRep,
- idCgRep, typeCgRep )
-import Id ( Id, idName )
-import VarEnv
-import VarSet ( varSetElems )
-import Literal ( literalType )
-import Maybes ( catMaybes )
-import Name ( isExternalName )
-import StgSyn ( StgArg, StgLiveVars, GenStgArg(..), isStgTypeArg )
-import Unique ( Uniquable(..) )
-import UniqSet ( elementOfUniqSet )
-import Outputable
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Bindery-datatypes]{Data types}
-%* *
-%************************************************************************
-
-@(CgBinding a b)@ is a type of finite maps from a to b.
-
-The assumption used to be that @lookupCgBind@ must get exactly one
-match. This is {\em completely wrong} in the case of compiling
-letrecs (where knot-tying is used). An initial binding is fed in (and
-never evaluated); eventually, a correct binding is put into the
-environment. So there can be two bindings for a given name.
-
-\begin{code}
-type CgBindings = IdEnv CgIdInfo
-
-data CgIdInfo
- = CgIdInfo
- { cg_id :: Id -- Id that this is the info for
- -- Can differ from the Id at occurrence sites by
- -- virtue of being externalised, for splittable C
- , cg_rep :: CgRep
- , cg_vol :: VolatileLoc
- , cg_stb :: StableLoc
- , cg_lf :: LambdaFormInfo }
-
-mkCgIdInfo id vol stb lf
- = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb,
- cg_lf = lf, cg_rep = idCgRep id }
-
-voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
- , cg_stb = VoidLoc, cg_lf = mkLFArgument id
- , cg_rep = VoidArg }
- -- Used just for VoidRep things
-
-data VolatileLoc -- These locations die across a call
- = NoVolatileLoc
- | RegLoc CmmReg -- In one of the registers (global or local)
- | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure)
- | VirNodeLoc VirtualHpOffset -- Cts of offset indirect from Node
- -- ie *(Node+offset)
-\end{code}
-
-@StableLoc@ encodes where an Id can be found, used by
-the @CgBindings@ environment in @CgBindery@.
-
-\begin{code}
-data StableLoc
- = NoStableLoc
-
- | VirStkLoc VirtualSpOffset -- The thing is held in this
- -- stack slot
-
- | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the
- -- value is this stack pointer
- -- (as opposed to the contents of the slot)
-
- | StableLoc CmmExpr
- | VoidLoc -- Used only for VoidRep variables. They never need to
- -- be saved, so it makes sense to treat treat them as
- -- having a stable location
-\end{code}
-
-\begin{code}
-instance Outputable CgIdInfo where
- ppr (CgIdInfo id rep vol stb lf)
- = ppr id <+> ptext SLIT("-->") <+> vcat [ppr vol, ppr stb]
-
-instance Outputable VolatileLoc where
- ppr NoVolatileLoc = empty
- ppr (RegLoc r) = ptext SLIT("reg") <+> ppr r
- ppr (VirHpLoc v) = ptext SLIT("vh") <+> ppr v
- ppr (VirNodeLoc v) = ptext SLIT("vn") <+> ppr v
-
-instance Outputable StableLoc where
- ppr NoStableLoc = empty
- ppr VoidLoc = ptext SLIT("void")
- ppr (VirStkLoc v) = ptext SLIT("vs") <+> ppr v
- ppr (VirStkLNE v) = ptext SLIT("lne") <+> ppr v
- ppr (StableLoc a) = ptext SLIT("amode") <+> ppr a
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Bindery-idInfo]{Manipulating IdInfo}
-%* *
-%************************************************************************
-
-\begin{code}
-stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info
-heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info
-letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info
-stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info
-nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc offset) NoStableLoc lf_info
-regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info
-
-idInfoToAmode :: CgIdInfo -> FCode CmmExpr
-idInfoToAmode info
- = case cg_vol info of {
- RegLoc reg -> returnFC (CmmReg reg) ;
- VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetW (CmmReg nodeReg) nd_off) mach_rep) ;
- VirHpLoc hp_off -> getHpRelOffset hp_off ;
- NoVolatileLoc ->
-
- case cg_stb info of
- StableLoc amode -> returnFC amode
- VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
- ; return (CmmLoad sp_rel mach_rep) }
-
- VirStkLNE sp_off -> getSpRelOffset sp_off
-
- VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
- -- We return a 'bottom' amode, rather than panicing now
- -- In this way getArgAmode returns a pair of (VoidArg, bottom)
- -- and that's exactly what we want
-
- NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
- }
- where
- mach_rep = argMachRep (cg_rep info)
-
-cgIdInfoId :: CgIdInfo -> Id
-cgIdInfoId = cg_id
-
-cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
-cgIdInfoLF = cg_lf
-
-cgIdInfoArgRep :: CgIdInfo -> CgRep
-cgIdInfoArgRep = cg_rep
-
-maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
-maybeLetNoEscape other = Nothing
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
-%* *
-%************************************************************************
-
-.There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
-
-A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
-The name should not already be bound. (nice ASSERT, eh?)
-
-\begin{code}
-addBindC :: Id -> CgIdInfo -> Code
-addBindC name stuff_to_bind = do
- binds <- getBinds
- setBinds $ extendVarEnv binds name stuff_to_bind
-
-addBindsC :: [(Id, CgIdInfo)] -> Code
-addBindsC new_bindings = do
- binds <- getBinds
- let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
- binds
- new_bindings
- setBinds new_binds
-
-modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
-modifyBindC name mangle_fn = do
- binds <- getBinds
- setBinds $ modifyVarEnv mangle_fn binds name
-
-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
- hmods <- getHomeModules
- let ext_lbl = CmmLit (CmmLabel (mkClosureLabel hmods name))
- return (stableIdInfo id ext_lbl (mkLFImported id))
- else
- if isVoidArg (idCgRep id) then
- -- Void things are never in the environment
- return (voidIdInfo id)
- else
- -- Bug
- cgLookupPanic id
- }}}}
-
-
-cgLookupPanic :: Id -> FCode a
-cgLookupPanic id
- = do static_binds <- getStaticBinds
- local_binds <- getBinds
- srt <- getSRTLabel
- pprPanic "cgPanic"
- (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
- ])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
-%* *
-%************************************************************************
-
-We sometimes want to nuke all the volatile bindings; we must be sure
-we don't leave any (NoVolatile, NoStable) binds around...
-
-\begin{code}
-nukeVolatileBinds :: CgBindings -> CgBindings
-nukeVolatileBinds binds
- = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
- where
- keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
- keep_if_stable info acc
- = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[lookup-interface]{Interface functions to looking up bindings}
-%* *
-%************************************************************************
-
-\begin{code}
-getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
-getCAddrModeIfVolatile id
- = do { info <- getCgIdInfo id
- ; case cg_stb info of
- NoStableLoc -> do -- Aha! So it is volatile!
- amode <- idInfoToAmode info
- return $ Just amode
- a_stable_loc -> return Nothing }
-\end{code}
-
-@getVolatileRegs@ gets a set of live variables, and returns a list of
-all registers on which these variables depend. These are the regs
-which must be saved and restored across any C calls. If a variable is
-both in a volatile location (depending on a register) {\em and} a
-stable one (notably, on the stack), we modify the current bindings to
-forget the volatile one.
-
-\begin{code}
-getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
-
-getVolatileRegs vars = do
- do { stuff <- mapFCs snaffle_it (varSetElems vars)
- ; returnFC $ catMaybes stuff }
- where
- snaffle_it var = do
- { info <- getCgIdInfo var
- ; let
- -- commoned-up code...
- consider_reg reg
- = -- We assume that all regs can die across C calls
- -- We leave it to the save-macros to decide which
- -- regs *really* need to be saved.
- case cg_stb info of
- NoStableLoc -> returnFC (Just reg) -- got one!
- is_a_stable_loc -> do
- { -- has both volatile & stable locations;
- -- force it to rely on the stable location
- modifyBindC var nuke_vol_bind
- ; return Nothing }
-
- ; case cg_vol info of
- RegLoc (CmmGlobal reg) -> consider_reg reg
- VirNodeLoc _ -> consider_reg node
- other_loc -> returnFC Nothing -- Local registers
- }
-
- nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
-\end{code}
-
-\begin{code}
-getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
-getArgAmode (StgVarArg var)
- = do { info <- getCgIdInfo var
- ; amode <- idInfoToAmode info
- ; return (cgIdInfoArgRep info, amode ) }
-
-getArgAmode (StgLitArg lit)
- = do { cmm_lit <- cgLit lit
- ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
-
-getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg"
-
-getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
-getArgAmodes [] = returnFC []
-getArgAmodes (atom:atoms)
- | isStgTypeArg atom = getArgAmodes atoms
- | otherwise = do { amode <- getArgAmode atom
- ; amodes <- getArgAmodes atoms
- ; return ( amode : amodes ) }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
-%* *
-%************************************************************************
-
-\begin{code}
-bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
-bindArgsToStack args
- = mapCs bind args
- where
- bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id))
-
-bindArgsToRegs :: [(Id, GlobalReg)] -> Code
-bindArgsToRegs args
- = mapCs bind args
- where
- bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
-
-bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
-bindNewToNode id offset lf_info
- = addBindC id (nodeIdInfo id offset lf_info)
-
--- Create a new temporary whose unique is that in the id,
--- bind the id to it, and return the addressing mode for the
--- temporary.
-bindNewToTemp :: Id -> FCode CmmReg
-bindNewToTemp id
- = do addBindC id (regIdInfo id temp_reg lf_info)
- return temp_reg
- where
- uniq = getUnique id
- temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
- lf_info = mkLFArgument id -- Always used of things we
- -- know nothing about
-
-bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
-bindNewToReg name reg lf_info
- = addBindC name info
- where
- info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info
-\end{code}
-
-\begin{code}
-rebindToStack :: Id -> VirtualSpOffset -> Code
-rebindToStack name offset
- = modifyBindC name replace_stable_fn
- where
- replace_stable_fn info = info { cg_stb = VirStkLoc offset }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgMonad-deadslots]{Finding dead stack slots}
-%* *
-%************************************************************************
-
-nukeDeadBindings does the following:
-
- - Removes all bindings from the environment other than those
- for variables in the argument to nukeDeadBindings.
- - Collects any stack slots so freed, and returns them to the stack free
- list.
- - Moves the virtual stack pointer to point to the topmost used
- stack locations.
-
-You can have multi-word slots on the stack (where a Double# used to
-be, for instance); if dead, such a slot will be reported as *several*
-offsets (one per word).
-
-Probably *naughty* to look inside monad...
-
-\begin{code}
-nukeDeadBindings :: StgLiveVars -- All the *live* variables
- -> Code
-nukeDeadBindings live_vars = do
- binds <- getBinds
- let (dead_stk_slots, bs') =
- dead_slots live_vars
- [] []
- [ (cg_id b, b) | b <- varEnvElts binds ]
- setBinds $ mkVarEnv bs'
- freeStackSlots dead_stk_slots
-\end{code}
-
-Several boring auxiliary functions to do the dirty work.
-
-\begin{code}
-dead_slots :: StgLiveVars
- -> [(Id,CgIdInfo)]
- -> [VirtualSpOffset]
- -> [(Id,CgIdInfo)]
- -> ([VirtualSpOffset], [(Id,CgIdInfo)])
-
--- dead_slots carries accumulating parameters for
--- filtered bindings, dead slots
-dead_slots live_vars fbs ds []
- = (ds, reverse fbs) -- Finished; rm the dups, if any
-
-dead_slots live_vars fbs ds ((v,i):bs)
- | v `elementOfUniqSet` live_vars
- = dead_slots live_vars ((v,i):fbs) ds bs
- -- Live, so don't record it in dead slots
- -- Instead keep it in the filtered bindings
-
- | otherwise
- = case cg_stb i of
- VirStkLoc offset
- | size > 0
- -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
-
- _ -> dead_slots live_vars fbs ds bs
- where
- size :: WordOff
- size = cgRepSizeW (cg_rep i)
-\end{code}
-
-\begin{code}
-getLiveStackSlots :: FCode [VirtualSpOffset]
--- Return the offsets of slots in stack containig live pointers
-getLiveStackSlots
- = do { binds <- getBinds
- ; return [off | CgIdInfo { cg_stb = VirStkLoc off,
- cg_rep = rep } <- varEnvElts binds,
- isFollowableArg rep] }
-\end{code}
projects / ghc-hetmet.git / blobdiff