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
82f81d12
Commit
82f81d12
authored
Jan 14, 2013
by
Simon Peyton Jones
Browse files
Merge branch 'master' of
http://darcs.haskell.org/ghc
parents
deec5b74
12f3a53e
Changes
25
Hide whitespace changes
Inline
Side-by-side
compiler/main/DriverPhases.hs
View file @
82f81d12
...
...
@@ -35,6 +35,7 @@ module DriverPhases (
#
include
"HsVersions.h"
import
{-#
SOURCE
#-
}
DynFlags
import
Outputable
import
Platform
import
System.FilePath
...
...
@@ -131,33 +132,39 @@ eqPhase _ _ = False
-- Partial ordering on phases: we want to know which phases will occur before
-- which others. This is used for sanity checking, to ensure that the
-- pipeline will stop at some point (see DriverPipeline.runPipeline).
happensBefore
::
Phase
->
Phase
->
Bool
StopLn
`
happensBefore
`
_
=
False
x
`
happensBefore
`
y
=
after_x
`
eqPhase
`
y
||
after_x
`
happensBefore
`
y
where
after_x
=
nextPhase
x
happensBefore
::
DynFlags
->
Phase
->
Phase
->
Bool
happensBefore
dflags
p1
p2
=
p1
`
happensBefore'
`
p2
where
StopLn
`
happensBefore'
`
_
=
False
x
`
happensBefore'
`
y
=
after_x
`
eqPhase
`
y
||
after_x
`
happensBefore'
`
y
where
after_x
=
nextPhase
dflags
x
nextPhase
::
Phase
->
Phase
-- A conservative approximation to the next phase, used in happensBefore
nextPhase
(
Unlit
sf
)
=
Cpp
sf
nextPhase
(
Cpp
sf
)
=
HsPp
sf
nextPhase
(
HsPp
sf
)
=
Hsc
sf
nextPhase
(
Hsc
_
)
=
HCc
nextPhase
Splitter
=
SplitAs
nextPhase
LlvmOpt
=
LlvmLlc
nextPhase
LlvmLlc
=
LlvmMangle
nextPhase
LlvmMangle
=
As
nextPhase
SplitAs
=
MergeStub
nextPhase
As
=
MergeStub
nextPhase
Ccpp
=
As
nextPhase
Cc
=
As
nextPhase
Cobjc
=
As
nextPhase
Cobjcpp
=
As
nextPhase
CmmCpp
=
Cmm
nextPhase
Cmm
=
HCc
nextPhase
HCc
=
As
nextPhase
MergeStub
=
StopLn
nextPhase
StopLn
=
panic
"nextPhase: nothing after StopLn"
nextPhase
::
DynFlags
->
Phase
->
Phase
nextPhase
dflags
p
-- A conservative approximation to the next phase, used in happensBefore
=
case
p
of
Unlit
sf
->
Cpp
sf
Cpp
sf
->
HsPp
sf
HsPp
sf
->
Hsc
sf
Hsc
_
->
maybeHCc
Splitter
->
SplitAs
LlvmOpt
->
LlvmLlc
LlvmLlc
->
LlvmMangle
LlvmMangle
->
As
SplitAs
->
MergeStub
As
->
MergeStub
Ccpp
->
As
Cc
->
As
Cobjc
->
As
Cobjcpp
->
As
CmmCpp
->
Cmm
Cmm
->
maybeHCc
HCc
->
As
MergeStub
->
StopLn
StopLn
->
panic
"nextPhase: nothing after StopLn"
where
maybeHCc
=
if
platformUnregisterised
(
targetPlatform
dflags
)
then
HCc
else
As
-- the first compilation phase for a given file is determined
-- by its suffix.
...
...
compiler/main/DriverPipeline.hs
View file @
82f81d12
...
...
@@ -503,70 +503,96 @@ runPipeline
->
IO
(
DynFlags
,
FilePath
)
-- ^ (final flags, output filename)
runPipeline
stop_phase
hsc_env0
(
input_fn
,
mb_phase
)
mb_basename
output
maybe_loc
maybe_stub_o
=
do
r
<-
runPipeline'
stop_phase
hsc_env0
(
input_fn
,
mb_phase
)
mb_basename
output
maybe_loc
maybe_stub_o
let
dflags
=
extractDynFlags
hsc_env0
whenCannotGenerateDynamicToo
dflags
$
do
=
do
let
dflags0
=
hsc_dflags
hsc_env0
-- Decide where dump files should go based on the pipeline output
dflags
=
dflags0
{
dumpPrefix
=
Just
(
basename
++
"."
)
}
hsc_env
=
hsc_env0
{
hsc_dflags
=
dflags
}
(
input_basename
,
suffix
)
=
splitExtension
input_fn
suffix'
=
drop
1
suffix
-- strip off the .
basename
|
Just
b
<-
mb_basename
=
b
|
otherwise
=
input_basename
-- If we were given a -x flag, then use that phase to start from
start_phase
=
fromMaybe
(
startPhase
suffix'
)
mb_phase
isHaskell
(
Unlit
_
)
=
True
isHaskell
(
Cpp
_
)
=
True
isHaskell
(
HsPp
_
)
=
True
isHaskell
(
Hsc
_
)
=
True
isHaskell
_
=
False
isHaskellishFile
=
isHaskell
start_phase
env
=
PipeEnv
{
pe_isHaskellishFile
=
isHaskellishFile
,
stop_phase
,
src_basename
=
basename
,
src_suffix
=
suffix'
,
output_spec
=
output
}
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- end.
--
-- There is a partial ordering on phases, where A < B iff A occurs
-- before B in a normal compilation pipeline.
let
happensBefore'
=
happensBefore
dflags
when
(
not
(
start_phase
`
happensBefore'
`
stop_phase
))
$
throwGhcException
(
UsageError
(
"cannot compile this file to desired target: "
++
input_fn
))
debugTraceMsg
dflags
4
(
text
"Running the pipeline"
)
r
<-
runPipeline'
start_phase
stop_phase
hsc_env
env
input_fn
output
maybe_loc
maybe_stub_o
-- If we are compiling a Haskell module, and doing
-- -dynamic-too, but couldn't do the -dynamic-too fast
-- path, then rerun the pipeline for the dyn way
let
dflags
=
extractDynFlags
hsc_env
when
isHaskellishFile
$
whenCannotGenerateDynamicToo
dflags
$
do
debugTraceMsg
dflags
4
(
text
"Running the pipeline again for -dynamic-too"
)
let
dflags'
=
doDynamicToo
dflags
hsc_env1
<-
newHscEnv
dflags'
_
<-
runPipeline'
stop_phase
hsc_env1
(
input_fn
,
mb_phase
)
mb_basename
output
maybe_loc
maybe_stub_o
-- TODO: This should use -dyno
output'
=
case
output
of
SpecificFile
fn
->
SpecificFile
(
replaceExtension
fn
(
objectSuf
dflags'
))
Persistent
->
Persistent
Temporary
->
Temporary
hsc_env'
<-
newHscEnv
dflags'
_
<-
runPipeline'
start_phase
stop_phase
hsc_env'
env
input_fn
output'
maybe_loc
maybe_stub_o
return
()
return
r
runPipeline'
::
Phase
-- ^ When to stop
::
Phase
-- ^ When to start
->
Phase
-- ^ When to stop
->
HscEnv
-- ^ Compilation environment
->
(
FilePath
,
Maybe
Phase
)
-- ^ Input filename (and maybe -x suffix)
->
Maybe
FilePath
-- ^ original basename (if different from ^^^)
->
PipeEnv
->
FilePath
-- ^ Input filename
->
PipelineOutput
-- ^ Output filename
->
Maybe
ModLocation
-- ^ A ModLocation, if this is a Haskell module
->
Maybe
FilePath
-- ^ stub object, if we have one
->
IO
(
DynFlags
,
FilePath
)
-- ^ (final flags, output filename)
runPipeline'
stop_phase
hsc_env
0
(
input_fn
,
mb_phase
)
mb_basename
output
maybe_loc
maybe_stub_o
->
IO
(
DynFlags
,
FilePath
)
-- ^ (final flags, output filename)
runPipeline'
start_phase
stop_phase
hsc_env
env
input_fn
output
maybe_loc
maybe_stub_o
=
do
let
dflags0
=
hsc_dflags
hsc_env0
(
input_basename
,
suffix
)
=
splitExtension
input_fn
suffix'
=
drop
1
suffix
-- strip off the .
basename
|
Just
b
<-
mb_basename
=
b
|
otherwise
=
input_basename
-- Decide where dump files should go based on the pipeline output
dflags
=
dflags0
{
dumpPrefix
=
Just
(
basename
++
"."
)
}
hsc_env
=
hsc_env0
{
hsc_dflags
=
dflags
}
-- If we were given a -x flag, then use that phase to start from
start_phase
=
fromMaybe
(
startPhase
suffix'
)
mb_phase
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- end.
--
-- There is a partial ordering on phases, where A < B iff A occurs
-- before B in a normal compilation pipeline.
when
(
not
(
start_phase
`
happensBefore
`
stop_phase
))
$
throwGhcException
(
UsageError
(
"cannot compile this file to desired target: "
++
input_fn
))
-- this is a function which will be used to calculate output file names
-- as we go along (we partially apply it to some of its inputs here)
let
get_output_fn
=
getOutputFilename
stop_phase
output
basename
let
get_output_fn
=
getOutputFilename
stop_phase
output
(
src_
basename
env
)
-- Execute the pipeline...
let
env
=
PipeEnv
{
stop_phase
,
src_basename
=
basename
,
src_suffix
=
suffix'
,
output_spec
=
output
}
state
=
PipeState
{
hsc_env
,
maybe_loc
,
maybe_stub_o
=
maybe_stub_o
}
let
state
=
PipeState
{
hsc_env
,
maybe_loc
,
maybe_stub_o
=
maybe_stub_o
}
(
state'
,
output_fn
)
<-
unP
(
pipeLoop
start_phase
input_fn
)
env
state
let
PipeState
{
hsc_env
=
hsc_env'
,
maybe_loc
}
=
state'
dflags
'
=
hsc_dflags
hsc_env'
dflags
=
hsc_dflags
hsc_env'
-- Sometimes, a compilation phase doesn't actually generate any output
-- (eg. the CPP phase when -fcpp is not turned on). If we end on this
...
...
@@ -575,20 +601,21 @@ runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
-- further compilation stages can tell what the original filename was.
case
output
of
Temporary
->
return
(
dflags
'
,
output_fn
)
_
other
->
do
final_fn
<-
get_output_fn
dflags
'
stop_phase
maybe_loc
return
(
dflags
,
output_fn
)
_
->
do
final_fn
<-
get_output_fn
dflags
stop_phase
maybe_loc
when
(
final_fn
/=
output_fn
)
$
do
let
msg
=
(
"Copying `"
++
output_fn
++
"' to `"
++
final_fn
++
"'"
)
line_prag
=
Just
(
"{-# LINE 1
\"
"
++
input_fn
++
"
\"
#-}
\n
"
)
copyWithHeader
dflags
msg
line_prag
output_fn
final_fn
return
(
dflags
'
,
final_fn
)
return
(
dflags
,
final_fn
)
-- -----------------------------------------------------------------------------
-- The pipeline uses a monad to carry around various bits of information
-- PipeEnv: invariant information passed down
data
PipeEnv
=
PipeEnv
{
pe_isHaskellishFile
::
Bool
,
stop_phase
::
Phase
,
-- ^ Stop just before this phase
src_basename
::
String
,
-- ^ basename of original input source
src_suffix
::
String
,
-- ^ its extension
...
...
@@ -656,12 +683,13 @@ phaseOutputFilename next_phase = do
pipeLoop
::
Phase
->
FilePath
->
CompPipeline
FilePath
pipeLoop
phase
input_fn
=
do
PipeEnv
{
stop_phase
}
<-
getPipeEnv
PipeState
{
hsc_env
}
<-
getPipeState
dflags
<-
getDynFlags
let
happensBefore'
=
happensBefore
dflags
case
()
of
_
|
phase
`
eqPhase
`
stop_phase
-- All done
->
return
input_fn
|
not
(
phase
`
happensBefore
`
stop_phase
)
|
not
(
phase
`
happensBefore
'
`
stop_phase
)
-- Something has gone wrong. We'll try to cover all the cases when
-- this could happen, so if we reach here it is a panic.
-- eg. it might happen if the -C flag is used on a source file that
...
...
@@ -670,9 +698,8 @@ pipeLoop phase input_fn = do
" but I wanted to stop at phase "
++
show
stop_phase
)
|
otherwise
->
do
liftIO
$
debugTraceMsg
(
hsc_
dflags
hsc_env
)
4
->
do
liftIO
$
debugTraceMsg
dflags
4
(
ptext
(
sLit
"Running phase"
)
<+>
ppr
phase
)
dflags
<-
getDynFlags
(
next_phase
,
output_fn
)
<-
runPhase
phase
input_fn
dflags
pipeLoop
next_phase
output_fn
...
...
@@ -1457,6 +1484,12 @@ runPhase MergeStub input_fn dflags
panic
"runPhase(MergeStub): no stub"
Just
stub_o
->
do
liftIO
$
joinObjectFiles
dflags
[
input_fn
,
stub_o
]
output_fn
whenGeneratingDynamicToo
dflags
$
do
liftIO
$
debugTraceMsg
dflags
4
(
text
"Merging stub again for -dynamic-too"
)
let
dyn_input_fn
=
replaceExtension
input_fn
(
dynObjectSuf
dflags
)
dyn_output_fn
=
replaceExtension
output_fn
(
dynObjectSuf
dflags
)
liftIO
$
joinObjectFiles
dflags
[
dyn_input_fn
,
stub_o
]
dyn_output_fn
return
(
StopLn
,
output_fn
)
-- warning suppression
...
...
@@ -1956,12 +1989,20 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
-- remember, in code we *compile*, the HOST is the same our TARGET,
-- and BUILD is the same as our HOST.
let
sse2
=
isSse2Enabled
dflags
sse4_2
=
isSse4_2Enabled
dflags
sse_defs
=
[
"-D__SSE__=1"
|
sse2
||
sse4_2
]
++
[
"-D__SSE2__=1"
|
sse2
||
sse4_2
]
++
[
"-D__SSE4_2__=1"
|
sse4_2
]
cpp_prog
(
map
SysTools
.
Option
verbFlags
++
map
SysTools
.
Option
include_paths
++
map
SysTools
.
Option
hsSourceCppOpts
++
map
SysTools
.
Option
target_defs
++
map
SysTools
.
Option
hscpp_opts
++
map
SysTools
.
Option
cc_opts
++
map
SysTools
.
Option
sse_defs
++
[
SysTools
.
Option
"-x"
,
SysTools
.
Option
"c"
,
SysTools
.
Option
input_fn
...
...
compiler/main/DynFlags.hs
View file @
82f81d12
...
...
@@ -118,6 +118,10 @@ module DynFlags (
tAG_MASK
,
mAX_PTR_TAG
,
tARGET_MIN_INT
,
tARGET_MAX_INT
,
tARGET_MAX_WORD
,
-- * SSE
isSse2Enabled
,
isSse4_2Enabled
,
)
where
#
include
"HsVersions.h"
...
...
@@ -590,6 +594,7 @@ data DynFlags = DynFlags {
dynHiSuf
::
String
,
outputFile
::
Maybe
String
,
dynOutputFile
::
Maybe
String
,
outputHi
::
Maybe
String
,
dynLibLoader
::
DynLibLoader
,
...
...
@@ -1144,6 +1149,7 @@ doDynamicToo :: DynFlags -> DynFlags
doDynamicToo
dflags0
=
let
dflags1
=
unSetGeneralFlag'
Opt_Static
dflags0
dflags2
=
addWay'
WayDyn
dflags1
dflags3
=
dflags2
{
outputFile
=
dynOutputFile
dflags2
,
hiSuf
=
dynHiSuf
dflags2
,
objectSuf
=
dynObjectSuf
dflags2
}
...
...
@@ -1222,6 +1228,7 @@ defaultDynFlags mySettings =
pluginModNameOpts
=
[]
,
outputFile
=
Nothing
,
dynOutputFile
=
Nothing
,
outputHi
=
Nothing
,
dynLibLoader
=
SystemDependent
,
dumpPrefix
=
Nothing
,
...
...
@@ -1594,7 +1601,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
addCmdlineFramework
,
addHaddockOpts
,
addGhciScript
,
setInteractivePrint
::
String
->
DynFlags
->
DynFlags
setOutputFile
,
setOutputHi
,
setDumpPrefixForce
setOutputFile
,
setDynOutputFile
,
setOutputHi
,
setDumpPrefixForce
::
Maybe
String
->
DynFlags
->
DynFlags
setObjectDir
f
d
=
d
{
objectDir
=
Just
f
}
...
...
@@ -1614,6 +1621,7 @@ setDynHiSuf f d = d{ dynHiSuf = f}
setHcSuf
f
d
=
d
{
hcSuf
=
f
}
setOutputFile
f
d
=
d
{
outputFile
=
f
}
setDynOutputFile
f
d
=
d
{
dynOutputFile
=
f
}
setOutputHi
f
d
=
d
{
outputHi
=
f
}
addPluginModuleName
::
String
->
DynFlags
->
DynFlags
...
...
@@ -1796,11 +1804,31 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcException
(
CmdLineError
(
"combination not supported: "
++
intercalate
"/"
(
map
wayDesc
theWays
)))
let
(
dflags4
,
consistency_warnings
)
=
makeDynFlagsConsistent
dflags3
-- TODO: This is an ugly hack. Do something better.
-- -fPIC affects the CMM code we generate, so if
-- we are in -dynamic-too mode we need -fPIC to be on during the
-- shared part of the compilation.
let
doingDynamicToo
=
gopt
Opt_BuildDynamicToo
dflags3
platform
=
targetPlatform
dflags3
dflags4
=
if
doingDynamicToo
then
foldr
setGeneralFlag'
dflags3
(
wayGeneralFlags
platform
WayDyn
)
else
dflags3
{-
TODO: This test doesn't quite work: We don't want to give an error
when e.g. compiling a C file, only when compiling Haskell files.
when doingDynamicToo $
unless (isJust (outputFile dflags4) == isJust (dynOutputFile dflags4)) $
throwGhcException $ CmdLineError
"With -dynamic-too, must give -dyno iff giving -o"
-}
let
(
dflags5
,
consistency_warnings
)
=
makeDynFlagsConsistent
dflags4
liftIO
$
setUnsafeGlobalDynFlags
dflags
4
liftIO
$
setUnsafeGlobalDynFlags
dflags
5
return
(
dflags
4
,
leftover
,
consistency_warnings
++
sh_warns
++
warns
)
return
(
dflags
5
,
leftover
,
consistency_warnings
++
sh_warns
++
warns
)
updateWays
::
DynFlags
->
DynFlags
updateWays
dflags
...
...
@@ -1992,6 +2020,7 @@ dynamic_flags = [
------- Output Redirection ------------------------------------------
,
Flag
"odir"
(
hasArg
setObjectDir
)
,
Flag
"o"
(
sepArg
(
setOutputFile
.
Just
))
,
Flag
"dyno"
(
sepArg
(
setDynOutputFile
.
Just
))
,
Flag
"ohi"
(
hasArg
(
setOutputHi
.
Just
))
,
Flag
"osuf"
(
hasArg
setObjectSuf
)
,
Flag
"dynosuf"
(
hasArg
setDynObjectSuf
)
...
...
@@ -2153,6 +2182,11 @@ dynamic_flags = [
,
Flag
"monly-4-regs"
(
NoArg
(
addWarn
"The -monly-4-regs flag does nothing; it will be removed in a future GHC release"
))
,
Flag
"msse2"
(
NoArg
(
setGeneralFlag
Opt_SSE2
))
,
Flag
"msse4.2"
(
NoArg
(
setGeneralFlag
Opt_SSE4_2
))
-- at some point we should probably have a single SSE flag that
-- contains the SSE version, instead of having a different flag
-- per version. That would make it easier to e.g. check if SSE2 is
-- enabled as you wouldn't have to check if either Opt_SSE2 or
-- Opt_SSE4_2 is set (as the latter implies the former).
------ Warning opts -------------------------------------------------
,
Flag
"W"
(
NoArg
(
mapM_
setWarningFlag
minusWOpts
))
...
...
@@ -3371,3 +3405,21 @@ makeDynFlagsConsistent dflags
arch
=
platformArch
platform
os
=
platformOS
platform
-- -----------------------------------------------------------------------------
-- SSE
isSse2Enabled
::
DynFlags
->
Bool
isSse2Enabled
dflags
=
isSse4_2Enabled
dflags
||
isSse2Enabled'
where
isSse2Enabled'
=
case
platformArch
(
targetPlatform
dflags
)
of
ArchX86_64
->
-- SSE2 is fixed on for x86_64. It would be
-- possible to make it optional, but we'd need to
-- fix at least the foreign call code where the
-- calling convention specifies the use of xmm regs,
-- and possibly other places.
True
ArchX86
->
gopt
Opt_SSE2
dflags
_
->
False
isSse4_2Enabled
::
DynFlags
->
Bool
isSse4_2Enabled
dflags
=
gopt
Opt_SSE4_2
dflags
compiler/main/GhcMake.hs
View file @
82f81d12
...
...
@@ -709,9 +709,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
prevailing_target
=
hscTarget
(
hsc_dflags
hsc_env
)
local_target
=
hscTarget
dflags
-- If OPTIONS_GHC contains -fasm or -f
via-C
, be careful that
-- If OPTIONS_GHC contains -fasm or -f
llvm
, be careful that
-- we don't do anything dodgy: these should only work to change
-- from -f
via-C
to -fasm and vice-versa, otherwise we could
-- from -f
llvm
to -fasm and vice-versa, otherwise we could
-- end up trying to link object code to byte code.
target
=
if
prevailing_target
/=
local_target
&&
(
not
(
isObjectTarget
prevailing_target
)
...
...
compiler/main/HscMain.hs
View file @
82f81d12
...
...
@@ -1250,8 +1250,9 @@ hscWriteIface iface no_change mod_summary = do
-- TODO: We should do a no_change check for the dynamic
-- interface file too
let
dynIfaceFile
=
replaceExtension
ifaceFile
(
dynHiSuf
dflags
)
dynIfaceFile'
=
addBootSuffix_maybe
(
mi_boot
iface
)
dynIfaceFile
dynDflags
=
doDynamicToo
dflags
writeIfaceFile
dynDflags
dynIfaceFile
iface
writeIfaceFile
dynDflags
dynIfaceFile
'
iface
-- | Compile to hard-code.
hscGenHardCode
::
CgGuts
->
ModSummary
...
...
compiler/nativeGen/SPARC/Base.hs
View file @
82f81d12
-- | Bits and pieces on the bottom of the module dependency tree.
-- Also import the required constants, so we know what we're using.
--
-- In the interests of cross-compilation, we want to free ourselves
-- from the autoconf generated modules like main/Constants
-- Also import the required constants, so we know what we're using.
--
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
-- In the interests of cross-compilation, we want to free ourselves
-- from the autoconf generated modules like main/Constants
module
SPARC.Base
(
wordLength
,
wordLengthInBits
,
spillAreaLength
,
spillSlotSize
,
extraStackArgsHere
,
fits13Bits
,
is32BitInteger
,
largeOffsetError
wordLength
,
wordLengthInBits
,
spillAreaLength
,
spillSlotSize
,
extraStackArgsHere
,
fits13Bits
,
is32BitInteger
,
largeOffsetError
)
where
...
...
@@ -36,13 +29,13 @@ wordLength :: Int
wordLength
=
4
wordLengthInBits
::
Int
wordLengthInBits
=
wordLength
*
8
wordLengthInBits
=
wordLength
*
8
-- Size of the available spill area
spillAreaLength
::
DynFlags
->
Int
spillAreaLength
=
rESERVED_C_STACK_BYTES
=
rESERVED_C_STACK_BYTES
-- | We need 8 bytes because our largest registers are 64 bit.
spillSlotSize
::
Int
...
...
@@ -50,7 +43,7 @@ spillSlotSize = 8
-- | We (allegedly) put the first six C-call arguments in registers;
--
where do we start putting the rest of them?
--
where do we start putting the rest of them?
extraStackArgsHere
::
Int
extraStackArgsHere
=
23
...
...
@@ -61,22 +54,22 @@ fits13Bits :: Integral a => a -> Bool
fits13Bits
x
=
x
>=
-
4096
&&
x
<
4096
-- | Check whether an integer will fit in 32 bits.
--
A CmmInt is intended to be truncated to the appropriate
--
number of bits, so here we truncate it to Int64. This is
--
important because e.g. -1 as a CmmInt might be either
--
-1 or 18446744073709551615.
--
A CmmInt is intended to be truncated to the appropriate
--
number of bits, so here we truncate it to Int64. This is
--
important because e.g. -1 as a CmmInt might be either
--
-1 or 18446744073709551615.
--
is32BitInteger
::
Integer
->
Bool
is32BitInteger
i
=
i64
<=
0x7fffffff
&&
i64
>=
-
0x80000000
where
i64
=
fromIntegral
i
::
Int64
is32BitInteger
i
=
i64
<=
0x7fffffff
&&
i64
>=
-
0x80000000
where
i64
=
fromIntegral
i
::
Int64
-- | Sadness.
largeOffsetError
::
(
Integral
a
,
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;"
++
"
\n
workaround: use -f
via-C
on this module.
\n
"
)
++
show
i
++
");
\n
probably because of large constant data structures;"
++
"
\n
workaround: use -f
llvm
on this module.
\n
"
)
compiler/nativeGen/X86/CodeGen.hs
View file @
82f81d12
...
...
@@ -71,20 +71,12 @@ is32BitPlatform = do
sse2Enabled
::
NatM
Bool
sse2Enabled
=
do
dflags
<-
getDynFlags
case
platformArch
(
targetPlatform
dflags
)
of
ArchX86_64
->
-- SSE2 is fixed on for x86_64. It would be
-- possible to make it optional, but we'd need to
-- fix at least the foreign call code where the
-- calling convention specifies the use of xmm regs,
-- and possibly other places.
return
True
ArchX86
->
return
(
gopt
Opt_SSE2
dflags
||
gopt
Opt_SSE4_2
dflags
)
_
->
panic
"sse2Enabled: Not an X86* arch"
return
(
isSse2Enabled
dflags
)
sse4_2Enabled
::
NatM
Bool
sse4_2Enabled
=
do
dflags
<-
getDynFlags
return
(
gopt
Opt_SSE4_2
dflags
)
return
(
isSse4_2Enabled
dflags
)
if_sse2
::
NatM
a
->
NatM
a
->
NatM
a
if_sse2
sse2
x87
=
do
...
...
compiler/prelude/PrelRules.lhs
View file @
82f81d12
...
...
@@ -142,28 +142,28 @@ primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
, inversePrimOp Word2IntOp ]
primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
, subsumedByPrimOp Narrow8IntOp
, subsume
dBy
PrimOp Narrow16IntOp
, subsume
dBy
PrimOp Narrow32IntOp ]
,
Narrow8IntOp `
subsume
s
PrimOp
`
Narrow16IntOp
,
Narrow8IntOp `
subsume
s
PrimOp
`
Narrow32IntOp ]
primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
,
Narrow16IntOp `
subsume
s
PrimOp
`
Narrow8IntOp
, subsume
dBy
PrimOp Narrow8IntOp
, subsumedByPrimOp Narrow16IntOp
, subsume
dBy
PrimOp Narrow32IntOp ]
,
Narrow16IntOp `
subsume
s
PrimOp
`
Narrow32IntOp ]
primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
,
Narrow32IntOp `
subsume
s
PrimOp
`
Narrow8IntOp
,
Narrow32IntOp `
subsume
s
PrimOp
`
Narrow16IntOp
, subsume
dBy
PrimOp Narrow8IntOp
, subsume
dBy
PrimOp Narrow16IntOp
, subsumedByPrimOp Narrow32IntOp
, removeOp32 ]
primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
, subsumedByPrimOp Narrow8WordOp
, subsume
dBy
PrimOp Narrow16WordOp
, subsume
dBy
PrimOp Narrow32WordOp ]
,
Narrow8WordOp `
subsume
s
PrimOp
`
Narrow16WordOp
,
Narrow8WordOp `
subsume
s
PrimOp
`
Narrow32WordOp ]
primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
,
Narrow16WordOp `
subsume
s
PrimOp
`
Narrow8WordOp
, subsume
dBy
PrimOp Narrow8WordOp
, subsumedByPrimOp Narrow16WordOp
, subsume
dBy
PrimOp Narrow32WordOp ]
,
Narrow16WordOp `
subsume
s
PrimOp
`
Narrow32WordOp ]
primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
,
Narrow32WordOp `
subsume
s
PrimOp
`
Narrow8WordOp
,
Narrow32WordOp `
subsume
s
PrimOp
`
Narrow16WordOp
, subsume
dBy
PrimOp Narrow8WordOp
, subsume
dBy
PrimOp Narrow16WordOp