projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
First pass at implementing info tables for CPS
[ghc-hetmet.git]
/
compiler
/
nativeGen
/
MachCodeGen.hs
diff --git
a/compiler/nativeGen/MachCodeGen.hs
b/compiler/nativeGen/MachCodeGen.hs
index
3abf6a4
..
154eed8
100644
(file)
--- a/
compiler/nativeGen/MachCodeGen.hs
+++ b/
compiler/nativeGen/MachCodeGen.hs
@@
-29,6
+29,7
@@
import PprCmm ( pprExpr )
import Cmm
import MachOp
import CLabel
import Cmm
import MachOp
import CLabel
+import ClosureInfo ( C_SRT(..) )
-- The rest:
import StaticFlags ( opt_PIC )
-- The rest:
import StaticFlags ( opt_PIC )
@@
-61,7
+62,7
@@
import Data.Int
type InstrBlock = OrdList Instr
type InstrBlock = OrdList Instr
-cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
+cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop]
cmmTopCodeGen (CmmProc info lab params blocks) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
cmmTopCodeGen (CmmProc info lab params blocks) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
@@
-119,8
+120,8
@@
stmtToInstrs stmt = case stmt of
| otherwise -> assignMem_IntCode kind addr src
where kind = cmmExprRep src
| otherwise -> assignMem_IntCode kind addr src
where kind = cmmExprRep src
- CmmCall target result_regs args vols
- -> genCCall target result_regs args vols
+ CmmCall target result_regs args _
+ -> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
@@
-188,7
+189,7
@@
assignMem_I64Code addrTree valueTree = do
return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
-assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
+assignReg_I64Code (CmmLocal (LocalReg u_dst pk _)) valueTree = do
ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
let
r_dst_lo = mkVReg u_dst I32
ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
let
r_dst_lo = mkVReg u_dst I32
@@
-230,7
+231,7
@@
iselExpr64 (CmmLoad addrTree I64) = do
rlo
)
rlo
)
-iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64)))
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64 _)))
= return (ChildCode64 nilOL (mkVReg vu I32))
-- we handle addition, but rather badly
= return (ChildCode64 nilOL (mkVReg vu I32))
-- we handle addition, but rather badly
@@
-399,7
+400,7
@@
iselExpr64 (CmmLoad addrTree I64) = do
return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
-iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64)))
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64 _)))
= return (ChildCode64 nilOL (mkVReg vu I32))
iselExpr64 (CmmLit (CmmInt i _)) = do
= return (ChildCode64 nilOL (mkVReg vu I32))
iselExpr64 (CmmLit (CmmInt i _)) = do
@@
-476,7
+477,7
@@
getSomeReg expr = do
getRegisterReg :: CmmReg -> Reg
getRegisterReg :: CmmReg -> Reg
-getRegisterReg (CmmLocal (LocalReg u pk))
+getRegisterReg (CmmLocal (LocalReg u pk _))
= mkVReg u pk
getRegisterReg (CmmGlobal mid)
= mkVReg u pk
getRegisterReg (CmmGlobal mid)
@@
-2938,9
+2939,8
@@
genCondJump id bool = do
genCCall
:: CmmCallTarget -- function to call
genCCall
:: CmmCallTarget -- function to call
- -> [(CmmReg,MachHint)] -- where to put the result
- -> [(CmmExpr,MachHint)] -- arguments (of mixed type)
- -> Maybe [GlobalReg] -- volatile regs to save
+ -> CmmHintFormals -- where to put the result
+ -> CmmActuals -- arguments (of mixed type)
-> NatM InstrBlock
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-> NatM InstrBlock
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@
-3019,12
+3019,12
@@
genCCall fn cconv result_regs args
#if i386_TARGET_ARCH
#if i386_TARGET_ARCH
-genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL
+genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-- we only cope with a single result for foreign calls
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-- we only cope with a single result for foreign calls
-genCCall (CmmPrim op) [(r,_)] args vols = do
+genCCall (CmmPrim op) [(r,_)] args = do
case op of
MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args
MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args
case op of
MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args
MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args
@@
-3038,14
+3038,14
@@
genCCall (CmmPrim op) [(r,_)] args vols = do
MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args
MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args
MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args
MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args
- other_op -> outOfLineFloatOp op r args vols
+ other_op -> outOfLineFloatOp op r args
where
actuallyInlineFloatOp rep instr [(x,_)]
= do res <- trivialUFCode rep instr x
any <- anyReg res
where
actuallyInlineFloatOp rep instr [(x,_)]
= do res <- trivialUFCode rep instr x
any <- anyReg res
- return (any (getRegisterReg r))
+ return (any (getRegisterReg (CmmLocal r)))
-genCCall target dest_regs args vols = do
+genCCall target dest_regs args = do
let
sizes = map (arg_size . cmmExprRep . fst) (reverse args)
#if !darwin_TARGET_OS
let
sizes = map (arg_size . cmmExprRep . fst) (reverse args)
#if !darwin_TARGET_OS
@@
-3108,8
+3108,8
@@
genCCall target dest_regs args vols = do
rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest))
where
r_dest_hi = getHiVRegFromLo r_dest
rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest))
where
r_dest_hi = getHiVRegFromLo r_dest
- rep = cmmRegRep dest
- r_dest = getRegisterReg dest
+ rep = localRegRep dest
+ r_dest = getRegisterReg (CmmLocal dest)
assign_code many = panic "genCCall.assign_code many"
return (push_code `appOL`
assign_code many = panic "genCCall.assign_code many"
return (push_code `appOL`
@@
-3173,23
+3173,23
@@
genCCall target dest_regs args vols = do
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)]
- -> Maybe [GlobalReg] -> NatM InstrBlock
-outOfLineFloatOp mop res args vols
+outOfLineFloatOp :: CallishMachOp -> CmmFormal -> CmmActuals
+ -> NatM InstrBlock
+outOfLineFloatOp mop res args
= do
targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl
let target = CmmForeignCall targetExpr CCallConv
= do
targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl
let target = CmmForeignCall targetExpr CCallConv
- if cmmRegRep res == F64
+ if localRegRep res == F64
then
then
- stmtToInstrs (CmmCall target [(res,FloatHint)] args vols)
+ stmtToInstrs (CmmCall target [(res,FloatHint)] args NoC_SRT)
else do
uq <- getUniqueNat
let
else do
uq <- getUniqueNat
let
- tmp = CmmLocal (LocalReg uq F64)
+ tmp = LocalReg uq F64 KindNonPtr
-- in
-- in
- code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args vols)
- code2 <- stmtToInstrs (CmmAssign res (CmmReg tmp))
+ code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args NoC_SRT)
+ code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
lbl = mkForeignLabel fn Nothing False
return (code1 `appOL` code2)
where
lbl = mkForeignLabel fn Nothing False
@@
-3233,14
+3233,14
@@
outOfLineFloatOp mop res args vols
#if x86_64_TARGET_ARCH
#if x86_64_TARGET_ARCH
-genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL
+genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-genCCall (CmmPrim op) [(r,_)] args vols =
- outOfLineFloatOp op r args vols
+genCCall (CmmPrim op) [(r,_)] args =
+ outOfLineFloatOp op r args
-genCCall target dest_regs args vols = do
+genCCall target dest_regs args = do
-- load up the register arguments
(stack_args, aregs, fregs, load_args_code)
-- load up the register arguments
(stack_args, aregs, fregs, load_args_code)
@@
-3426,7
+3426,7
@@
genCCall target dest_regs args vols = do
stack only immediately prior to the call proper. Sigh.
-}
stack only immediately prior to the call proper. Sigh.
-}
-genCCall target dest_regs argsAndHints vols = do
+genCCall target dest_regs argsAndHints = do
let
args = map fst argsAndHints
argcode_and_vregs <- mapM arg_to_int_vregs args
let
args = map fst argsAndHints
argcode_and_vregs <- mapM arg_to_int_vregs args
@@
-3622,7
+3622,7
@@
outOfLineFloatOp mop =
genCCall (CmmPrim MO_WriteBarrier) _ _ _
= return $ unitOL LWSYNC
genCCall (CmmPrim MO_WriteBarrier) _ _ _
= return $ unitOL LWSYNC
-genCCall target dest_regs argsAndHints vols
+genCCall target dest_regs argsAndHints
= ASSERT (not $ any (`elem` [I8,I16]) argReps)
-- we rely on argument promotion in the codeGen
do
= ASSERT (not $ any (`elem` [I8,I16]) argReps)
-- we rely on argument promotion in the codeGen
do