Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
aaff8766
Commit
aaff8766
authored
Apr 24, 2012
by
Simon Peyton Jones
Browse files
Merge branch 'master' of
http://darcs.haskell.org/ghc
parents
05debbb4
09037d92
Changes
13
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmMachOp.hs
View file @
aaff8766
...
...
@@ -442,6 +442,7 @@ data CallishMachOp
|
MO_S_QuotRem
Width
|
MO_U_QuotRem
Width
|
MO_U_QuotRem2
Width
|
MO_Add2
Width
|
MO_U_Mul2
Width
...
...
compiler/cmm/PprC.hs
View file @
aaff8766
...
...
@@ -661,11 +661,12 @@ pprCallishMachOp_for_C mop
MO_Memmove
->
ptext
(
sLit
"memmove"
)
(
MO_PopCnt
w
)
->
ptext
(
sLit
$
popCntLabel
w
)
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_Touch
->
unsupported
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_U_QuotRem2
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_Touch
->
unsupported
where
unsupported
=
panic
(
"pprCallishMachOp_for_C: "
++
show
mop
++
" not supported!"
)
...
...
compiler/codeGen/CgPrimOp.hs
View file @
aaff8766
...
...
@@ -468,6 +468,59 @@ emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
CmmHinted
arg_y
NoHint
]
CmmMayReturn
in
stmtC
stmt
emitPrimOp
[
res_q
,
res_r
]
WordQuotRem2Op
[
arg_x_high
,
arg_x_low
,
arg_y
]
_
=
do
let
ty
=
cmmExprType
arg_x_high
shl
x
i
=
CmmMachOp
(
MO_Shl
wordWidth
)
[
x
,
i
]
shr
x
i
=
CmmMachOp
(
MO_U_Shr
wordWidth
)
[
x
,
i
]
or
x
y
=
CmmMachOp
(
MO_Or
wordWidth
)
[
x
,
y
]
ge
x
y
=
CmmMachOp
(
MO_U_Ge
wordWidth
)
[
x
,
y
]
ne
x
y
=
CmmMachOp
(
MO_Ne
wordWidth
)
[
x
,
y
]
minus
x
y
=
CmmMachOp
(
MO_Sub
wordWidth
)
[
x
,
y
]
times
x
y
=
CmmMachOp
(
MO_Mul
wordWidth
)
[
x
,
y
]
zero
=
lit
0
one
=
lit
1
negone
=
lit
(
fromIntegral
(
widthInBits
wordWidth
)
-
1
)
lit
i
=
CmmLit
(
CmmInt
i
wordWidth
)
f
::
Int
->
CmmExpr
->
CmmExpr
->
CmmExpr
->
FCode
[
CmmStmt
]
f
0
acc
high
_
=
return
[
CmmAssign
(
CmmLocal
res_q
)
acc
,
CmmAssign
(
CmmLocal
res_r
)
high
]
f
i
acc
high
low
=
do
roverflowedBit
<-
newLocalReg
ty
rhigh'
<-
newLocalReg
ty
rhigh''
<-
newLocalReg
ty
rlow'
<-
newLocalReg
ty
risge
<-
newLocalReg
ty
racc'
<-
newLocalReg
ty
let
high'
=
CmmReg
(
CmmLocal
rhigh'
)
isge
=
CmmReg
(
CmmLocal
risge
)
overflowedBit
=
CmmReg
(
CmmLocal
roverflowedBit
)
let
this
=
[
CmmAssign
(
CmmLocal
roverflowedBit
)
(
shr
high
negone
),
CmmAssign
(
CmmLocal
rhigh'
)
(
or
(
shl
high
one
)
(
shr
low
negone
)),
CmmAssign
(
CmmLocal
rlow'
)
(
shl
low
one
),
CmmAssign
(
CmmLocal
risge
)
(
or
(
overflowedBit
`
ne
`
zero
)
(
high'
`
ge
`
arg_y
)),
CmmAssign
(
CmmLocal
rhigh''
)
(
high'
`
minus
`
(
arg_y
`
times
`
isge
)),
CmmAssign
(
CmmLocal
racc'
)
(
or
(
shl
acc
one
)
isge
)]
rest
<-
f
(
i
-
1
)
(
CmmReg
(
CmmLocal
racc'
))
(
CmmReg
(
CmmLocal
rhigh''
))
(
CmmReg
(
CmmLocal
rlow'
))
return
(
this
++
rest
)
genericImpl
<-
f
(
widthInBits
wordWidth
)
zero
arg_x_high
arg_x_low
let
stmt
=
CmmCall
(
CmmPrim
(
MO_U_QuotRem2
wordWidth
)
(
Just
genericImpl
))
[
CmmHinted
res_q
NoHint
,
CmmHinted
res_r
NoHint
]
[
CmmHinted
arg_x_high
NoHint
,
CmmHinted
arg_x_low
NoHint
,
CmmHinted
arg_y
NoHint
]
CmmMayReturn
stmtC
stmt
emitPrimOp
[
res_h
,
res_l
]
WordAdd2Op
[
arg_x
,
arg_y
]
_
=
do
r1
<-
newLocalReg
(
cmmExprType
arg_x
)
r2
<-
newLocalReg
(
cmmExprType
arg_x
)
...
...
compiler/ghc.mk
View file @
aaff8766
...
...
@@ -27,8 +27,6 @@ endef
# The 'echo' commands simply spit the values of various make variables
# into Config.hs, whence they can be compiled and used by GHC itself
compiler_CONFIG_HS
=
compiler/main/Config.hs
# This is just to avoid generating a warning when generating deps
# involving RtsFlags.h
compiler_stage1_MKDEPENDC_OPTS
=
-DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES
...
...
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
View file @
aaff8766
...
...
@@ -473,12 +473,13 @@ cmmPrimOpFunctions env mop
(
MO_PopCnt
w
)
->
fsLit
$
"llvm.ctpop."
++
show
(
widthToLlvmInt
w
)
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_U_QuotRem2
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
where
intrinTy1
=
(
if
getLlvmVer
env
>=
28
...
...
compiler/nativeGen/PPC/CodeGen.hs
View file @
aaff8766
...
...
@@ -1145,12 +1145,13 @@ genCCall' gcp target dest_regs argsAndHints
MO_PopCnt
w
->
(
fsLit
$
popCntLabel
w
,
False
)
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_U_QuotRem2
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
unsupported
=
panic
(
"outOfLineCmmOp: "
++
show
mop
++
" not supported"
)
...
...
compiler/nativeGen/SPARC/CodeGen.hs
View file @
aaff8766
...
...
@@ -640,12 +640,13 @@ outOfLineMachOp_table mop
MO_PopCnt
w
->
fsLit
$
popCntLabel
w
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_U_QuotRem2
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
where
unsupported
=
panic
(
"outOfLineCmmOp: "
++
show
mop
++
" not supported here"
)
compiler/nativeGen/X86/CodeGen.hs
View file @
aaff8766
...
...
@@ -1676,8 +1676,9 @@ genCCall32 target dest_regs args =
=
panic
$
"genCCall32.actuallyInlineFloatOp: bad number of arguments! ("
++
show
(
length
args
)
++
")"
(
CmmPrim
(
MO_S_QuotRem
width
)
_
,
_
)
->
divOp
True
width
dest_regs
args
(
CmmPrim
(
MO_U_QuotRem
width
)
_
,
_
)
->
divOp
False
width
dest_regs
args
(
CmmPrim
(
MO_S_QuotRem
width
)
_
,
_
)
->
divOp1
True
width
dest_regs
args
(
CmmPrim
(
MO_U_QuotRem
width
)
_
,
_
)
->
divOp1
False
width
dest_regs
args
(
CmmPrim
(
MO_U_QuotRem2
width
)
_
,
_
)
->
divOp2
False
width
dest_regs
args
(
CmmPrim
(
MO_Add2
width
)
_
,
[
CmmHinted
res_h
_
,
CmmHinted
res_l
_
])
->
case
args
of
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
->
...
...
@@ -1712,8 +1713,18 @@ genCCall32 target dest_regs args =
_
->
genCCall32'
target
dest_regs
args
where
divOp
signed
width
[
CmmHinted
res_q
_
,
CmmHinted
res_r
_
]
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
where
divOp1
signed
width
results
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
=
divOp
signed
width
results
Nothing
arg_x
arg_y
divOp1
_
_
_
_
=
panic
"genCCall32: Wrong number of arguments for divOp1"
divOp2
signed
width
results
[
CmmHinted
arg_x_high
_
,
CmmHinted
arg_x_low
_
,
CmmHinted
arg_y
_
]
=
divOp
signed
width
results
(
Just
arg_x_high
)
arg_x_low
arg_y
divOp2
_
_
_
_
=
panic
"genCCall64: Wrong number of arguments for divOp2"
divOp
signed
width
[
CmmHinted
res_q
_
,
CmmHinted
res_r
_
]
m_arg_x_high
arg_x_low
arg_y
=
do
let
size
=
intSize
width
reg_q
=
getRegisterReg
True
(
CmmLocal
res_q
)
reg_r
=
getRegisterReg
True
(
CmmLocal
res_r
)
...
...
@@ -1722,15 +1733,20 @@ genCCall32 target dest_regs args =
instr
|
signed
=
IDIV
|
otherwise
=
DIV
(
y_reg
,
y_code
)
<-
getRegOrMem
arg_y
x_code
<-
getAnyReg
arg_x
x_low_code
<-
getAnyReg
arg_x_low
x_high_code
<-
case
m_arg_x_high
of
Just
arg_x_high
->
getAnyReg
arg_x_high
Nothing
->
return
$
const
$
unitOL
widen
return
$
y_code
`
appOL
`
x_code
rax
`
appOL
`
toOL
[
widen
,
instr
size
y_reg
,
x_
low_
code
rax
`
appOL
`
x_high_code
rdx
`
appOL
`
toOL
[
instr
size
y_reg
,
MOV
size
(
OpReg
rax
)
(
OpReg
reg_q
),
MOV
size
(
OpReg
rdx
)
(
OpReg
reg_r
)]
divOp
_
_
_
_
=
panic
"genCCall32: Wrong number of
arguments/
results for divOp"
divOp
_
_
_
_
_
_
=
panic
"genCCall32: Wrong number of results for divOp"
genCCall32'
::
CmmCallTarget
-- function to call
->
[
HintedCmmFormal
]
-- where to put the result
...
...
@@ -1896,8 +1912,9 @@ genCCall64 target dest_regs args =
-- we only cope with a single result for foreign calls
outOfLineCmmOp
op
(
Just
res
)
args
(
CmmPrim
(
MO_S_QuotRem
width
)
_
,
_
)
->
divOp
True
width
dest_regs
args
(
CmmPrim
(
MO_U_QuotRem
width
)
_
,
_
)
->
divOp
False
width
dest_regs
args
(
CmmPrim
(
MO_S_QuotRem
width
)
_
,
_
)
->
divOp1
True
width
dest_regs
args
(
CmmPrim
(
MO_U_QuotRem
width
)
_
,
_
)
->
divOp1
False
width
dest_regs
args
(
CmmPrim
(
MO_U_QuotRem2
width
)
_
,
_
)
->
divOp2
False
width
dest_regs
args
(
CmmPrim
(
MO_Add2
width
)
_
,
[
CmmHinted
res_h
_
,
CmmHinted
res_l
_
])
->
case
args
of
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
->
...
...
@@ -1935,8 +1952,18 @@ genCCall64 target dest_regs args =
let
platform
=
targetPlatform
dflags
genCCall64'
platform
target
dest_regs
args
where
divOp
signed
width
[
CmmHinted
res_q
_
,
CmmHinted
res_r
_
]
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
where
divOp1
signed
width
results
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
=
divOp
signed
width
results
Nothing
arg_x
arg_y
divOp1
_
_
_
_
=
panic
"genCCall64: Wrong number of arguments for divOp1"
divOp2
signed
width
results
[
CmmHinted
arg_x_high
_
,
CmmHinted
arg_x_low
_
,
CmmHinted
arg_y
_
]
=
divOp
signed
width
results
(
Just
arg_x_high
)
arg_x_low
arg_y
divOp2
_
_
_
_
=
panic
"genCCall64: Wrong number of arguments for divOp2"
divOp
signed
width
[
CmmHinted
res_q
_
,
CmmHinted
res_r
_
]
m_arg_x_high
arg_x_low
arg_y
=
do
let
size
=
intSize
width
reg_q
=
getRegisterReg
True
(
CmmLocal
res_q
)
reg_r
=
getRegisterReg
True
(
CmmLocal
res_r
)
...
...
@@ -1945,15 +1972,18 @@ genCCall64 target dest_regs args =
instr
|
signed
=
IDIV
|
otherwise
=
DIV
(
y_reg
,
y_code
)
<-
getRegOrMem
arg_y
x_code
<-
getAnyReg
arg_x
x_low_code
<-
getAnyReg
arg_x_low
x_high_code
<-
case
m_arg_x_high
of
Just
arg_x_high
->
getAnyReg
arg_x_high
Nothing
->
return
$
const
$
unitOL
widen
return
$
y_code
`
appOL
`
x_code
rax
`
appOL
`
toOL
[
widen
,
instr
size
y_reg
,
x_
low_
code
rax
`
appOL
`
x_high_code
rdx
`
appOL
`
toOL
[
instr
size
y_reg
,
MOV
size
(
OpReg
rax
)
(
OpReg
reg_q
),
MOV
size
(
OpReg
rdx
)
(
OpReg
reg_r
)]
divOp
_
_
_
_
=
panic
"genCCall64: Wrong number of
arguments/
results for divOp"
divOp
_
_
_
_
_
_
=
panic
"genCCall64: Wrong number of results for divOp"
genCCall64'
::
Platform
->
CmmCallTarget
-- function to call
...
...
@@ -2225,12 +2255,13 @@ outOfLineCmmOp mop res args
MO_PopCnt
_
->
fsLit
"popcnt"
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
MO_S_QuotRem
{}
->
unsupported
MO_U_QuotRem
{}
->
unsupported
MO_U_QuotRem2
{}
->
unsupported
MO_Add2
{}
->
unsupported
MO_U_Mul2
{}
->
unsupported
MO_WriteBarrier
->
unsupported
MO_Touch
->
unsupported
unsupported
=
panic
(
"outOfLineCmmOp: "
++
show
mop
++
"not supported here"
)
...
...
compiler/prelude/primops.txt.pp
View file @
aaff8766
...
...
@@ -269,6 +269,7 @@ primtype Word#
primop
WordAddOp
"
plusWord
#
"
Dyadic
Word
#
->
Word
#
->
Word
#
with
commutable
=
True
-- Returns (# high, low #) (or equivalently, (# carry, low #))
primop
WordAdd2Op
"
plusWord2
#
"
GenPrimOp
Word
#
->
Word
#
->
(#
Word
#,
Word
#
#)
with
commutable
=
True
...
...
@@ -278,6 +279,7 @@ primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word#
primop
WordMulOp
"
timesWord
#
"
Dyadic
Word
#
->
Word
#
->
Word
#
with
commutable
=
True
-- Returns (# high, low #)
primop
WordMul2Op
"
timesWord2
#
"
GenPrimOp
Word
#
->
Word
#
->
(#
Word
#,
Word
#
#)
with
commutable
=
True
...
...
@@ -292,6 +294,12 @@ primop WordQuotRemOp "quotRemWord#" GenPrimOp
Word
#
->
Word
#
->
(#
Word
#,
Word
#
#)
with
can_fail
=
True
-- Takes high word of dividend, then low word of dividend, then divisor.
-- Requires that high word is not divisible by divisor.
primop
WordQuotRem2Op
"
quotRemWord2
#
"
GenPrimOp
Word
#
->
Word
#
->
Word
#
->
(#
Word
#,
Word
#
#)
with
can_fail
=
True
primop
AndOp
"
and
#
"
Dyadic
Word
#
->
Word
#
->
Word
#
with
commutable
=
True
...
...
compiler/typecheck/FamInst.lhs
View file @
aaff8766
...
...
@@ -24,12 +24,11 @@ import TyCon
import DynFlags
import Name
import Module
import SrcLoc
import Outputable
import UniqFM
import VarSet
import FastString
import Util( filterOut )
import Util( filterOut
, sortWith
)
import Maybes
import Control.Monad
import Data.Map (Map)
...
...
@@ -308,15 +307,18 @@ checkForConflicts inst_envs fam_inst
conflictInstErr :: FamInst -> FamInst -> TcRn ()
conflictInstErr famInst conflictingFamInst
= addFamInstLoc famInst $
addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
2 (pprFamInsts [famInst, conflictingFamInst]))
addFamInstLoc :: FamInst -> TcRn a -> TcRn a
addFamInstLoc famInst thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc famInst
= addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
[famInst, conflictingFamInst]
addFamInstsErr :: SDoc -> [FamInst] -> TcRn ()
addFamInstsErr herald insts
= setSrcSpan (getSrcSpan (head sorted)) $
addErr (hang herald 2 (pprFamInsts sorted))
where
sorted = sortWith getSrcLoc insts
-- The sortWith just arranges that instances are dislayed in order
-- of source location, which reduced wobbling in error messages,
-- and is better for users
tcGetFamInstEnvs :: TcM FamInstEnvs
-- Gets both the external-package inst-env
...
...
compiler/typecheck/Inst.lhs
View file @
aaff8766
...
...
@@ -474,25 +474,28 @@ traceDFuns ispecs
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr ispec ispecs
= add
DictLoc ispec $
addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:")
)
2 (pprInstances (ispec:ispecs)))
= add
ClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
(ispec : ispecs
)
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr ispec dup_ispec
= add
DictLoc ispec $
addErr (hang (ptext (sLit "Duplicate instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
= add
ClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
[ispec, dup_ispec]
overlappingInstErr :: ClsInst -> ClsInst -> TcRn ()
overlappingInstErr ispec dup_ispec
= addDictLoc ispec $
addErr (hang (ptext (sLit "Overlapping instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
addDictLoc :: ClsInst -> TcRn a -> TcRn a
addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc ispec
= addClsInstsErr (ptext (sLit "Overlapping instance declarations:"))
[ispec, dup_ispec]
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr herald ispecs
= setSrcSpan (getSrcSpan (head sorted)) $
addErr (hang herald 2 (pprInstances sorted))
where
sorted = sortWith getSrcLoc ispecs
-- The sortWith just arranges that instances are dislayed in order
-- of source location, which reduced wobbling in error messages,
-- and is better for users
\end{code}
%************************************************************************
...
...
compiler/types/InstEnv.lhs
View file @
aaff8766
...
...
@@ -34,7 +34,6 @@ import BasicTypes
import UniqFM
import Id
import FastString
import Data.Data ( Data, Typeable )
import Data.Maybe ( isJust, isNothing )
\end{code}
...
...
ghc/InteractiveUI.hs
View file @
aaff8766
...
...
@@ -2837,14 +2837,16 @@ showException :: SomeException -> GHCi ()
showException
se
=
liftIO
$
case
fromException
se
of
-- omit the location for CmdLineError:
Just
(
CmdLineError
s
)
->
put
StrL
n
s
Just
(
CmdLineError
s
)
->
put
Exceptio
n
s
-- ditto:
Just
ph
@
(
PhaseFailed
{})
->
put
StrL
n
(
showGhcException
ph
""
)
Just
other_ghc_ex
->
p
rint
other_ghc_ex
Just
ph
@
(
PhaseFailed
{})
->
put
Exceptio
n
(
showGhcException
ph
""
)
Just
other_ghc_ex
->
p
utException
(
show
other_ghc_ex
)
Nothing
->
case
fromException
se
of
Just
UserInterrupt
->
putStrLn
"Interrupted."
_
->
putStrLn
(
"*** Exception: "
++
show
se
)
Just
UserInterrupt
->
putException
"Interrupted."
_
->
putException
(
"*** Exception: "
++
show
se
)
where
putException
=
hPutStrLn
stderr
-----------------------------------------------------------------------------
...
...
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