Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
0d7c6cea
Commit
0d7c6cea
authored
Aug 15, 2006
by
simonpj@microsoft.com
Browse files
Make UniqSM into a proper monad
parent
273d4e21
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/UniqSupply.lhs
View file @
0d7c6cea
...
...
@@ -98,14 +98,19 @@ uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (I# n) : uniqsFromS
%************************************************************************
\begin{code}
type UniqSM result = UniqSupply -> (result, UniqSupply)
newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }
instance Monad UniqSM where
return = returnUs
(>>=) = thenUs
(>>) = thenUs_
-- the initUs function also returns the final UniqSupply; initUs_ drops it
initUs :: UniqSupply -> UniqSM a -> (a,UniqSupply)
initUs init_us m = case m init_us of { (r,us) -> (r,us) }
initUs init_us m = case
unUSM
m init_us of { (r,us) -> (r,us) }
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case m init_us of { (r,us) -> r }
initUs_ init_us m = case
unUSM
m init_us of { (r,us) -> r }
{-# INLINE thenUs #-}
{-# INLINE lazyThenUs #-}
...
...
@@ -116,38 +121,38 @@ initUs_ init_us m = case m init_us of { (r,us) -> r }
@thenUs@ is where we split the @UniqSupply@.
\begin{code}
fixUs :: (a -> UniqSM a) -> UniqSM a
fixUs m us
= (r,us') where (r,us') = m r us
fixUs m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs expr cont us
= case (expr us) of { (result, us') -> cont result us' }
thenUs (USM expr) cont
= USM (\us -> case (expr us) of
(result, us') -> unUSM (cont result) us')
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
lazyThenUs expr cont
us
= let (result, us') = expr us in cont result us'
lazyThenUs
(USM
expr
)
cont
=
USM (\us ->
let (result, us') = expr us in
unUSM (
cont result
)
us'
)
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_
expr
cont
us
= case (expr us) of { (_, us') -> cont us' }
thenUs_
(USM expr) (USM
cont
)
=
USM (\us ->
case (expr us) of { (_, us') -> cont us' }
)
returnUs :: a -> UniqSM a
returnUs result us
=
(result, us)
returnUs result
= USM (\
us
->
(result, us)
)
withUs :: (UniqSupply -> (a, UniqSupply)) -> UniqSM a
withUs f us
=
f us -- Ha ha!
withUs f
= USM (\
us
->
f us
)
-- Ha ha!
getUs :: UniqSM UniqSupply
getUs us
=
splitUniqSupply us
getUs
= USM (\
us
->
splitUniqSupply us
)
getUniqueUs :: UniqSM Unique
getUniqueUs us
=
case splitUniqSupply us of
(us1,us2) -> (uniqFromSupply us1, us2)
getUniqueUs
= USM (\
us
->
case splitUniqSupply us of
(us1,us2) -> (uniqFromSupply us1, us2)
)
getUniquesUs :: UniqSM [Unique]
getUniquesUs us
=
case splitUniqSupply us of
(us1,us2) -> (uniqsFromSupply us1, us2)
getUniquesUs
= USM (\
us
->
case splitUniqSupply us of
(us1,us2) -> (uniqsFromSupply us1, us2)
)
\end{code}
\begin{code}
...
...
compiler/nativeGen/AsmCodeGen.lhs
View file @
0d7c6cea
...
...
@@ -309,17 +309,17 @@ reorder id accum (b@(block,id',out) : rest)
genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode cmm_top
initial_us
=
let
initial_
st = mkNatM_State initial_us 0
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_us = natm_us final_st
final_
delta
= natm_
delta
final_st
final_imports
= natm_
imports
final_st
in
if final_delta == 0
then
(
(new_tops, final_imports)
, final_us)
else pprPanic "genMachCode: nonzero final delta"
(int final_delta)
genMachCode cmm_top
=
do {
initial_
us <- getUs
; let initial_st = mkNatM_State initial_us 0
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_
us
= natm_
us
final_st
final_delta
= natm_
delta
final_st
f
in
al_imports = natm_imports final_st
;
if final_delta == 0
then
return
(new_tops, final_imports)
else pprPanic "genMachCode: nonzero final delta"
(int final_delta)
}
-- -----------------------------------------------------------------------------
-- Fixup assignments to global registers so that they assign to
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment