Commit c31a55d1 authored by rje's avatar rje
Browse files

[project @ 2001-08-29 14:20:14 by rje]

FCode/Code is now a monad, and thus now also a constructed type, rather than a
type synonym.

This requires quite a lot of changes in quite a lot of files, but none of these changes should have changed the behaviour of anything.

Being a Monad allows code that used FCode to be IMHO rather more readable
as it can use do notation, and other common Monad idioms.

In addition, state has been abstracted away with getter and setter
functions, so that functions mess with the innards of FCode as little as
possible - making it easier to change FCode in future.
parent 13350796
......@@ -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 = ASSERT (all (>=0) rel_slots) 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 = 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.26 2000/11/06 08:15:21 simonpj Exp $
% $Id: CgMonad.lhs,v 1.27 2001/08/29 14:20:14 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