Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Alex D
GHC
Commits
39337a6d
Commit
39337a6d
authored
Jan 05, 2015
by
Simon Peyton Jones
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Remove redundant constraints in the compiler itself, found by -fwarn-redundant-constraints
parent
32973bf3
Changes
25
Hide whitespace changes
Inline
Side-by-side
Showing
25 changed files
with
79 additions
and
69 deletions
+79
-69
compiler/basicTypes/Name.hs
compiler/basicTypes/Name.hs
+2
-1
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmExpr.hs
+4
-4
compiler/cmm/Hoopl/Dataflow.hs
compiler/cmm/Hoopl/Dataflow.hs
+1
-1
compiler/coreSyn/TrieMap.hs
compiler/coreSyn/TrieMap.hs
+2
-2
compiler/deSugar/MatchLit.hs
compiler/deSugar/MatchLit.hs
+1
-1
compiler/ghci/ByteCodeItbls.hs
compiler/ghci/ByteCodeItbls.hs
+4
-2
compiler/ghci/Linker.hs
compiler/ghci/Linker.hs
+1
-1
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsDecls.hs
+3
-5
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExpr.hs
+4
-4
compiler/main/CmdLineParser.hs
compiler/main/CmdLineParser.hs
+1
-1
compiler/main/GHC.hs
compiler/main/GHC.hs
+7
-3
compiler/main/GhcMonad.hs
compiler/main/GhcMonad.hs
+13
-4
compiler/main/InteractiveEval.hs
compiler/main/InteractiveEval.hs
+1
-2
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+4
-7
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
+2
-2
compiler/nativeGen/SPARC/Base.hs
compiler/nativeGen/SPARC/Base.hs
+1
-1
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnMonad.hs
+2
-1
compiler/types/CoAxiom.hs
compiler/types/CoAxiom.hs
+1
-1
compiler/utils/Binary.hs
compiler/utils/Binary.hs
+1
-1
compiler/utils/GraphColor.hs
compiler/utils/GraphColor.hs
+3
-3
compiler/utils/GraphOps.hs
compiler/utils/GraphOps.hs
+10
-14
compiler/utils/GraphPpr.hs
compiler/utils/GraphPpr.hs
+4
-5
compiler/utils/Maybes.hs
compiler/utils/Maybes.hs
+4
-0
compiler/utils/Serialized.hs
compiler/utils/Serialized.hs
+2
-2
compiler/utils/UniqSet.hs
compiler/utils/UniqSet.hs
+1
-1
No files found.
compiler/basicTypes/Name.hs
View file @
39337a6d
...
...
@@ -564,11 +564,12 @@ getSrcLoc = nameSrcLoc . getName
getSrcSpan
=
nameSrcSpan
.
getName
getOccString
=
occNameString
.
getOccName
pprInfixName
,
pprPrefixName
::
(
Outputable
a
,
NamedThing
a
)
=>
a
->
SDoc
pprInfixName
::
(
Outputable
a
,
NamedThing
a
)
=>
a
->
SDoc
-- See Outputable.pprPrefixVar, pprInfixVar;
-- add parens or back-quotes as appropriate
pprInfixName
n
=
pprInfixVar
(
isSymOcc
(
getOccName
n
))
(
ppr
n
)
pprPrefixName
::
NamedThing
a
=>
a
->
SDoc
pprPrefixName
thing
|
name
`
hasKey
`
liftedTypeKindTyConKey
=
ppr
name
-- See Note [Special treatment for kind *]
...
...
compiler/cmm/CmmExpr.hs
View file @
39337a6d
...
...
@@ -280,15 +280,15 @@ type RegSet r = Set r
type
LocalRegSet
=
RegSet
LocalReg
type
GlobalRegSet
=
RegSet
GlobalReg
emptyRegSet
::
Ord
r
=>
RegSet
r
nullRegSet
::
Ord
r
=>
RegSet
r
->
Bool
emptyRegSet
::
RegSet
r
nullRegSet
::
RegSet
r
->
Bool
elemRegSet
::
Ord
r
=>
r
->
RegSet
r
->
Bool
extendRegSet
::
Ord
r
=>
RegSet
r
->
r
->
RegSet
r
deleteFromRegSet
::
Ord
r
=>
RegSet
r
->
r
->
RegSet
r
mkRegSet
::
Ord
r
=>
[
r
]
->
RegSet
r
minusRegSet
,
plusRegSet
,
timesRegSet
::
Ord
r
=>
RegSet
r
->
RegSet
r
->
RegSet
r
sizeRegSet
::
Ord
r
=>
RegSet
r
->
Int
regSetToList
::
Ord
r
=>
RegSet
r
->
[
r
]
sizeRegSet
::
RegSet
r
->
Int
regSetToList
::
RegSet
r
->
[
r
]
emptyRegSet
=
Set
.
empty
nullRegSet
=
Set
.
null
...
...
compiler/cmm/Hoopl/Dataflow.hs
View file @
39337a6d
...
...
@@ -763,7 +763,7 @@ normalizeGraph g = (mapGraphBlocks dropFact g, facts g)
exitFacts
(
JustO
(
DBlock
f
b
))
=
mapSingleton
(
entryLabel
b
)
f
bodyFacts
::
LabelMap
(
DBlock
f
n
C
C
)
->
FactBase
f
bodyFacts
body
=
mapFoldWithKey
f
noFacts
body
where
f
::
forall
t
a
x
.
(
NonLocal
t
)
=>
Label
->
DBlock
a
t
C
x
->
LabelMap
a
->
LabelMap
a
where
f
::
forall
t
a
x
.
Label
->
DBlock
a
t
C
x
->
LabelMap
a
->
LabelMap
a
f
lbl
(
DBlock
f
_
)
fb
=
mapInsert
lbl
f
fb
--- implementation of the constructors (boring)
...
...
compiler/coreSyn/TrieMap.hs
View file @
39337a6d
...
...
@@ -154,12 +154,12 @@ mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
mapMb
f
(
MM
{
mm_nothing
=
mn
,
mm_just
=
mj
})
=
MM
{
mm_nothing
=
fmap
f
mn
,
mm_just
=
mapTM
f
mj
}
lkMaybe
::
TrieMap
m
=>
(
forall
b
.
k
->
m
b
->
Maybe
b
)
lkMaybe
::
(
forall
b
.
k
->
m
b
->
Maybe
b
)
->
Maybe
k
->
MaybeMap
m
a
->
Maybe
a
lkMaybe
_
Nothing
=
mm_nothing
lkMaybe
lk
(
Just
x
)
=
mm_just
>.>
lk
x
xtMaybe
::
TrieMap
m
=>
(
forall
b
.
k
->
XT
b
->
m
b
->
m
b
)
xtMaybe
::
(
forall
b
.
k
->
XT
b
->
m
b
->
m
b
)
->
Maybe
k
->
XT
a
->
MaybeMap
m
a
->
MaybeMap
m
a
xtMaybe
_
Nothing
f
m
=
m
{
mm_nothing
=
f
(
mm_nothing
m
)
}
xtMaybe
tr
(
Just
x
)
f
m
=
m
{
mm_just
=
mm_just
m
|>
tr
x
f
}
...
...
compiler/deSugar/MatchLit.hs
View file @
39337a6d
...
...
@@ -394,7 +394,7 @@ hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
hsLitKey
_
l
=
pprPanic
"hsLitKey"
(
ppr
l
)
---------------------------
hsOverLitKey
::
OutputableBndr
a
=>
HsOverLit
a
->
Bool
->
Literal
hsOverLitKey
::
HsOverLit
a
->
Bool
->
Literal
-- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey
(
OverLit
{
ol_val
=
l
})
neg
=
litValKey
l
neg
...
...
compiler/ghci/ByteCodeItbls.hs
View file @
39337a6d
...
...
@@ -235,12 +235,14 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
arch
->
panic
(
"mkJumpToAddr not defined for "
++
show
arch
)
byte0
,
byte1
,
byte2
,
byte3
::
(
Integral
w
,
Bits
w
)
=>
w
->
Word8
byte0
::
(
Integral
w
)
=>
w
->
Word8
byte0
w
=
fromIntegral
w
byte1
,
byte2
,
byte3
,
byte4
,
byte5
,
byte6
,
byte7
::
(
Integral
w
,
Bits
w
)
=>
w
->
Word8
byte1
w
=
fromIntegral
(
w
`
shiftR
`
8
)
byte2
w
=
fromIntegral
(
w
`
shiftR
`
16
)
byte3
w
=
fromIntegral
(
w
`
shiftR
`
24
)
byte4
,
byte5
,
byte6
,
byte7
::
(
Integral
w
,
Bits
w
)
=>
w
->
Word8
byte4
w
=
fromIntegral
(
w
`
shiftR
`
32
)
byte5
w
=
fromIntegral
(
w
`
shiftR
`
40
)
byte6
w
=
fromIntegral
(
w
`
shiftR
`
48
)
...
...
compiler/ghci/Linker.hs
View file @
39337a6d
...
...
@@ -199,7 +199,7 @@ linkDependencies hsc_env pls span needed_mods = do
-- | Temporarily extend the linker state.
withExtendedLinkEnv
::
(
MonadIO
m
,
ExceptionMonad
m
)
=>
withExtendedLinkEnv
::
(
ExceptionMonad
m
)
=>
[(
Name
,
HValue
)]
->
m
a
->
m
a
withExtendedLinkEnv
new_env
action
=
gbracket
(
liftIO
$
extendLinkEnv
new_env
)
...
...
compiler/hsSyn/HsDecls.hs
View file @
39337a6d
...
...
@@ -601,12 +601,10 @@ isDataFamilyDecl _other = False
-- Dealing with names
tyFamInstDeclName
::
OutputableBndr
name
=>
TyFamInstDecl
name
->
name
tyFamInstDeclName
::
TyFamInstDecl
name
->
name
tyFamInstDeclName
=
unLoc
.
tyFamInstDeclLName
tyFamInstDeclLName
::
OutputableBndr
name
=>
TyFamInstDecl
name
->
Located
name
tyFamInstDeclLName
::
TyFamInstDecl
name
->
Located
name
tyFamInstDeclLName
(
TyFamInstDecl
{
tfid_eqn
=
(
L
_
(
TyFamEqn
{
tfe_tycon
=
ln
}))
})
=
ln
...
...
@@ -618,7 +616,7 @@ tyClDeclLName decl = tcdLName decl
tcdName
::
TyClDecl
name
->
name
tcdName
=
unLoc
.
tyClDeclLName
tyClDeclTyVars
::
OutputableBndr
name
=>
TyClDecl
name
->
LHsTyVarBndrs
name
tyClDeclTyVars
::
TyClDecl
name
->
LHsTyVarBndrs
name
tyClDeclTyVars
(
FamDecl
{
tcdFam
=
FamilyDecl
{
fdTyVars
=
tvs
}
})
=
tvs
tyClDeclTyVars
d
=
tcdTyVars
d
...
...
compiler/hsSyn/HsExpr.hs
View file @
39337a6d
...
...
@@ -1064,14 +1064,14 @@ pprMatch ctxt (Match pats maybe_ty grhss)
Nothing
->
empty
pprGRHSs
::
(
OutputableBndr
id
L
,
OutputableBndr
id
R
,
Outputable
body
)
pprGRHSs
::
(
OutputableBndr
idR
,
Outputable
body
)
=>
HsMatchContext
idL
->
GRHSs
idR
body
->
SDoc
pprGRHSs
ctxt
(
GRHSs
grhss
binds
)
=
vcat
(
map
(
pprGRHS
ctxt
.
unLoc
)
grhss
)
$$
ppUnless
(
isEmptyLocalBinds
binds
)
(
text
"where"
$$
nest
4
(
pprBinds
binds
))
pprGRHS
::
(
OutputableBndr
id
L
,
OutputableBndr
id
R
,
Outputable
body
)
pprGRHS
::
(
OutputableBndr
idR
,
Outputable
body
)
=>
HsMatchContext
idL
->
GRHS
idR
body
->
SDoc
pprGRHS
ctxt
(
GRHS
[]
body
)
=
pp_rhs
ctxt
body
...
...
@@ -1355,8 +1355,8 @@ In any other context than 'MonadComp', the fields for most of these
'SyntaxExpr's stay bottom.
-}
instance
(
OutputableBndr
idL
,
OutputableBndr
idR
)
=>
Outputable
(
ParStmtBlock
idL
idR
)
where
instance
(
OutputableBndr
idL
)
=>
Outputable
(
ParStmtBlock
idL
idR
)
where
ppr
(
ParStmtBlock
stmts
_
_
)
=
interpp'SP
stmts
instance
(
OutputableBndr
idL
,
OutputableBndr
idR
,
Outputable
body
)
...
...
compiler/main/CmdLineParser.hs
View file @
39337a6d
...
...
@@ -108,7 +108,7 @@ instance Monad m => Monad (EwM m) where
unEwM
(
k
r
)
l
e'
w'
)
return
v
=
EwM
(
\
_
e
w
->
return
(
e
,
w
,
v
))
setArg
::
Monad
m
=>
Located
String
->
EwM
m
()
->
EwM
m
()
setArg
::
Located
String
->
EwM
m
()
->
EwM
m
()
setArg
l
(
EwM
f
)
=
EwM
(
\
_
es
ws
->
f
l
es
ws
)
addErr
::
Monad
m
=>
String
->
EwM
m
()
...
...
compiler/main/GHC.hs
View file @
39337a6d
...
...
@@ -345,7 +345,7 @@ import Prelude hiding (init)
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
defaultErrorHandler
::
(
ExceptionMonad
m
,
MonadIO
m
)
defaultErrorHandler
::
(
ExceptionMonad
m
)
=>
FatalMessager
->
FlushOut
->
m
a
->
m
a
defaultErrorHandler
fm
(
FlushOut
flushOut
)
inner
=
-- top-level exception handler: any unrecognised exception is a compiler bug.
...
...
@@ -386,7 +386,7 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
-- a GHC run. This is separate from 'defaultErrorHandler', because you might
-- want to override the error handling, but still get the ordinary cleanup
-- behaviour.
defaultCleanupHandler
::
(
ExceptionMonad
m
,
MonadIO
m
)
=>
defaultCleanupHandler
::
(
ExceptionMonad
m
)
=>
DynFlags
->
m
a
->
m
a
defaultCleanupHandler
dflags
inner
=
-- make sure we clean up after ourselves
...
...
@@ -432,7 +432,11 @@ runGhc mb_top_dir ghc = do
-- to this function will create a new session which should not be shared among
-- several threads.
runGhcT
::
(
ExceptionMonad
m
,
Functor
m
,
MonadIO
m
)
=>
#
if
__GLASGOW_HASKELL__
<
710
runGhcT
::
(
ExceptionMonad
m
,
Functor
m
)
=>
#
else
runGhcT
::
(
ExceptionMonad
m
)
=>
#
endif
Maybe
FilePath
-- ^ See argument to 'initGhcMonad'.
->
GhcT
m
a
-- ^ The action to perform.
->
m
a
...
...
compiler/main/GhcMonad.hs
View file @
39337a6d
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE
CPP,
RankNTypes #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- -----------------------------------------------------------------------------
--
...
...
@@ -156,7 +156,8 @@ reifyGhc act = Ghc $ act
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype
GhcT
m
a
=
GhcT
{
unGhcT
::
Session
->
m
a
}
liftGhcT
::
Monad
m
=>
m
a
->
GhcT
m
a
liftGhcT
::
m
a
->
GhcT
m
a
liftGhcT
m
=
GhcT
$
\
_
->
m
instance
Functor
m
=>
Functor
(
GhcT
m
)
where
...
...
@@ -183,10 +184,18 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where
in
unGhcT
(
f
g_restore
)
s
instance
(
Functor
m
,
ExceptionMonad
m
,
MonadIO
m
)
=>
HasDynFlags
(
GhcT
m
)
where
#
if
__GLASGOW_HASKELL__
<
710
instance
(
ExceptionMonad
m
,
Functor
m
)
=>
HasDynFlags
(
GhcT
m
)
where
#
else
instance
(
ExceptionMonad
m
)
=>
HasDynFlags
(
GhcT
m
)
where
#
endif
getDynFlags
=
getSessionDynFlags
instance
(
Functor
m
,
ExceptionMonad
m
,
MonadIO
m
)
=>
GhcMonad
(
GhcT
m
)
where
#
if
__GLASGOW_HASKELL__
<
710
instance
(
ExceptionMonad
m
,
Functor
m
)
=>
GhcMonad
(
GhcT
m
)
where
#
else
instance
(
ExceptionMonad
m
)
=>
GhcMonad
(
GhcT
m
)
where
#
endif
getSession
=
GhcT
$
\
(
Session
r
)
->
liftIO
$
readIORef
r
setSession
s'
=
GhcT
$
\
(
Session
r
)
->
liftIO
$
writeIORef
r
s'
...
...
compiler/main/InteractiveEval.hs
View file @
39337a6d
...
...
@@ -75,7 +75,6 @@ import BreakArray
import
RtClosureInspect
import
Outputable
import
FastString
import
MonadUtils
import
System.Mem.Weak
import
System.Directory
...
...
@@ -427,7 +426,7 @@ rethrow dflags io = Exception.catch io $ \se -> do
-- resets everything when the computation has stopped running. This
-- is a not-very-good way to ensure that only the interactive
-- evaluation should generate breakpoints.
withBreakAction
::
(
ExceptionMonad
m
,
MonadIO
m
)
=>
withBreakAction
::
(
ExceptionMonad
m
)
=>
Bool
->
DynFlags
->
MVar
()
->
MVar
Status
->
m
a
->
m
a
withBreakAction
step
dflags
breakMVar
statusMVar
act
=
gbracket
(
liftIO
setBreakAction
)
(
liftIO
.
resetBreakAction
)
(
\
_
->
act
)
...
...
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
View file @
39337a6d
...
...
@@ -543,7 +543,7 @@ addAssoc a b m
-- | Delete all associations to a node.
delAssoc
::
(
Outputable
a
,
Uniquable
a
)
delAssoc
::
(
Uniquable
a
)
=>
a
->
Assoc
a
->
Assoc
a
delAssoc
a
m
...
...
@@ -566,7 +566,7 @@ delAssoc1 a b m
-- | Check if these two things are associated.
elemAssoc
::
(
Outputable
a
,
Uniquable
a
)
elemAssoc
::
(
Uniquable
a
)
=>
a
->
a
->
Assoc
a
->
Bool
elemAssoc
a
b
m
...
...
@@ -574,7 +574,7 @@ elemAssoc a b m
-- | Find the refl. trans. closure of the association from this point.
closeAssoc
::
(
Outputable
a
,
Uniquable
a
)
closeAssoc
::
(
Uniquable
a
)
=>
a
->
Assoc
a
->
UniqSet
a
closeAssoc
a
assoc
...
...
@@ -604,10 +604,7 @@ closeAssoc a assoc
(
unionUniqSets
toVisit
neighbors
)
-- | Intersect two associations.
intersectAssoc
::
Uniquable
a
=>
Assoc
a
->
Assoc
a
->
Assoc
a
intersectAssoc
::
Assoc
a
->
Assoc
a
->
Assoc
a
intersectAssoc
a
b
=
intersectUFM_C
(
intersectUniqSets
)
a
b
compiler/nativeGen/RegAlloc/Linear/Main.hs
View file @
39337a6d
...
...
@@ -606,7 +606,7 @@ releaseRegs regs = do
--
saveClobberedTemps
::
(
Outputable
instr
,
Instruction
instr
,
FR
freeRegs
)
::
(
Instruction
instr
,
FR
freeRegs
)
=>
[
RealReg
]
-- real registers clobbered by this instruction
->
[
Reg
]
-- registers which are no longer live after this insn
->
RegM
freeRegs
[
instr
]
-- return: instructions to spill any temps that will
...
...
@@ -873,7 +873,7 @@ newLocation _ my_reg = InReg my_reg
-- | Load up a spilled temporary if we need to (read from memory).
loadTemp
::
(
Outputable
instr
,
Instruction
instr
)
::
(
Instruction
instr
)
=>
VirtualReg
-- the temp being loaded
->
SpillLoc
-- the current location of this temp
->
RealReg
-- the hreg to load the temp into
...
...
compiler/nativeGen/SPARC/Base.hs
View file @
39337a6d
...
...
@@ -66,7 +66,7 @@ is32BitInteger i
-- | Sadness.
largeOffsetError
::
(
Integral
a
,
Show
a
)
=>
a
->
b
largeOffsetError
::
(
Show
a
)
=>
a
->
b
largeOffsetError
i
=
panic
(
"ERROR: SPARC native-code generator cannot handle large offset ("
++
show
i
++
");
\n
probably because of large constant data structures;"
++
...
...
compiler/typecheck/TcRnMonad.hs
View file @
39337a6d
...
...
@@ -893,10 +893,11 @@ failIfErrsM :: TcRn ()
-- Useful to avoid error cascades
failIfErrsM
=
ifErrsM
failM
(
return
()
)
checkTH
::
Outputable
a
=>
a
->
String
->
TcRn
()
#
ifdef
GHCI
checkTH
::
a
->
String
->
TcRn
()
checkTH
_
_
=
return
()
-- OK
#
else
checkTH
::
Outputable
a
=>
a
->
String
->
TcRn
()
checkTH
e
what
=
failTH
e
what
-- Raise an error in a stage-1 compiler
#
endif
...
...
compiler/types/CoAxiom.hs
View file @
39337a6d
...
...
@@ -184,7 +184,7 @@ brListFoldlM_ :: forall a b m br. Monad m
=>
(
a
->
b
->
m
a
)
->
a
->
BranchList
b
br
->
m
()
brListFoldlM_
f
z
brs
=
do
{
_
<-
go
z
brs
;
return
()
}
where
go
::
forall
br'
.
Monad
m
=>
a
->
BranchList
b
br'
->
m
a
where
go
::
forall
br'
.
a
->
BranchList
b
br'
->
m
a
go
acc
(
FirstBranch
b
)
=
f
acc
b
go
acc
(
NextBranch
h
t
)
=
do
{
fh
<-
f
acc
h
;
go
fh
t
}
...
...
compiler/utils/Binary.hs
View file @
39337a6d
...
...
@@ -549,7 +549,7 @@ writeByteArray arr i (W8# w) = IO $ \s ->
indexByteArray
::
ByteArray
#
->
Int
#
->
Word8
indexByteArray
a
#
n
#
=
W8
#
(
indexWord8Array
#
a
#
n
#
)
instance
(
Integral
a
,
Binary
a
)
=>
Binary
(
Ratio
a
)
where
instance
(
Binary
a
)
=>
Binary
(
Ratio
a
)
where
put_
bh
(
a
:%
b
)
=
do
put_
bh
a
;
put_
bh
b
get
bh
=
do
a
<-
get
bh
;
b
<-
get
bh
;
return
(
a
:%
b
)
...
...
compiler/utils/GraphColor.hs
View file @
39337a6d
...
...
@@ -34,7 +34,7 @@ import Data.List
--
colorGraph
::
(
Uniquable
k
,
Uniquable
cls
,
Uniquable
color
,
Eq
c
olor
,
Eq
c
ls
,
Ord
k
,
Eq
cls
,
Ord
k
,
Outputable
k
,
Outputable
cls
,
Outputable
color
)
=>
Bool
-- ^ whether to do iterative coalescing
->
Int
-- ^ how many times we've tried to color this graph so far.
...
...
@@ -250,7 +250,7 @@ colorScan_spill iterative triv spill graph
assignColors
::
(
Uniquable
k
,
Uniquable
cls
,
Uniquable
color
,
Eq
color
,
Outputable
cls
)
,
Outputable
cls
)
=>
UniqFM
(
UniqSet
color
)
-- ^ map of (node class -> set of colors available for this class).
->
Graph
k
cls
color
-- ^ the graph
->
[
k
]
-- ^ nodes to assign a color to.
...
...
@@ -288,7 +288,7 @@ assignColors colors graph ks
--
selectColor
::
(
Uniquable
k
,
Uniquable
cls
,
Uniquable
color
,
Eq
color
,
Outputable
cls
)
,
Outputable
cls
)
=>
UniqFM
(
UniqSet
color
)
-- ^ map of (node class -> set of colors available for this class).
->
Graph
k
cls
color
-- ^ the graph
->
k
-- ^ key of the node to select a color for.
...
...
compiler/utils/GraphOps.hs
View file @
39337a6d
...
...
@@ -76,7 +76,7 @@ addNode k node graph
-- | Delete a node and all its edges from the graph.
delNode
::
(
Uniquable
k
,
Outputable
k
)
delNode
::
(
Uniquable
k
)
=>
k
->
Graph
k
cls
color
->
Maybe
(
Graph
k
cls
color
)
delNode
k
graph
...
...
@@ -119,16 +119,14 @@ modNode f k graph
-- | Get the size of the graph, O(n)
size
::
Uniquable
k
=>
Graph
k
cls
color
->
Int
size
::
Graph
k
cls
color
->
Int
size
graph
=
sizeUFM
$
graphMap
graph
-- | Union two graphs together.
union
::
Uniquable
k
=>
Graph
k
cls
color
->
Graph
k
cls
color
->
Graph
k
cls
color
union
::
Graph
k
cls
color
->
Graph
k
cls
color
->
Graph
k
cls
color
union
graph1
graph2
=
Graph
...
...
@@ -333,7 +331,7 @@ coalesceGraph' aggressive triv graph kkPairsAcc
-- Nothing if either of the nodes weren't in the graph
coalesceNodes
::
(
Uniquable
k
,
Ord
k
,
Eq
cls
,
Outputable
k
)
::
(
Uniquable
k
,
Ord
k
,
Eq
cls
)
=>
Bool
-- ^ If True, coalesce nodes even if this might make the graph
-- less colorable (aggressive coalescing)
->
Triv
k
cls
color
...
...
@@ -364,7 +362,7 @@ coalesceNodes aggressive triv graph (k1, k2)
=
(
graph
,
Nothing
)
coalesceNodes_merge
::
(
Uniquable
k
,
Ord
k
,
Eq
cls
,
Outputable
k
)
::
(
Uniquable
k
,
Eq
cls
)
=>
Bool
->
Triv
k
cls
color
->
Graph
k
cls
color
...
...
@@ -410,7 +408,7 @@ coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
in
coalesceNodes_check
aggressive
triv
graph
kMin
kMax
node
coalesceNodes_check
::
(
Uniquable
k
,
Ord
k
,
Eq
cls
,
Outputable
k
)
::
Uniquable
k
=>
Bool
->
Triv
k
cls
color
->
Graph
k
cls
color
...
...
@@ -483,7 +481,7 @@ freezeNode k
-- right here, and add it to a worklist if known triv\/non-move nodes.
--
freezeOneInGraph
::
(
Uniquable
k
,
Outputable
k
)
::
(
Uniquable
k
)
=>
Graph
k
cls
color
->
(
Graph
k
cls
color
-- the new graph
,
Bool
)
-- whether we found a node to freeze
...
...
@@ -512,7 +510,7 @@ freezeOneInGraph graph
-- for debugging the iterative allocator.
--
freezeAllInGraph
::
(
Uniquable
k
,
Outputable
k
)
::
(
Uniquable
k
)
=>
Graph
k
cls
color
->
Graph
k
cls
color
...
...
@@ -525,8 +523,7 @@ freezeAllInGraph graph
-- | Find all the nodes in the graph that meet some criteria
--
scanGraph
::
Uniquable
k
=>
(
Node
k
cls
color
->
Bool
)
::
(
Node
k
cls
color
->
Bool
)
->
Graph
k
cls
color
->
[
Node
k
cls
color
]
...
...
@@ -611,8 +608,7 @@ checkNode graph node
-- | Slurp out a map of how many nodes had a certain number of conflict neighbours
slurpNodeConflictCount
::
Uniquable
k
=>
Graph
k
cls
color
::
Graph
k
cls
color
->
UniqFM
(
Int
,
Int
)
-- ^ (conflict neighbours, num nodes with that many conflicts)
slurpNodeConflictCount
graph
...
...
compiler/utils/GraphPpr.hs
View file @
39337a6d
...
...
@@ -20,7 +20,7 @@ import Data.Maybe
-- | Pretty print a graph in a somewhat human readable format.
dumpGraph
::
(
Outputable
k
,
Outputable
c
ls
,
Outputable
c
olor
)
::
(
Outputable
k
,
Outputable
color
)
=>
Graph
k
cls
color
->
SDoc
dumpGraph
graph
...
...
@@ -28,7 +28,7 @@ dumpGraph graph
$$
(
vcat
$
map
dumpNode
$
eltsUFM
$
graphMap
graph
)
dumpNode
::
(
Outputable
k
,
Outputable
c
ls
,
Outputable
c
olor
)
::
(
Outputable
k
,
Outputable
color
)
=>
Node
k
cls
color
->
SDoc
dumpNode
node
...
...
@@ -74,8 +74,7 @@ dotGraph colorMap triv graph
,
space
])
dotNode
::
(
Uniquable
k
,
Outputable
k
,
Outputable
cls
,
Outputable
color
)
dotNode
::
(
Outputable
k
,
Outputable
cls
,
Outputable
color
)
=>
(
color
->
SDoc
)
->
Triv
k
cls
color
->
Node
k
cls
color
->
SDoc
...
...
@@ -132,7 +131,7 @@ dotNode colorMap triv node
dotNodeEdges
::
(
Uniquable
k
,
Outputable
k
,
Outputable
cls
,
Outputable
color
)
,
Outputable
k
)
=>
UniqSet
k
->
Node
k
cls
color
->
(
UniqSet
k
,
Maybe
SDoc
)
...
...
compiler/utils/Maybes.hs
View file @
39337a6d
...
...
@@ -67,7 +67,11 @@ newtype MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)}
instance
Functor
m
=>
Functor
(
MaybeT
m
)
where
fmap
f
x
=
MaybeT
$
fmap
(
fmap
f
)
$
runMaybeT
x
#
if
__GLASGOW_HASKELL__
<
710
instance
(
Monad
m
,
Functor
m
)
=>
Applicative
(
MaybeT
m
)
where
#
else
instance
(
Monad
m
)
=>
Applicative
(
MaybeT
m
)
where
#
endif
pure
=
return
(
<*>
)
=
ap
...
...
compiler/utils/Serialized.hs
View file @
39337a6d
...
...
@@ -100,7 +100,7 @@ deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
serializeFixedWidthNum
::
forall
a
.
(
Num
a
,
Integral
a
,
Bits
a
)
=>
a
->
[
Word8
]
->
[
Word8
]
serializeFixedWidthNum
what
=
go
(
bitSize
what
)
what
#
else
serializeFixedWidthNum
::
forall
a
.
(
Num
a
,
Integral
a
,
FiniteBits
a
)
=>
a
->
[
Word8
]
->
[
Word8
]
serializeFixedWidthNum
::
forall
a
.
(
Integral
a
,
FiniteBits
a
)
=>
a
->
[
Word8
]
->
[
Word8
]
serializeFixedWidthNum
what
=
go
(
finiteBitSize
what
)
what
#
endif
where
...
...
@@ -113,7 +113,7 @@ serializeFixedWidthNum what = go (finiteBitSize what) what
deserializeFixedWidthNum
::
forall
a
b
.
(
Num
a
,
Integral
a
,
Bits
a
)
=>
[
Word8
]
->
(
a
->
[
Word8
]
->
b
)
->
b
deserializeFixedWidthNum
bytes
k
=
go
(
bitSize
(
undefined
::
a
))
bytes
k
#
else
deserializeFixedWidthNum
::
forall
a
b
.
(
Num
a
,
Integral
a
,
FiniteBits
a
)
=>
[
Word8
]
->
(
a
->
[
Word8
]
->
b
)
->
b
deserializeFixedWidthNum
::
forall
a
b
.
(
Integral
a
,
FiniteBits
a
)
=>
[
Word8
]
->
(
a
->
[
Word8
]
->
b
)
->
b
deserializeFixedWidthNum
bytes
k
=
go
(
finiteBitSize
(
undefined
::
a
))
bytes
k
#
endif
where
...
...
compiler/utils/UniqSet.hs
View file @
39337a6d
...
...
@@ -54,7 +54,7 @@ addOneToUniqSet_C :: Uniquable a => (a -> a -> a) -> UniqSet a -> a -> UniqSet a
addListToUniqSet
::
Uniquable
a
=>
UniqSet
a
->
[
a
]
->
UniqSet
a
delOneFromUniqSet
::
Uniquable
a
=>
UniqSet
a
->
a
->
UniqSet
a
delOneFromUniqSet_Directly
::
Uniq
uable
a
=>
Uniq
Set
a
->
Unique
->
UniqSet
a
delOneFromUniqSet_Directly
::
UniqSet
a
->
Unique
->
UniqSet
a
delListFromUniqSet
::
Uniquable
a
=>
UniqSet
a
->
[
a
]
->
UniqSet
a
unionUniqSets
::
UniqSet
a
->
UniqSet
a
->
UniqSet
a
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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