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
2304a362
Commit
2304a362
authored
Feb 27, 2012
by
Ian Lynagh
Browse files
Fix the unregisterised build; fixes
#5901
parent
a3523855
Changes
12
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmExpr.hs
View file @
2304a362
...
...
@@ -217,6 +217,10 @@ filterRegsUsed p e =
foldRegsUsed
(
\
regs
r
->
if
p
r
then
extendRegSet
regs
r
else
regs
)
emptyRegSet
e
instance
UserOfLocalRegs
a
=>
UserOfLocalRegs
(
Maybe
a
)
where
foldRegsUsed
f
z
(
Just
x
)
=
foldRegsUsed
f
z
x
foldRegsUsed
_
z
Nothing
=
z
instance
UserOfLocalRegs
CmmReg
where
foldRegsUsed
f
z
(
CmmLocal
reg
)
=
f
z
reg
foldRegsUsed
_
z
(
CmmGlobal
_
)
=
z
...
...
compiler/cmm/CmmLint.hs
View file @
2304a362
...
...
@@ -134,7 +134,8 @@ lintCmmStmt platform labels = lint
_
<-
lintCmmExpr
platform
r
return
()
lint
(
CmmCall
target
_res
args
_
)
=
lintTarget
platform
target
>>
mapM_
(
lintCmmExpr
platform
.
hintlessCmm
)
args
do
lintTarget
platform
labels
target
mapM_
(
lintCmmExpr
platform
.
hintlessCmm
)
args
lint
(
CmmCondBranch
e
id
)
=
checkTarget
id
>>
lintCmmExpr
platform
e
>>
checkCond
platform
e
lint
(
CmmSwitch
e
branches
)
=
do
mapM_
checkTarget
$
catMaybes
branches
...
...
@@ -149,9 +150,12 @@ lintCmmStmt platform labels = lint
checkTarget
id
=
if
setMember
id
labels
then
return
()
else
cmmLintErr
(
text
"Branch to nonexistent id"
<+>
ppr
id
)
lintTarget
::
Platform
->
CmmCallTarget
->
CmmLint
()
lintTarget
platform
(
CmmCallee
e
_
)
=
lintCmmExpr
platform
e
>>
return
()
lintTarget
_
(
CmmPrim
{})
=
return
()
lintTarget
::
Platform
->
BlockSet
->
CmmCallTarget
->
CmmLint
()
lintTarget
platform
_
(
CmmCallee
e
_
)
=
do
_
<-
lintCmmExpr
platform
e
return
()
lintTarget
_
_
(
CmmPrim
_
Nothing
)
=
return
()
lintTarget
platform
labels
(
CmmPrim
_
(
Just
stmts
))
=
mapM_
(
lintCmmStmt
platform
labels
)
stmts
checkCond
::
Platform
->
CmmExpr
->
CmmLint
()
...
...
compiler/cmm/CmmOpt.hs
View file @
2304a362
...
...
@@ -61,7 +61,8 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
stmt
m
(
CmmStore
e1
e2
)
=
expr
(
expr
m
e1
)
e2
stmt
m
(
CmmCall
c
_
as
_
)
=
f
(
actuals
m
as
)
c
where
f
m
(
CmmCallee
e
_
)
=
expr
m
e
f
m
(
CmmPrim
_
_
)
=
m
f
m
(
CmmPrim
_
Nothing
)
=
m
f
m
(
CmmPrim
_
(
Just
stmts
))
=
foldl'
stmt
m
stmts
stmt
m
(
CmmBranch
b
)
=
b
:
m
stmt
m
(
CmmCondBranch
e
b
)
=
b
:
(
expr
m
e
)
stmt
m
(
CmmSwitch
e
bs
)
=
catMaybes
bs
++
expr
m
e
...
...
@@ -269,7 +270,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e
inlineStmt
u
a
(
CmmCall
target
regs
es
ret
)
=
CmmCall
(
infn
target
)
regs
es'
ret
where
infn
(
CmmCallee
fn
cconv
)
=
CmmCallee
(
inlineExpr
u
a
fn
)
cconv
infn
(
CmmPrim
p
m
)
=
CmmPrim
p
m
infn
(
CmmPrim
p
m
Stmts
)
=
CmmPrim
p
(
fmap
(
map
(
inlineStmt
u
a
))
mStmts
)
es'
=
[
(
CmmHinted
(
inlineExpr
u
a
e
)
hint
)
|
(
CmmHinted
e
hint
)
<-
es
]
inlineStmt
u
a
(
CmmCondBranch
e
d
)
=
CmmCondBranch
(
inlineExpr
u
a
e
)
d
inlineStmt
u
a
(
CmmSwitch
e
d
)
=
CmmSwitch
(
inlineExpr
u
a
e
)
d
...
...
compiler/cmm/OldCmm.hs
View file @
2304a362
...
...
@@ -222,8 +222,8 @@ instance UserOfLocalRegs CmmStmt where
gen
a
set
=
foldRegsUsed
f
set
a
instance
UserOfLocalRegs
CmmCallTarget
where
foldRegsUsed
f
set
(
CmmCallee
e
_
)
=
foldRegsUsed
f
set
e
foldRegsUsed
_
set
(
CmmPrim
{})
=
set
foldRegsUsed
f
set
(
CmmCallee
e
_
)
=
foldRegsUsed
f
set
e
foldRegsUsed
f
set
(
CmmPrim
_
mStmts
)
=
foldRegsUsed
f
set
mStmts
instance
UserOfSlots
CmmCallTarget
where
foldSlotsUsed
f
set
(
CmmCallee
e
_
)
=
foldSlotsUsed
f
set
e
...
...
@@ -296,5 +296,5 @@ data CmmCallTarget
-- If we don't know how to implement the
-- mach op, then we can replace it with
-- this list of statements:
(
Maybe
([
HintedCmmFormal
]
->
[
HintedCmmActual
]
->
[
CmmStmt
])
)
(
Maybe
[
CmmStmt
])
compiler/cmm/PprC.hs
View file @
2304a362
...
...
@@ -237,8 +237,8 @@ pprStmt platform stmt = case stmt of
pprCall
platform
cast_fn
cconv
results
args
<>
semi
)
-- for a dynamic call, no declaration is necessary.
CmmCall
(
CmmPrim
_
(
Just
mkS
tmts
))
results
args
_ret
->
vcat
$
map
(
pprStmt
platform
)
(
mkStmts
results
args
)
CmmCall
(
CmmPrim
_
(
Just
s
tmts
))
_
_
_
->
vcat
$
map
(
pprStmt
platform
)
stmts
CmmCall
(
CmmPrim
op
_
)
results
args
_ret
->
pprCall
platform
ppr_fn
CCallConv
results
args'
...
...
@@ -935,13 +935,19 @@ te_Lit _ = return ()
te_Stmt
::
CmmStmt
->
TE
()
te_Stmt
(
CmmAssign
r
e
)
=
te_Reg
r
>>
te_Expr
e
te_Stmt
(
CmmStore
l
r
)
=
te_Expr
l
>>
te_Expr
r
te_Stmt
(
CmmCall
_
rs
es
_
)
=
mapM_
(
te_temp
.
hintlessCmm
)
rs
>>
mapM_
(
te_Expr
.
hintlessCmm
)
es
te_Stmt
(
CmmCall
target
rs
es
_
)
=
do
te_Target
target
mapM_
(
te_temp
.
hintlessCmm
)
rs
mapM_
(
te_Expr
.
hintlessCmm
)
es
te_Stmt
(
CmmCondBranch
e
_
)
=
te_Expr
e
te_Stmt
(
CmmSwitch
e
_
)
=
te_Expr
e
te_Stmt
(
CmmJump
e
_
)
=
te_Expr
e
te_Stmt
_
=
return
()
te_Target
::
CmmCallTarget
->
TE
()
te_Target
(
CmmCallee
{})
=
return
()
te_Target
(
CmmPrim
_
Nothing
)
=
return
()
te_Target
(
CmmPrim
_
(
Just
stmts
))
=
mapM_
te_Stmt
stmts
te_Expr
::
CmmExpr
->
TE
()
te_Expr
(
CmmLit
lit
)
=
te_Lit
lit
te_Expr
(
CmmLoad
e
_
)
=
te_Expr
e
...
...
compiler/codeGen/CgPrimOp.hs
View file @
2304a362
...
...
@@ -443,13 +443,11 @@ emitPrimOp [res] op args live
stmtC
stmt
emitPrimOp
[
res_q
,
res_r
]
IntQuotRemOp
[
arg_x
,
arg_y
]
_
=
let
genericImpl
[
CmmHinted
res_q
_
,
CmmHinted
res_r
_
]
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
=
let
genericImpl
=
[
CmmAssign
(
CmmLocal
res_q
)
(
CmmMachOp
(
MO_S_Quot
wordWidth
)
[
arg_x
,
arg_y
]),
CmmAssign
(
CmmLocal
res_r
)
(
CmmMachOp
(
MO_S_Rem
wordWidth
)
[
arg_x
,
arg_y
])]
genericImpl
_
_
=
panic
"emitPrimOp IntQuotRemOp generic: bad lengths"
stmt
=
CmmCall
(
CmmPrim
(
MO_S_QuotRem
wordWidth
)
(
Just
genericImpl
))
[
CmmHinted
res_q
NoHint
,
CmmHinted
res_r
NoHint
]
...
...
@@ -458,13 +456,11 @@ emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
CmmMayReturn
in
stmtC
stmt
emitPrimOp
[
res_q
,
res_r
]
WordQuotRemOp
[
arg_x
,
arg_y
]
_
=
let
genericImpl
[
CmmHinted
res_q
_
,
CmmHinted
res_r
_
]
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
=
let
genericImpl
=
[
CmmAssign
(
CmmLocal
res_q
)
(
CmmMachOp
(
MO_U_Quot
wordWidth
)
[
arg_x
,
arg_y
]),
CmmAssign
(
CmmLocal
res_r
)
(
CmmMachOp
(
MO_U_Rem
wordWidth
)
[
arg_x
,
arg_y
])]
genericImpl
_
_
=
panic
"emitPrimOp WordQuotRemOp generic: bad lengths"
stmt
=
CmmCall
(
CmmPrim
(
MO_U_QuotRem
wordWidth
)
(
Just
genericImpl
))
[
CmmHinted
res_q
NoHint
,
CmmHinted
res_r
NoHint
]
...
...
@@ -477,8 +473,7 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
r2
<-
newLocalReg
(
cmmExprType
arg_x
)
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
let
genericImpl
[
CmmHinted
res_h
_
,
CmmHinted
res_l
_
]
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
let
genericImpl
=
[
CmmAssign
(
CmmLocal
r1
)
(
add
(
bottomHalf
arg_x
)
(
bottomHalf
arg_y
)),
CmmAssign
(
CmmLocal
r2
)
...
...
@@ -497,7 +492,6 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
hww
=
CmmLit
(
CmmInt
(
fromIntegral
(
widthInBits
halfWordWidth
))
wordWidth
)
hwm
=
CmmLit
(
CmmInt
halfWordMask
wordWidth
)
genericImpl
_
_
=
panic
"emitPrimOp WordAdd2Op generic: bad lengths"
stmt
=
CmmCall
(
CmmPrim
(
MO_Add2
wordWidth
)
(
Just
genericImpl
))
[
CmmHinted
res_h
NoHint
,
CmmHinted
res_l
NoHint
]
...
...
@@ -513,8 +507,7 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _
r
<-
liftM
CmmLocal
$
newLocalReg
t
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
let
genericImpl
[
CmmHinted
res_h
_
,
CmmHinted
res_l
_
]
[
CmmHinted
arg_x
_
,
CmmHinted
arg_y
_
]
let
genericImpl
=
[
CmmAssign
xlyl
(
mul
(
bottomHalf
arg_x
)
(
bottomHalf
arg_y
)),
CmmAssign
xlyh
...
...
@@ -543,7 +536,6 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _
hww
=
CmmLit
(
CmmInt
(
fromIntegral
(
widthInBits
halfWordWidth
))
wordWidth
)
hwm
=
CmmLit
(
CmmInt
halfWordMask
wordWidth
)
genericImpl
_
_
=
panic
"emitPrimOp WordMul2Op generic: bad lengths"
stmt
=
CmmCall
(
CmmPrim
(
MO_U_Mul2
wordWidth
)
(
Just
genericImpl
))
[
CmmHinted
res_h
NoHint
,
CmmHinted
res_l
NoHint
]
...
...
compiler/codeGen/CgUtils.hs
View file @
2304a362
...
...
@@ -1011,7 +1011,8 @@ fixStgRegStmt stmt
CmmCall
target
regs
args
returns
->
let
target'
=
case
target
of
CmmCallee
e
conv
->
CmmCallee
(
fixStgRegExpr
e
)
conv
other
->
other
CmmPrim
op
mStmts
->
CmmPrim
op
(
fmap
(
map
fixStgRegStmt
)
mStmts
)
args'
=
map
(
\
(
CmmHinted
arg
hint
)
->
(
CmmHinted
(
fixStgRegExpr
arg
)
hint
))
args
in
CmmCall
target'
regs
args'
returns
...
...
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
View file @
2304a362
...
...
@@ -202,9 +202,10 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
genCall
env
t
@
(
CmmPrim
op
_
)
[]
args
CmmMayReturn
|
op
==
MO_Memcpy
||
op
==
MO_Memset
||
op
==
MO_Memmove
=
do
genCall
env
t
@
(
CmmPrim
op
_
)
[]
args
CmmMayReturn
|
op
==
MO_Memcpy
||
op
==
MO_Memset
||
op
==
MO_Memmove
=
do
let
(
isVolTy
,
isVolVal
)
=
if
getLlvmVer
env
>=
28
then
([
i1
],
[
mkIntLit
i1
0
])
else
(
[]
,
[]
)
argTy
|
op
==
MO_Memset
=
[
i8Ptr
,
i8
,
llvmWord
,
i32
]
++
isVolTy
...
...
@@ -222,8 +223,8 @@ genCall env t@(CmmPrim op _) [] args CmmMayReturn | op == MO_Memcpy ||
`
appOL
`
trashStmts
`
snocOL
`
call
return
(
env2
,
stmts
,
top1
++
top2
)
genCall
env
(
CmmPrim
_
(
Just
mkS
tmts
))
results
args
_
=
stmtsToInstrs
env
(
mkStmts
results
args
)
(
nilOL
,
[]
)
genCall
env
(
CmmPrim
_
(
Just
s
tmts
))
_
_
_
=
stmtsToInstrs
env
stmts
(
nilOL
,
[]
)
-- Handle all other foreign calls and prim ops.
genCall
env
target
res
args
ret
=
do
...
...
compiler/nativeGen/AsmCodeGen.lhs
View file @
2304a362
...
...
@@ -880,7 +880,11 @@ cmmStmtConFold stmt
CmmCallee e conv -> do
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
other -> return other
op@(CmmPrim _ Nothing) ->
return op
CmmPrim op (Just stmts) ->
do stmts' <- mapM cmmStmtConFold stmts
return $ CmmPrim op (Just stmts')
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (CmmHinted arg' hint)) args
...
...
compiler/nativeGen/PPC/CodeGen.hs
View file @
2304a362
...
...
@@ -901,8 +901,8 @@ genCCall'
genCCall'
_
(
CmmPrim
MO_WriteBarrier
_
)
_
_
=
return
$
unitOL
LWSYNC
genCCall'
_
(
CmmPrim
_
(
Just
mkS
tmts
))
results
args
=
stmtsToInstrs
(
mkStmts
results
args
)
genCCall'
_
(
CmmPrim
_
(
Just
s
tmts
))
_
_
=
stmtsToInstrs
stmts
genCCall'
gcp
target
dest_regs
argsAndHints
=
ASSERT
(
not
$
any
(`
elem
`
[
II16
])
$
map
cmmTypeSize
argReps
)
...
...
@@ -946,7 +946,7 @@ genCCall' gcp target dest_regs argsAndHints
GCPLinux
->
roundTo
16
finalStack
-- need to remove alignment information
argsAndHints'
|
(
CmmPrim
mop
_
)
<-
target
,
argsAndHints'
|
CmmPrim
mop
_
<-
target
,
(
mop
==
MO_Memcpy
||
mop
==
MO_Memset
||
mop
==
MO_Memmove
)
...
...
compiler/nativeGen/SPARC/CodeGen.hs
View file @
2304a362
...
...
@@ -383,13 +383,13 @@ genCCall
genCCall
(
CmmPrim
(
MO_WriteBarrier
)
_
)
_
_
=
do
return
nilOL
genCCall
(
CmmPrim
_
(
Just
mkS
tmts
))
results
args
=
stmtsToInstrs
(
mkStmts
results
args
)
genCCall
(
CmmPrim
_
(
Just
s
tmts
))
_
_
=
stmtsToInstrs
stmts
genCCall
target
dest_regs
argsAndHints
=
do
-- need to remove alignment information
let
argsAndHints'
|
(
CmmPrim
mop
_
)
<-
target
,
let
argsAndHints'
|
CmmPrim
mop
_
<-
target
,
(
mop
==
MO_Memcpy
||
mop
==
MO_Memset
||
mop
==
MO_Memmove
)
...
...
compiler/nativeGen/X86/CodeGen.hs
View file @
2304a362
...
...
@@ -1707,8 +1707,8 @@ genCCall32 target dest_regs args =
return
code
_
->
panic
"genCCall32: Wrong number of arguments/results for add2"
(
CmmPrim
_
(
Just
mkS
tmts
),
results
)
->
stmtsToInstrs
(
mkStmts
results
args
)
(
CmmPrim
_
(
Just
s
tmts
),
_
)
->
stmtsToInstrs
stmts
_
->
genCCall32'
target
dest_regs
args
...
...
@@ -1927,8 +1927,8 @@ genCCall64 target dest_regs args =
return
code
_
->
panic
"genCCall64: Wrong number of arguments/results for add2"
(
CmmPrim
_
(
Just
mkS
tmts
),
results
)
->
stmtsToInstrs
(
mkStmts
results
args
)
(
CmmPrim
_
(
Just
s
tmts
),
_
)
->
stmtsToInstrs
stmts
_
->
genCCall64'
target
dest_regs
args
...
...
Ian Lynagh <igloo@earth.li>
@trac-igloo
mentioned in issue
#5900 (closed)
·
Feb 27, 2012
mentioned in issue
#5900 (closed)
mentioned in issue #5900
Toggle commit list
erikd
@trac-erikd
mentioned in issue
#5900 (closed)
·
Feb 27, 2012
mentioned in issue
#5900 (closed)
mentioned in issue #5900
Toggle commit list
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