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
4,321
Issues
4,321
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
359
Merge Requests
359
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
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
Glasgow Haskell Compiler
GHC
Commits
9ee9e518
Commit
9ee9e518
authored
Dec 22, 2011
by
dterei
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Formatting fixes
parent
74ac5be0
Changes
5
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
797 additions
and
836 deletions
+797
-836
compiler/codeGen/CgCallConv.hs
compiler/codeGen/CgCallConv.hs
+126
-133
compiler/codeGen/CgCase.lhs
compiler/codeGen/CgCase.lhs
+272
-276
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/CgForeignCall.hs
+9
-9
compiler/codeGen/CgPrimOp.hs
compiler/codeGen/CgPrimOp.hs
+101
-108
compiler/stgSyn/StgSyn.lhs
compiler/stgSyn/StgSyn.lhs
+289
-310
No files found.
compiler/codeGen/CgCallConv.hs
View file @
9ee9e518
...
...
@@ -4,34 +4,27 @@
--
-- CgCallConv
--
-- The datatypes and functions here encapsulate the
-- The datatypes and functions here encapsulate the
-- calling and return conventions used by the code generator.
--
-----------------------------------------------------------------------------
{-# 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
module
CgCallConv
(
-- Argument descriptors
mkArgDescr
,
-- Argument descriptors
mkArgDescr
,
-- Liveness
mkRegLiveness
,
-- Liveness
mkRegLiveness
,
-- Register assignment
assignCallRegs
,
assignReturnRegs
,
assignPrimOpCallRegs
,
-- Register assignment
assignCallRegs
,
assignReturnRegs
,
assignPrimOpCallRegs
,
-- Calls
constructSlowCall
,
slowArgs
,
slowCallPattern
,
-- Calls
constructSlowCall
,
slowArgs
,
slowCallPattern
,
-- Returns
dataReturnConvPrim
,
getSequelAmode
-- Returns
dataReturnConvPrim
,
getSequelAmode
)
where
import
CgMonad
...
...
@@ -57,11 +50,11 @@ import Data.Bits
-------------------------------------------------------------------------
--
--
Making argument descriptors
--
Making argument descriptors
--
-- An argument descriptor describes the layout of args on the stack,
-- both for
* GC (stack-layout) purposes, and
--
* saving/restoring registers when a heap-check fails
-- both for
* GC (stack-layout) purposes, and
--
* saving/restoring registers when a heap-check fails
--
-- Void arguments aren't important, therefore (contrast constructSlowCall)
--
...
...
@@ -72,29 +65,29 @@ import Data.Bits
-------------------------
mkArgDescr
::
Name
->
[
Id
]
->
FCode
ArgDescr
mkArgDescr
_nm
args
mkArgDescr
_nm
args
=
case
stdPattern
arg_reps
of
Just
spec_id
->
return
(
ArgSpec
spec_id
)
Nothing
->
return
(
ArgGen
arg_bits
)
Just
spec_id
->
return
(
ArgSpec
spec_id
)
Nothing
->
return
(
ArgGen
arg_bits
)
where
arg_bits
=
argBits
arg_reps
arg_reps
=
filter
nonVoidArg
(
map
idCgRep
args
)
-- Getting rid of voids eases matching of standard patterns
-- Getting rid of voids eases matching of standard patterns
argBits
::
[
CgRep
]
->
[
Bool
]
-- True for non-ptr, False for ptr
argBits
[]
=
[]
argBits
::
[
CgRep
]
->
[
Bool
]
-- True for non-ptr, False for ptr
argBits
[]
=
[]
argBits
(
PtrArg
:
args
)
=
False
:
argBits
args
argBits
(
arg
:
args
)
=
take
(
cgRepSizeW
arg
)
(
repeat
True
)
++
argBits
args
stdPattern
::
[
CgRep
]
->
Maybe
StgHalfWord
stdPattern
[]
=
Just
ARG_NONE
-- just void args, probably
stdPattern
[]
=
Just
ARG_NONE
-- just void args, probably
stdPattern
[
PtrArg
]
=
Just
ARG_P
stdPattern
[
FloatArg
]
=
Just
ARG_F
stdPattern
[
DoubleArg
]
=
Just
ARG_D
stdPattern
[
LongArg
]
=
Just
ARG_L
stdPattern
[
NonPtrArg
]
=
Just
ARG_N
stdPattern
[
NonPtrArg
,
NonPtrArg
]
=
Just
ARG_NN
stdPattern
[
NonPtrArg
,
PtrArg
]
=
Just
ARG_NP
stdPattern
[
PtrArg
,
NonPtrArg
]
=
Just
ARG_PN
...
...
@@ -103,13 +96,13 @@ stdPattern [PtrArg,PtrArg] = Just ARG_PP
stdPattern
[
NonPtrArg
,
NonPtrArg
,
NonPtrArg
]
=
Just
ARG_NNN
stdPattern
[
NonPtrArg
,
NonPtrArg
,
PtrArg
]
=
Just
ARG_NNP
stdPattern
[
NonPtrArg
,
PtrArg
,
NonPtrArg
]
=
Just
ARG_NPN
stdPattern
[
NonPtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_NPP
stdPattern
[
NonPtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_NPP
stdPattern
[
PtrArg
,
NonPtrArg
,
NonPtrArg
]
=
Just
ARG_PNN
stdPattern
[
PtrArg
,
NonPtrArg
,
PtrArg
]
=
Just
ARG_PNP
stdPattern
[
PtrArg
,
PtrArg
,
NonPtrArg
]
=
Just
ARG_PPN
stdPattern
[
PtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_PPP
stdPattern
[
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_PPPP
stdPattern
[
PtrArg
,
NonPtrArg
,
PtrArg
]
=
Just
ARG_PNP
stdPattern
[
PtrArg
,
PtrArg
,
NonPtrArg
]
=
Just
ARG_PPN
stdPattern
[
PtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_PPP
stdPattern
[
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_PPPP
stdPattern
[
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_PPPPP
stdPattern
[
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
,
PtrArg
]
=
Just
ARG_PPPPPP
stdPattern
_
=
Nothing
...
...
@@ -117,17 +110,17 @@ stdPattern _ = Nothing
-------------------------------------------------------------------------
--
--
Bitmap describing register liveness
--
across GC when doing a "generic" heap check
--
(a RET_DYN stack frame).
--
Bitmap describing register liveness
--
across GC when doing a "generic" heap check
--
(a RET_DYN stack frame).
--
-- NB. Must agree with these macros (currently in StgMacros.h):
-- NB. Must agree with these macros (currently in StgMacros.h):
-- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
-------------------------------------------------------------------------
mkRegLiveness
::
[(
Id
,
GlobalReg
)]
->
Int
->
Int
->
StgWord
mkRegLiveness
regs
ptrs
nptrs
=
(
fromIntegral
nptrs
`
shiftL
`
16
)
.|.
=
(
fromIntegral
nptrs
`
shiftL
`
16
)
.|.
(
fromIntegral
ptrs
`
shiftL
`
24
)
.|.
all_non_ptrs
`
xor
`
reg_bits
regs
where
...
...
@@ -135,31 +128,31 @@ mkRegLiveness regs ptrs nptrs
reg_bits
[]
=
0
reg_bits
((
id
,
VanillaReg
i
_
)
:
regs
)
|
isFollowableArg
(
idCgRep
id
)
=
(
1
`
shiftL
`
(
i
-
1
))
.|.
reg_bits
regs
=
(
1
`
shiftL
`
(
i
-
1
))
.|.
reg_bits
regs
reg_bits
(
_
:
regs
)
=
reg_bits
regs
=
reg_bits
regs
-------------------------------------------------------------------------
--
--
Pushing the arguments for a slow call
--
Pushing the arguments for a slow call
--
-------------------------------------------------------------------------
-- For a slow call, we must take a bunch of arguments and intersperse
-- some stg_ap_<pattern>_ret_info return addresses.
constructSlowCall
::
[(
CgRep
,
CmmExpr
)]
->
(
CLabel
,
-- RTS entry point for call
[(
CgRep
,
CmmExpr
)],
-- args to pass to the entry point
[(
CgRep
,
CmmExpr
)])
-- stuff to save on the stack
::
[(
CgRep
,
CmmExpr
)]
->
(
CLabel
,
-- RTS entry point for call
[(
CgRep
,
CmmExpr
)],
-- args to pass to the entry point
[(
CgRep
,
CmmExpr
)])
-- stuff to save on the stack
-- don't forget the zero case
constructSlowCall
[]
constructSlowCall
[]
=
(
mkRtsApFastLabel
(
fsLit
"stg_ap_0"
),
[]
,
[]
)
constructSlowCall
amodes
=
(
stg_ap_pat
,
these
,
rest
)
where
where
stg_ap_pat
=
mkRtsApFastLabel
arg_pat
(
arg_pat
,
these
,
rest
)
=
matchSlowPattern
amodes
...
...
@@ -178,33 +171,33 @@ slowArgs amodes
save_cccs
=
[(
NonPtrArg
,
mkLblExpr
save_cccs_lbl
),
(
NonPtrArg
,
curCCS
)]
save_cccs_lbl
=
mkCmmRetInfoLabel
rtsPackageId
(
fsLit
"stg_restore_cccs"
)
matchSlowPattern
::
[(
CgRep
,
CmmExpr
)]
->
(
FastString
,
[(
CgRep
,
CmmExpr
)],
[(
CgRep
,
CmmExpr
)])
matchSlowPattern
::
[(
CgRep
,
CmmExpr
)]
->
(
FastString
,
[(
CgRep
,
CmmExpr
)],
[(
CgRep
,
CmmExpr
)])
matchSlowPattern
amodes
=
(
arg_pat
,
these
,
rest
)
where
(
arg_pat
,
n
)
=
slowCallPattern
(
map
fst
amodes
)
(
these
,
rest
)
=
splitAt
n
amodes
(
these
,
rest
)
=
splitAt
n
amodes
-- These cases were found to cover about 99% of all slow calls:
slowCallPattern
::
[
CgRep
]
->
(
FastString
,
Int
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_pppppp"
,
6
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_ppppp"
,
5
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_pppp"
,
4
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
VoidArg
:
_
)
=
(
fsLit
"stg_ap_pppv"
,
4
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_ppp"
,
3
)
slowCallPattern
(
PtrArg
:
PtrArg
:
VoidArg
:
_
)
=
(
fsLit
"stg_ap_ppv"
,
3
)
slowCallPattern
(
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_pp"
,
2
)
slowCallPattern
(
PtrArg
:
VoidArg
:
_
)
=
(
fsLit
"stg_ap_pv"
,
2
)
slowCallPattern
(
PtrArg
:
_
)
=
(
fsLit
"stg_ap_p"
,
1
)
slowCallPattern
(
VoidArg
:
_
)
=
(
fsLit
"stg_ap_v"
,
1
)
slowCallPattern
(
NonPtrArg
:
_
)
=
(
fsLit
"stg_ap_n"
,
1
)
slowCallPattern
(
FloatArg
:
_
)
=
(
fsLit
"stg_ap_f"
,
1
)
slowCallPattern
(
DoubleArg
:
_
)
=
(
fsLit
"stg_ap_d"
,
1
)
slowCallPattern
(
LongArg
:
_
)
=
(
fsLit
"stg_ap_l"
,
1
)
slowCallPattern
_
=
panic
"CgStackery.slowCallPattern"
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_ppppp"
,
5
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_pppp"
,
4
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
VoidArg
:
_
)
=
(
fsLit
"stg_ap_pppv"
,
4
)
slowCallPattern
(
PtrArg
:
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_ppp"
,
3
)
slowCallPattern
(
PtrArg
:
PtrArg
:
VoidArg
:
_
)
=
(
fsLit
"stg_ap_ppv"
,
3
)
slowCallPattern
(
PtrArg
:
PtrArg
:
_
)
=
(
fsLit
"stg_ap_pp"
,
2
)
slowCallPattern
(
PtrArg
:
VoidArg
:
_
)
=
(
fsLit
"stg_ap_pv"
,
2
)
slowCallPattern
(
PtrArg
:
_
)
=
(
fsLit
"stg_ap_p"
,
1
)
slowCallPattern
(
VoidArg
:
_
)
=
(
fsLit
"stg_ap_v"
,
1
)
slowCallPattern
(
NonPtrArg
:
_
)
=
(
fsLit
"stg_ap_n"
,
1
)
slowCallPattern
(
FloatArg
:
_
)
=
(
fsLit
"stg_ap_f"
,
1
)
slowCallPattern
(
DoubleArg
:
_
)
=
(
fsLit
"stg_ap_d"
,
1
)
slowCallPattern
(
LongArg
:
_
)
=
(
fsLit
"stg_ap_l"
,
1
)
slowCallPattern
_
=
panic
"CgStackery.slowCallPattern"
-------------------------------------------------------------------------
--
--
Return conventions
--
Return conventions
--
-------------------------------------------------------------------------
...
...
@@ -219,7 +212,7 @@ dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
-- getSequelAmode returns an amode which refers to an info table. The info
-- table will always be of the RET_(BIG|SMALL) kind. We're careful
-- not to handle real code pointers, just in case we're compiling for
-- not to handle real code pointers, just in case we're compiling for
-- an unregisterised/untailcallish architecture, where info pointers and
-- code pointers aren't the same.
-- DIRE WARNING.
...
...
@@ -230,60 +223,60 @@ dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void"
getSequelAmode
::
FCode
CmmExpr
getSequelAmode
=
do
{
EndOfBlockInfo
virt_sp
sequel
<-
getEndOfBlockInfo
;
case
sequel
of
OnStack
->
do
{
sp_rel
<-
getSpRelOffset
virt_sp
;
returnFC
(
CmmLoad
sp_rel
bWord
)
}
=
do
{
EndOfBlockInfo
virt_sp
sequel
<-
getEndOfBlockInfo
;
case
sequel
of
OnStack
->
do
{
sp_rel
<-
getSpRelOffset
virt_sp
;
returnFC
(
CmmLoad
sp_rel
bWord
)
}
CaseAlts
lbl
_
_
->
returnFC
(
CmmLit
(
CmmLabel
lbl
))
}
CaseAlts
lbl
_
_
->
returnFC
(
CmmLit
(
CmmLabel
lbl
))
}
-------------------------------------------------------------------------
--
--
Register assignment
--
Register assignment
--
-------------------------------------------------------------------------
-- How to assign registers for
-- How to assign registers for
--
--
1) Calling a fast entry point.
--
2) Returning an unboxed tuple.
--
3) Invoking an out-of-line PrimOp.
--
1) Calling a fast entry point.
--
2) Returning an unboxed tuple.
--
3) Invoking an out-of-line PrimOp.
--
-- Registers are assigned in order.
--
--
-- If we run out, we don't attempt to assign any further registers (even
-- though we might have run out of only one kind of register); we just
-- return immediately with the left-overs specified.
--
--
-- The alternative version @assignAllRegs@ uses the complete set of
-- registers, including those that aren't mapped to real machine
-- registers. This is used for calling special RTS functions and PrimOps
-- which expect their arguments to always be in the same registers.
assignCallRegs
,
assignPrimOpCallRegs
,
assignReturnRegs
::
[(
CgRep
,
a
)]
-- Arg or result values to assign
->
([(
a
,
GlobalReg
)],
-- Register assignment in same order
-- for *initial segment of* input list
-- (but reversed; doesn't matter)
-- VoidRep args do not appear here
[(
CgRep
,
a
)])
-- Leftover arg or result values
::
[(
CgRep
,
a
)]
-- Arg or result values to assign
->
([(
a
,
GlobalReg
)],
-- Register assignment in same order
-- for *initial segment of* input list
-- (but reversed; doesn't matter)
-- VoidRep args do not appear here
[(
CgRep
,
a
)])
-- Leftover arg or result values
assignCallRegs
args
=
assign_regs
args
(
mkRegTbl
[
node
])
-- The entry convention for a function closure
-- never uses Node for argument passing; instead
-- Node points to the function closure itself
-- The entry convention for a function closure
-- never uses Node for argument passing; instead
-- Node points to the function closure itself
assignPrimOpCallRegs
args
=
assign_regs
args
(
mkRegTbl_allRegs
[]
)
-- For primops, *all* arguments must be passed in registers
-- For primops, *all* arguments must be passed in registers
assignReturnRegs
args
-- when we have a single non-void component to return, use the normal
-- unpointed return convention. This make various things simpler: it
-- means we can assume a consistent convention for IO, which is useful
-- when writing code that relies on knowing the IO return convention in
-- when writing code that relies on knowing the IO return convention in
-- the RTS (primops, especially exception-related primops).
-- Also, the bytecode compiler assumes this when compiling
-- case expressions and ccalls, so it only needs to know one set of
...
...
@@ -292,24 +285,24 @@ assignReturnRegs args
=
([(
arg
,
r
)],
[]
)
|
otherwise
=
assign_regs
args
(
mkRegTbl
[]
)
-- For returning unboxed tuples etc,
-- we use all regs
where
-- For returning unboxed tuples etc,
-- we use all regs
where
non_void_args
=
filter
((
/=
VoidArg
)
.
fst
)
args
assign_regs
::
[(
CgRep
,
a
)]
-- Arg or result values to assign
->
AvailRegs
-- Regs still avail: Vanilla, Float, Double, Longs
->
([(
a
,
GlobalReg
)],
[(
CgRep
,
a
)])
assign_regs
::
[(
CgRep
,
a
)]
-- Arg or result values to assign
->
AvailRegs
-- Regs still avail: Vanilla, Float, Double, Longs
->
([(
a
,
GlobalReg
)],
[(
CgRep
,
a
)])
assign_regs
args
supply
=
go
args
[]
supply
where
go
[]
acc
_
=
(
acc
,
[]
)
-- Return the results reversed (doesn't matter)
go
((
VoidArg
,
_
)
:
args
)
acc
supply
-- Skip void arguments; they aren't passed, and
=
go
args
acc
supply
-- there's nothing to bind them to
go
((
rep
,
arg
)
:
args
)
acc
supply
=
case
assign_reg
rep
supply
of
Just
(
reg
,
supply'
)
->
go
args
((
arg
,
reg
)
:
acc
)
supply'
Nothing
->
(
acc
,
(
rep
,
arg
)
:
args
)
-- No more regs
go
[]
acc
_
=
(
acc
,
[]
)
-- Return the results reversed (doesn't matter)
go
((
VoidArg
,
_
)
:
args
)
acc
supply
-- Skip void arguments; they aren't passed, and
=
go
args
acc
supply
-- there's nothing to bind them to
go
((
rep
,
arg
)
:
args
)
acc
supply
=
case
assign_reg
rep
supply
of
Just
(
reg
,
supply'
)
->
go
args
((
arg
,
reg
)
:
acc
)
supply'
Nothing
->
(
acc
,
(
rep
,
arg
)
:
args
)
-- No more regs
assign_reg
::
CgRep
->
AvailRegs
->
Maybe
(
GlobalReg
,
AvailRegs
)
assign_reg
FloatArg
(
vs
,
f
:
fs
,
ds
,
ls
)
=
Just
(
FloatReg
f
,
(
vs
,
fs
,
ds
,
ls
))
...
...
@@ -323,7 +316,7 @@ assign_reg _ _ = Nothing
-------------------------------------------------------------------------
--
--
Register supplies
--
Register supplies
--
-------------------------------------------------------------------------
...
...
@@ -335,37 +328,37 @@ assign_reg _ _ = Nothing
useVanillaRegs
::
Int
useVanillaRegs
|
opt_Unregisterised
=
0
|
otherwise
=
mAX_Real_Vanilla_REG
|
otherwise
=
mAX_Real_Vanilla_REG
useFloatRegs
::
Int
useFloatRegs
|
opt_Unregisterised
=
0
|
otherwise
=
mAX_Real_Float_REG
|
otherwise
=
mAX_Real_Float_REG
useDoubleRegs
::
Int
useDoubleRegs
|
opt_Unregisterised
=
0
|
otherwise
=
mAX_Real_Double_REG
|
otherwise
=
mAX_Real_Double_REG
useLongRegs
::
Int
useLongRegs
|
opt_Unregisterised
=
0
|
otherwise
=
mAX_Real_Long_REG
|
otherwise
=
mAX_Real_Long_REG
vanillaRegNos
,
floatRegNos
,
doubleRegNos
,
longRegNos
::
[
Int
]
vanillaRegNos
=
regList
useVanillaRegs
floatRegNos
=
regList
useFloatRegs
doubleRegNos
=
regList
useDoubleRegs
vanillaRegNos
=
regList
useVanillaRegs
floatRegNos
=
regList
useFloatRegs
doubleRegNos
=
regList
useDoubleRegs
longRegNos
=
regList
useLongRegs
allVanillaRegNos
,
allFloatRegNos
,
allDoubleRegNos
,
allLongRegNos
::
[
Int
]
allVanillaRegNos
=
regList
mAX_Vanilla_REG
allFloatRegNos
=
regList
mAX_Float_REG
allDoubleRegNos
=
regList
mAX_Double_REG
allLongRegNos
=
regList
mAX_Long_REG
allFloatRegNos
=
regList
mAX_Float_REG
allDoubleRegNos
=
regList
mAX_Double_REG
allLongRegNos
=
regList
mAX_Long_REG
regList
::
Int
->
[
Int
]
regList
n
=
[
1
..
n
]
type
AvailRegs
=
(
[
Int
]
-- available vanilla regs.
,
[
Int
]
-- floats
,
[
Int
]
-- doubles
,
[
Int
]
-- longs (int64 and word64)
)
,
[
Int
]
-- floats
,
[
Int
]
-- doubles
,
[
Int
]
-- longs (int64 and word64)
)
mkRegTbl
::
[
GlobalReg
]
->
AvailRegs
mkRegTbl
regs_in_use
...
...
@@ -381,23 +374,23 @@ mkRegTbl' regs_in_use vanillas floats doubles longs
=
(
ok_vanilla
,
ok_float
,
ok_double
,
ok_long
)
where
ok_vanilla
=
mapCatMaybes
(
select
(
\
i
->
VanillaReg
i
VNonGcPtr
))
vanillas
-- ptrhood isn't looked at, hence we can use any old rep.
ok_float
=
mapCatMaybes
(
select
FloatReg
)
floats
-- ptrhood isn't looked at, hence we can use any old rep.
ok_float
=
mapCatMaybes
(
select
FloatReg
)
floats
ok_double
=
mapCatMaybes
(
select
DoubleReg
)
doubles
ok_long
=
mapCatMaybes
(
select
LongReg
)
longs
ok_long
=
mapCatMaybes
(
select
LongReg
)
longs
select
::
(
Int
->
GlobalReg
)
->
Int
{-cand-}
->
Maybe
Int
-- one we've unboxed the Int, we make a GlobalReg
-- and see if it is already in use; if not, return its number.
-- one we've unboxed the Int, we make a GlobalReg
-- and see if it is already in use; if not, return its number.
select
mk_reg_fun
cand
=
let
reg
=
mk_reg_fun
cand
in
if
reg
`
not_elem
`
regs_in_use
then
Just
cand
else
Nothing
reg
=
mk_reg_fun
cand
in
if
reg
`
not_elem
`
regs_in_use
then
Just
cand
else
Nothing
where
not_elem
=
isn'tIn
"mkRegTbl"
not_elem
=
isn'tIn
"mkRegTbl"
compiler/codeGen/CgCase.lhs
View file @
9ee9e518
This diff is collapsed.
Click to expand it.
compiler/codeGen/CgForeignCall.hs
View file @
9ee9e518
...
...
@@ -7,15 +7,15 @@
-----------------------------------------------------------------------------
module
CgForeignCall
(
cgForeignCall
,
emitForeignCall
,
emitForeignCall'
,
shimForeignCallArg
,
emitSaveThreadState
,
-- will be needed by the Cmm parser
emitLoadThreadState
,
-- ditto
emitCloseNursery
,
emitOpenNursery
,
)
where
cgForeignCall
,
emitForeignCall
,
emitForeignCall'
,
shimForeignCallArg
,
emitSaveThreadState
,
-- will be needed by the Cmm parser
emitLoadThreadState
,
-- ditto
emitCloseNursery
,
emitOpenNursery
,
)
where
import
StgSyn
import
CgProf
...
...
compiler/codeGen/CgPrimOp.hs
View file @
9ee9e518
...
...
@@ -6,16 +6,9 @@
--
-----------------------------------------------------------------------------
{-# 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
module
CgPrimOp
(
cgPrimOp
)
where
cgPrimOp
)
where
import
BasicTypes
import
ForeignCall
...
...
@@ -43,44 +36,44 @@ import StaticFlags
-- ---------------------------------------------------------------------------
-- Code generation for PrimOps
cgPrimOp
::
[
CmmFormal
]
-- where to put the results
->
PrimOp
-- the op
->
[
StgArg
]
-- arguments
->
StgLiveVars
-- live vars, in case we need to save them
->
Code
cgPrimOp
::
[
CmmFormal
]
-- where to put the results
->
PrimOp
-- the op
->
[
StgArg
]
-- arguments
->
StgLiveVars
-- live vars, in case we need to save them
->
Code
cgPrimOp
results
op
args
live
=
do
arg_exprs
<-
getArgAmodes
args
let
non_void_args
=
[
e
|
(
r
,
e
)
<-
arg_exprs
,
nonVoidArg
r
]
let
non_void_args
=
[
e
|
(
r
,
e
)
<-
arg_exprs
,
nonVoidArg
r
]
emitPrimOp
results
op
non_void_args
live
emitPrimOp
::
[
CmmFormal
]
-- where to put the results
->
PrimOp
-- the op
->
[
CmmExpr
]
-- arguments
->
StgLiveVars
-- live vars, in case we need to save them
->
Code
emitPrimOp
::
[
CmmFormal
]
-- where to put the results
->
PrimOp
-- the op
->
[
CmmExpr
]
-- arguments
->
StgLiveVars
-- live vars, in case we need to save them
->
Code
-- First we handle various awkward cases specially. The remaining
-- easy cases are then handled by translateOp, defined below.
emitPrimOp
[
res_r
,
res_c
]
IntAddCOp
[
aa
,
bb
]
_
{-
{-
With some bit-twiddling, we can define int{Add,Sub}Czh portably in
C, and without needing any comparisons. This may not be the
fastest way to do it - if you have better code, please send it! --SDM
Return : r = a + b, c = 0 if no overflow, 1 on overflow.
We currently don't make use of the r value if c is != 0 (i.e.
We currently don't make use of the r value if c is != 0 (i.e.
overflow), we just convert to big integers and try again. This
could be improved by making r and c the correct values for
plugging into a new J#.
{ r = ((I_)(a)) + ((I_)(b));
\
c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))
\
>> (BITS_IN (I_) - 1);
\
}
plugging into a new J#.
{ r = ((I_)(a)) + ((I_)(b));
\
c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))
\
>> (BITS_IN (I_) - 1);
\
}
Wading through the mass of bracketry, it seems to reduce to:
c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
...
...
@@ -88,22 +81,22 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _
=
stmtsC
[
CmmAssign
(
CmmLocal
res_r
)
(
CmmMachOp
mo_wordAdd
[
aa
,
bb
]),
CmmAssign
(
CmmLocal
res_c
)
$
CmmMachOp
mo_wordUShr
[
CmmMachOp
mo_wordAnd
[
CmmMachOp
mo_wordNot
[
CmmMachOp
mo_wordXor
[
aa
,
bb
]],
CmmMachOp
mo_wordXor
[
aa
,
CmmReg
(
CmmLocal
res_r
)]
],
CmmLit
(
mkIntCLit
(
wORD_SIZE_IN_BITS
-
1
))
]
CmmMachOp
mo_wordUShr
[
CmmMachOp
mo_wordAnd
[
CmmMachOp
mo_wordNot
[
CmmMachOp
mo_wordXor
[
aa
,
bb
]],
CmmMachOp
mo_wordXor
[
aa
,
CmmReg
(
CmmLocal
res_r
)]
],
CmmLit
(
mkIntCLit
(
wORD_SIZE_IN_BITS
-
1
))
]
]
emitPrimOp
[
res_r
,
res_c
]
IntSubCOp
[
aa
,
bb
]
_
{- Similarly:
#define subIntCzh(r,c,a,b)
\
{ r = ((I_)(a)) - ((I_)(b));
\
c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))
\
>> (BITS_IN (I_) - 1);
\
#define subIntCzh(r,c,a,b)
\
{ r = ((I_)(a)) - ((I_)(b));
\
c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))
\
>> (BITS_IN (I_) - 1);
\
}
c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
...
...
@@ -111,27 +104,27 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _
=
stmtsC
[
CmmAssign
(
CmmLocal
res_r
)
(
CmmMachOp
mo_wordSub
[
aa
,
bb
]),
CmmAssign
(
CmmLocal
res_c
)
$
CmmMachOp
mo_wordUShr
[
CmmMachOp
mo_wordAnd
[
CmmMachOp
mo_wordXor
[
aa
,
bb
],
CmmMachOp
mo_wordXor
[
aa
,
CmmReg
(
CmmLocal
res_r
)]
],
CmmLit
(
mkIntCLit
(
wORD_SIZE_IN_BITS
-
1
))
]
CmmMachOp
mo_wordUShr
[
CmmMachOp
mo_wordAnd
[
CmmMachOp
mo_wordXor
[
aa
,
bb
],
CmmMachOp
mo_wordXor
[
aa
,
CmmReg
(
CmmLocal
res_r
)]
],
CmmLit
(
mkIntCLit
(
wORD_SIZE_IN_BITS
-
1
))
]
]
emitPrimOp
[
res
]
ParOp
[
arg
]
live
=
do
-- for now, just implement this in a C function
-- later, we might want to inline it.
-- for now, just implement this in a C function