summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
713b32a)
--------------------------
Tidy up arity propagation (the saga continues)
--------------------------
Turns out that it's not as easy as I thought.
The code generator was assuming that (not . isLocalName) was enough to
identify an imported thing (whose CgInfo should be right), but that's
not true. Needs more thought.
Meanwhile, I've made the code generator a bit more sensible about how
it looks things up. But there's still a problem for GHCi: the
unfoldings in the TypeEnv won't have CgIdInfo stuff. Sigh. Thinks.
import VarEnv
import VarSet ( varSetElems )
import Literal ( Literal )
import VarEnv
import VarSet ( varSetElems )
import Literal ( Literal )
-import Maybes ( catMaybes, maybeToBool )
+import Maybes ( catMaybes, maybeToBool, seqMaybe )
import Name ( isLocalName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
import Name ( isLocalName, NamedThing(..) )
#ifdef DEBUG
import PprAbsC ( pprAmode )
setBinds $ modifyVarEnv mangle_fn binds name
lookupBindC :: Id -> FCode CgIdInfo
setBinds $ modifyVarEnv mangle_fn binds name
lookupBindC :: Id -> FCode CgIdInfo
-lookupBindC name = do
- static_binds <- getStaticBinds
- local_binds <- getBinds
- case (lookupVarEnv local_binds name) of
- Nothing -> case (lookupVarEnv static_binds name) of
- Nothing -> cgPanic (text "lookupBindC: no info for" <+> ppr name)
- Just this -> return this
- Just this -> return this
+lookupBindC id = do maybe_info <- lookupBindC_maybe id
+ case maybe_info of
+ Just info -> return info
+ Nothing -> cgLookupPanic id
+
+lookupBindC_maybe :: Id -> FCode (Maybe CgIdInfo)
+lookupBindC_maybe id
+ = do static_binds <- getStaticBinds
+ local_binds <- getBinds
+ return (lookupVarEnv local_binds id
+ `seqMaybe`
+ lookupVarEnv static_binds id)
-cgPanic :: SDoc -> FCode a
-cgPanic doc = do
- static_binds <- getStaticBinds
+cgLookupPanic :: Id -> FCode a
+cgLookupPanic id
+ = do static_binds <- getStaticBinds
local_binds <- getBinds
srt <- getSRTLabel
pprPanic "cgPanic"
local_binds <- getBinds
srt <- getSRTLabel
pprPanic "cgPanic"
ptext SLIT("static binds for:"),
vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
ptext SLIT("static binds for:"),
vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
getCAddrModeAndInfo id
getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)
getCAddrModeAndInfo id
- | not (isLocalName name)
- = returnFC (id, global_amode, mkLFImported id)
- -- deals with imported or locally defined but externally visible ids
- -- (CoreTidy makes all these into global names).
-
- | otherwise = do -- *might* be a nested defn: in any case, it's something whose
- -- definition we will know about...
- (MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id
- amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
- return (id', amode, lf_info)
+ = do
+ maybe_cg_id_info <- lookupBindC_maybe id
+ case maybe_cg_id_info of
+
+ -- Nothing => not in the environment, so should be imported
+ Nothing | isLocalName name -> cgLookupPanic id
+ | otherwise -> returnFC (id, global_amode, mkLFImported id)
+
+ Just (MkCgIdInfo id' volatile_loc stable_loc lf_info)
+ -> do amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
+ return (id', amode, lf_info)
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.30 2001/09/26 15:11:50 simonpj Exp $
+% $Id: CgMonad.lhs,v 1.31 2001/10/15 16:03:04 simonpj Exp $
%
\section[CgMonad]{The code generation monad}
%
\section[CgMonad]{The code generation monad}
initC cg_info (FCode code)
= case (code (MkCgInfoDown
cg_info
initC cg_info (FCode code)
= case (code (MkCgInfoDown
cg_info
- (error "initC: statics")
+ emptyVarEnv -- (error "initC: statics")
(error "initC: srt")
(mkTopTickyCtrLabel)
initEobInfo)
(error "initC: srt")
(mkTopTickyCtrLabel)
initEobInfo)