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
/
AsmCodeGen.lhs
diff --git
a/compiler/nativeGen/AsmCodeGen.lhs
b/compiler/nativeGen/AsmCodeGen.lhs
index
ff3063c
..
f954d52
100644
(file)
--- a/
compiler/nativeGen/AsmCodeGen.lhs
+++ b/
compiler/nativeGen/AsmCodeGen.lhs
@@
-108,12
+108,12
@@
The machine-dependent bits break down as follows:
-- NB. We *lazilly* compile each block of code for space reasons.
-- NB. We *lazilly* compile each block of code for space reasons.
-nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen dflags cmms us
= let (res, _) = initUs us $
cgCmm (concat (map add_split cmms))
nativeCodeGen dflags cmms us
= let (res, _) = initUs us $
cgCmm (concat (map add_split cmms))
- cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
+ cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
case unzip3 results of { (cmms,docs,imps) ->
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
case unzip3 results of { (cmms,docs,imps) ->
@@
-196,7
+196,7
@@
nativeCodeGen dflags cmms us
-- Complete native code generation phase for a single top-level chunk
-- of Cmm.
-- Complete native code generation phase for a single top-level chunk
-- of Cmm.
-cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
+cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])
cmmNativeGen dflags cmm
= {-# SCC "fixAssigns" #-}
fixAssignsTop cmm `thenUs` \ fixed_cmm ->
cmmNativeGen dflags cmm
= {-# SCC "fixAssigns" #-}
fixAssignsTop cmm `thenUs` \ fixed_cmm ->
@@
-390,7
+390,7
@@
apply_mapping ufm (CmmProc info lbl params blocks)
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode cmm_top
= do { initial_us <- getUs
genMachCode cmm_top
= do { initial_us <- getUs
@@
-412,7
+412,7
@@
genMachCode cmm_top
-- the generic optimiser below, to avoid having two separate passes
-- over the Cmm.
-- the generic optimiser below, to avoid having two separate passes
-- over the Cmm.
-fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
@@
-444,16
+444,12
@@
fixAssign (CmmAssign (CmmGlobal reg) src)
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
-fixAssign (CmmCall target results args vols)
+{-
+fixAssign (CmmCall target results args)
= mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
= mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
- returnUs (caller_save ++
- CmmCall target results' args vols :
- caller_restore ++
+ returnUs (CmmCall target results' args :
concat stores)
where
concat stores)
where
- -- we also save/restore any caller-saves STG registers here
- (caller_save, caller_restore) = callerSaveVolatileRegs vols
-
fixResult g@(CmmGlobal reg,hint) =
case get_GlobalReg_reg_or_addr reg of
Left realreg -> returnUs (g, [])
fixResult g@(CmmGlobal reg,hint) =
case get_GlobalReg_reg_or_addr reg of
Left realreg -> returnUs (g, [])
@@
-464,6
+460,7
@@
fixAssign (CmmCall target results args vols)
[CmmStore baseRegAddr (CmmReg local)])
fixResult other =
returnUs (other,[])
[CmmStore baseRegAddr (CmmReg local)])
fixResult other =
returnUs (other,[])
+-}
fixAssign other_stmt = returnUs [other_stmt]
fixAssign other_stmt = returnUs [other_stmt]
@@
-493,7
+490,7
@@
Ideas for other things we could do (ToDo):
temp assignments, and certain assigns to mem...)
-}
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
+cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm top@(CmmData _ _) = (top, [])
cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
cmmToCmm top@(CmmData _ _) = (top, [])
cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
@@
-539,7
+536,7
@@
cmmStmtConFold stmt
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
- CmmCall target regs args vols
+ CmmCall target regs args srt
-> do target' <- case target of
CmmForeignCall e conv -> do
e' <- cmmExprConFold CallReference e
-> do target' <- case target of
CmmForeignCall e conv -> do
e' <- cmmExprConFold CallReference e
@@
-548,7
+545,7
@@
cmmStmtConFold stmt
args' <- mapM (\(arg, hint) -> do
arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
args' <- mapM (\(arg, hint) -> do
arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
- return $ CmmCall target' regs args' vols
+ return $ CmmCall target' regs args' srt
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test