Commit 205383c2 authored by rje's avatar rje
Browse files

[project @ 2001-08-31 12:39:06 by rje]

Reapplied my "FCode as a monad" patch, now that 5.02 has forked into
a separate branch.

I'm fairly sure that this doesn't change the behaviour of anything.
parent 642e22e8
......@@ -176,41 +176,40 @@ The name should not already be bound. (nice ASSERT, eh?)
\begin{code}
addBindC :: Id -> CgIdInfo -> Code
addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
= MkCgState absC (extendVarEnv binds name stuff_to_bind) usage
addBindC name stuff_to_bind = do
binds <- getBinds
setBinds $ extendVarEnv binds name stuff_to_bind
addBindsC :: [(Id, CgIdInfo)] -> Code
addBindsC new_bindings info_down (MkCgState absC binds usage)
= MkCgState absC new_binds usage
where
new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
binds
new_bindings
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 info_down (MkCgState absC binds usage)
= MkCgState absC (modifyVarEnv mangle_fn binds name) usage
modifyBindC name mangle_fn = do
binds <- getBinds
setBinds $ modifyVarEnv mangle_fn binds name
lookupBindC :: Id -> FCode CgIdInfo
lookupBindC name info_down@(MkCgInfoDown _ static_binds srt ticky _)
state@(MkCgState absC local_binds usage)
= (val, state)
where
val = case (lookupVarEnv local_binds name) of
Nothing -> try_static
Just this -> this
try_static =
case (lookupVarEnv static_binds name) of
Just this -> this
Nothing
-> cgPanic (text "lookupBindC: no info for" <+> ppr name) info_down state
cgPanic :: SDoc -> CgInfoDownwards -> CgState -> a
cgPanic doc info_down@(MkCgInfoDown _ static_binds srt ticky _)
state@(MkCgState absC local_binds usage)
= pprPanic "cgPanic"
(vcat [doc,
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
cgPanic :: SDoc -> FCode a
cgPanic doc = do
static_binds <- getStaticBinds
local_binds <- getBinds
srt <- getSRTLabel
pprPanic "cgPanic"
(vcat [doc,
ptext SLIT("static binds for:"),
vcat [ ppr i | (MkCgIdInfo i _ _ _) <- rngVarEnv static_binds ],
ptext SLIT("local binds for:"),
......@@ -256,20 +255,20 @@ getCAddrModeAndInfo id
-- deals with imported or locally defined but externally visible ids
-- (CoreTidy makes all these into global names).
| otherwise = -- *might* be a nested defn: in any case, it's something whose
| otherwise = do -- *might* be a nested defn: in any case, it's something whose
-- definition we will know about...
lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) ->
idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
returnFC (id', amode, lf_info)
(MkCgIdInfo id' volatile_loc stable_loc lf_info) <- lookupBindC id
amode <- idInfoPiecesToAmode kind volatile_loc stable_loc
return (id', amode, lf_info)
where
name = getName id
global_amode = CLbl (mkClosureLabel name) kind
kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
= getCAddrModeAndInfo name `thenFC` \ (_, amode, _) ->
returnFC amode
getCAddrMode name = do
(_, amode, _) <- getCAddrModeAndInfo name
return amode
\end{code}
\begin{code}
......@@ -277,13 +276,13 @@ getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
getCAddrModeIfVolatile name
-- | toplevelishId name = returnFC Nothing
-- | otherwise
= lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
case stable_loc of
NoStableLoc -> -- Aha! So it is volatile!
idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
returnFC (Just amode)
a_stable_loc -> returnFC Nothing
= do
(MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC name
case stable_loc of
NoStableLoc -> do -- Aha! So it is volatile!
amode <- idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc
return $ Just amode
a_stable_loc -> return Nothing
\end{code}
@getVolatileRegs@ gets a set of live variables, and returns a list of
......@@ -296,50 +295,50 @@ forget the volatile one.
\begin{code}
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
getVolatileRegs vars
= mapFCs snaffle_it (varSetElems vars) `thenFC` \ stuff ->
returnFC (catMaybes stuff)
where
snaffle_it var
= lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
let
-- commoned-up code...
consider_reg reg
= if not (isVolatileReg reg) then
-- Potentially dies across C calls
-- For now, that's everything; we leave
-- it to the save-macros to decide which
-- regs *really* need to be saved.
returnFC Nothing
else
case stable_loc of
NoStableLoc -> returnFC (Just reg) -- got one!
is_a_stable_loc ->
-- has both volatile & stable locations;
-- force it to rely on the stable location
modifyBindC var nuke_vol_bind `thenC`
returnFC Nothing
in
case volatile_loc of
RegLoc reg -> consider_reg reg
VirHpLoc _ -> consider_reg Hp
VirNodeLoc _ -> consider_reg node
non_reg_loc -> returnFC Nothing
nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
= MkCgIdInfo i NoVolatileLoc stable_loc lf_info
getVolatileRegs vars = do
stuff <- mapFCs snaffle_it (varSetElems vars)
returnFC $ catMaybes stuff
where
snaffle_it var = do
(MkCgIdInfo _ volatile_loc stable_loc lf_info) <- lookupBindC var
let
-- commoned-up code...
consider_reg reg =
if not (isVolatileReg reg) then
-- Potentially dies across C calls
-- For now, that's everything; we leave
-- it to the save-macros to decide which
-- regs *really* need to be saved.
returnFC Nothing
else
case stable_loc 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
in
case volatile_loc of
RegLoc reg -> consider_reg reg
VirHpLoc _ -> consider_reg Hp
VirNodeLoc _ -> consider_reg node
non_reg_loc -> returnFC Nothing
nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info)
= MkCgIdInfo i NoVolatileLoc stable_loc lf_info
\end{code}
\begin{code}
getArgAmodes :: [StgArg] -> FCode [CAddrMode]
getArgAmodes [] = returnFC []
getArgAmodes (atom:atoms)
| isStgTypeArg atom
= getArgAmodes atoms
| otherwise
= getArgAmode atom `thenFC` \ amode ->
getArgAmodes atoms `thenFC` \ amodes ->
returnFC ( amode : amodes )
| isStgTypeArg atom
= getArgAmodes atoms
| otherwise = do
amode <- getArgAmode atom
amodes <- getArgAmodes atoms
return ( amode : amodes )
getArgAmode :: StgArg -> FCode CAddrMode
......@@ -375,9 +374,9 @@ bindNewToTemp name
-- This is used only for things we don't know
-- anything about; values returned by a case statement,
-- for example.
in
addBindC name id_info `thenC`
returnFC temp_amode
in do
addBindC name id_info
return temp_amode
bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code
bindNewToReg name magic_id lf_info
......@@ -425,6 +424,8 @@ rebindToStack name offset
%* *
%************************************************************************
ToDo: remove the dependency on 32-bit words.
There are four kinds of things on the stack:
- pointer variables (bound in the environment)
......@@ -450,34 +451,35 @@ buildLivenessMask
-> VirtualSpOffset -- offset from which the bitmap should start
-> FCode Liveness -- mask for free/unlifted slots
buildLivenessMask uniq sp info_down
state@(MkCgState abs_c binds ((vsp, free, _, _), heap_usage))
= ASSERT(all (>=0) rel_slots)
livenessToAbsC uniq liveness_mask info_down state
where
buildLivenessMask uniq sp = do
-- find all unboxed stack-resident ids
unboxed_slots =
[ (ofs, size) |
(MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
let rep = idPrimRep id; size = getPrimRepSize rep,
binds <- getBinds
((vsp, free, _, _), heap_usage) <- getUsage
let unboxed_slots =
[ (ofs, size) |
(MkCgIdInfo id _ (VirStkLoc ofs) _) <- rngVarEnv binds,
let rep = idPrimRep id; size = getPrimRepSize rep,
not (isFollowableRep rep),
size > 0
]
]
-- flatten this list into a list of unboxed stack slots
flatten_slots = sortLt (<)
let flatten_slots = sortLt (<)
(foldr (\(ofs,size) r -> [ofs-size+1 .. ofs] ++ r) []
unboxed_slots)
-- merge in the free slots
all_slots = mergeSlots flatten_slots (map fst free) ++
let all_slots = mergeSlots flatten_slots (map fst free) ++
if vsp < sp then [vsp+1 .. sp] else []
-- recalibrate the list to be sp-relative
rel_slots = reverse (map (sp-) all_slots)
let rel_slots = reverse (map (sp-) all_slots)
-- build the bitmap
liveness_mask = listToLivenessMask rel_slots
let liveness_mask = ASSERT(all (>=0) rel_slots) (listToLivenessMask rel_slots)
livenessToAbsC uniq liveness_mask
mergeSlots :: [Int] -> [Int] -> [Int]
mergeSlots cs [] = cs
......@@ -497,10 +499,10 @@ listToLivenessMask slots =
where (this,rest) = span (<32) slots
livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
livenessToAbsC uniq mask =
absC (CBitmap lbl mask) `thenC`
returnFC (Liveness lbl mask)
where lbl = mkBitmapLabel uniq
livenessToAbsC uniq mask =
absC (CBitmap lbl mask) `thenC`
returnFC (Liveness lbl mask)
where lbl = mkBitmapLabel uniq
\end{code}
In a continuation, we want a liveness mask that starts from just after
......@@ -510,9 +512,9 @@ the return address, which is on the stack at realSp.
buildContLivenessMask
:: Unique
-> FCode Liveness
buildContLivenessMask uniq
= getRealSp `thenFC` \ realSp ->
buildLivenessMask uniq (realSp-1)
buildContLivenessMask uniq = do
realSp <- getRealSp
buildLivenessMask uniq (realSp-1)
\end{code}
%************************************************************************
......@@ -539,16 +541,15 @@ Probably *naughty* to look inside monad...
\begin{code}
nukeDeadBindings :: StgLiveVars -- All the *live* variables
-> Code
nukeDeadBindings live_vars info_down (MkCgState abs_c binds usage)
= freeStackSlots extra_free info_down (MkCgState abs_c (mkVarEnv bs') usage)
where
(dead_stk_slots, bs')
= dead_slots live_vars
[] []
[ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
extra_free = sortLt (<) dead_stk_slots
nukeDeadBindings live_vars = do
binds <- getBinds
let (dead_stk_slots, bs') =
dead_slots live_vars
[] []
[ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngVarEnv binds ]
let extra_free = sortLt (<) dead_stk_slots
setBinds $ mkVarEnv bs'
freeStackSlots extra_free
\end{code}
Several boring auxiliary functions to do the dirty work.
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgMonad.lhs,v 1.28 2001/08/30 09:51:16 sewardj Exp $
% $Id: CgMonad.lhs,v 1.29 2001/08/31 12:39:06 rje Exp $
%
\section[CgMonad]{The code generation monad}
......@@ -35,6 +35,13 @@ module CgMonad (
Sequel(..), -- ToDo: unabstract?
sequelToAmode,
-- ideally we wouldn't export these, but some other modules access internal state
getState, setState, getInfoDown,
-- more localised access to monad state
getUsage, setUsage,
getBinds, setBinds, getStaticBinds,
-- out of general friendliness, we also export ...
CgInfoDownwards(..), CgState(..), -- non-abstract
CompilationInfo(..)
......@@ -253,8 +260,12 @@ stateIncUsage (MkCgState abs_c bs ((v,f,r,h1),(vH1,rH1)))
%************************************************************************
\begin{code}
type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
type Code = CgInfoDownwards -> CgState -> CgState
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
type Code = FCode ()
instance Monad FCode where
(>>=) = thenFC
return = returnFC
{-# INLINE thenC #-}
{-# INLINE thenFC #-}
......@@ -265,7 +276,7 @@ The Abstract~C is not in the environment so as to improve strictness.
\begin{code}
initC :: CompilationInfo -> Code -> AbstractC
initC cg_info code
initC cg_info (FCode code)
= case (code (MkCgInfoDown
cg_info
(error "initC: statics")
......@@ -273,83 +284,111 @@ initC cg_info code
(mkTopTickyCtrLabel)
initEobInfo)
initialStateC) of
MkCgState abc _ _ -> abc
((),MkCgState abc _ _) -> abc
returnFC :: a -> FCode a
returnFC val info_down state = (val, state)
returnFC val = FCode (\info_down state -> (val, state))
\end{code}
\begin{code}
thenC :: Code
-> (CgInfoDownwards -> CgState -> a)
-> CgInfoDownwards -> CgState -> a
-- thenC has both of the following types:
-- thenC :: Code -> Code -> Code
-- thenC :: Code -> FCode a -> FCode a
thenC m k info_down state
= k info_down new_state
where
new_state = m info_down state
thenC :: Code -> FCode a -> FCode a
thenC (FCode m) (FCode k) =
FCode (\info_down state -> let (_,new_state) = m info_down state in
k info_down new_state)
listCs :: [Code] -> Code
listCs [] info_down state = state
listCs (c:cs) info_down state = stateN
where
state1 = c info_down state
stateN = listCs cs info_down state1
listCs [] = return ()
listCs (fc:fcs) = do
fc
listCs fcs
mapCs :: (a -> Code) -> [a] -> Code
mapCs f [] info_down state = state
mapCs f (c:cs) info_down state = stateN
where
state1 = (f c) info_down state
stateN = mapCs f cs info_down state1
mapCs = mapM_
\end{code}
\begin{code}
thenFC :: FCode a
-> (a -> CgInfoDownwards -> CgState -> c)
-> CgInfoDownwards -> CgState -> c
-- thenFC :: FCode a -> (a -> FCode b) -> FCode b
-- thenFC :: FCode a -> (a -> Code) -> Code
thenFC m k info_down state
= k m_result info_down new_state
where
(m_result, new_state) = m info_down state
thenFC :: FCode a -> (a -> FCode c) -> FCode c
thenFC (FCode m) k = FCode (
\info_down state ->
let
(m_result, new_state) = m info_down state
(FCode kcode) = k m_result
in
kcode info_down new_state
)
listFCs :: [FCode a] -> FCode [a]
listFCs [] info_down state = ([], state)
listFCs (fc:fcs) info_down state = (thing : things, stateN)
where
(thing, state1) = fc info_down state
(things, stateN) = listFCs fcs info_down state1
listFCs = sequence
mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
mapFCs f [] info_down state = ([], state)
mapFCs f (fc:fcs) info_down state = (thing : things, stateN)
where
(thing, state1) = (f fc) info_down state
(things, stateN) = mapFCs f fcs info_down state1
mapFCs = mapM
\end{code}
And the knot-tying combinator:
\begin{code}
fixC :: (a -> FCode a) -> FCode a
fixC fcode info_down state = result
where
result@(v, _) = fcode v info_down state
-- ^-------------^
fixC fcode = FCode (
\info_down state ->
let
FCode fc = fcode v
result@(v,_) = fc info_down state
-- ^--------^
in
result
)
\end{code}
Operators for getting and setting the state and "info_down".
To maximise encapsulation, code should try to only get and set the
state it actually uses.
\begin{code}
getState :: FCode CgState
getState = FCode $ \info_down state -> (state,state)
setState :: CgState -> FCode ()
setState state = FCode $ \info_down _ -> ((),state)
getUsage :: FCode CgStksAndHeapUsage
getUsage = do
MkCgState absC binds usage <- getState
return usage
setUsage :: CgStksAndHeapUsage -> FCode ()
setUsage newusage = do
MkCgState absC binds usage <- getState
setState $ MkCgState absC binds newusage
getBinds :: FCode CgBindings
getBinds = do
MkCgState absC binds usage <- getState
return binds
setBinds :: CgBindings -> FCode ()
setBinds newbinds = do
MkCgState absC binds usage <- getState
setState $ MkCgState absC newbinds usage
getStaticBinds :: FCode CgBindings
getStaticBinds = do
(MkCgInfoDown _ static_binds _ _ _) <- getInfoDown
return static_binds
withState :: FCode a -> CgState -> FCode (a,CgState)
withState (FCode fcode) newstate = FCode $ \info_down state ->
let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
doFCode (FCode fcode) info_down state = fcode info_down state
\end{code}
@forkClosureBody@ takes a code, $c$, and compiles it in a completely
fresh environment, except that:
- compilation info and statics are passed in unchanged.
......@@ -369,36 +408,39 @@ bindings and usage information is otherwise unchanged.
\begin{code}
forkClosureBody :: Code -> Code
forkClosureBody code
(MkCgInfoDown cg_info statics srt ticky _)
(MkCgState absC_in binds un_usage)
= MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
where
fork_state = code body_info_down initialStateC
MkCgState absC_fork _ _ = fork_state
body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
forkClosureBody (FCode code) = do
(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown
(MkCgState absC_in binds un_usage) <- getState
let body_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
let ((),fork_state) = code body_info_down initialStateC
let MkCgState absC_fork _ _ = fork_state
setState $ MkCgState (AbsCStmts absC_in absC_fork) binds un_usage
forkStatics :: FCode a -> FCode a
forkStatics fcode (MkCgInfoDown cg_info _ srt ticky _)
(MkCgState absC_in statics un_usage)
= (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
where
(result, state) = fcode rhs_info_down initialStateC
MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
-- above or it becomes too strict!
rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
forkStatics (FCode fcode) = FCode (
\(MkCgInfoDown cg_info _ srt ticky _)
(MkCgState absC_in statics un_usage)
->
let
(result, state) = fcode rhs_info_down initialStateC
MkCgState absC_fork _ _ = state -- Don't merge these this line with the one
-- above or it becomes too strict!
rhs_info_down = MkCgInfoDown cg_info statics srt ticky initEobInfo
in
(result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage)
)
forkAbsC :: Code -> FCode AbstractC
forkAbsC code info_down (MkCgState absC1 bs usage)
= (absC2, new_state)
where
MkCgState absC2 _ ((_, _, _,h2), _) =
code info_down (MkCgState AbsCNop bs usage)
((v, f, r, h1), heap_usage) = usage
new_usage = ((v, f, r, h1 `max` h2), heap_usage)
new_state = MkCgState absC1 bs new_usage
forkAbsC (FCode code) =
do
info_down <- getInfoDown
(MkCgState absC1 bs usage) <- getState
let ((),MkCgState absC2 _ ((_, _, _,h2), _)) = code info_down (MkCgState AbsCNop bs usage)
let ((v, f, r, h1), heap_usage) = usage
let new_usage = ((v, f, r, h1 `max` h2), heap_usage)
setState $ MkCgState absC1 bs new_usage
return absC2
\end{code}
@forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and
......@@ -411,17 +453,17 @@ that
\begin{code}
forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
forkAlts branch_fcodes deflt_fcode info_down in_state
= ((branch_results , deflt_result), out_state)
where
compile fc = fc info_down in_state
forkAlts branch_fcodes (FCode deflt_fcode) =
do
info_down <- getInfoDown
in_state <- getState
let compile (FCode fc) = fc info_down in_state
let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
-- NB foldl. in_state is the *left* argument to stateIncUsage
return (branch_results, deflt_result)
(branch_results, branch_out_states) = unzip (map compile branch_fcodes)
(deflt_result, deflt_out_state) = deflt_fcode info_down in_state
out_state = foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
-- NB foldl. in_state is the *left* argument to stateIncUsage
\end{code}
@forkEval@ takes two blocks of code.
......@@ -455,23 +497,21 @@ forkEvalHelp :: EndOfBlockInfo -- For the body
-> FCode (Int, -- Sp
a) -- Result of the FCode
forkEvalHelp body_eob_info env_code body_code
info_down@(MkCgInfoDown cg_info statics srt ticky _) state
= ((v,value_returned), state `stateIncUsageEval` state_at_end_return)
where
info_down_for_body = MkCgInfoDown cg_info statics srt ticky body_eob_info