#include "HsVersions.h"
#include "nativeGen/NCG.h"
-import IO ( Handle )
import List ( intersperse )
import MachMisc
import AbsCStixGen ( genCodeAbstractC )
import AbsCSyn ( AbstractC, MagicId )
+import AbsCUtils ( mkAbsCStmtList )
import AsmRegAlloc ( runRegAllocate )
import PrimOp ( commutableOp, PrimOp(..) )
-import RegAllocInfo ( mkMRegsState, MRegsState, findReservedRegs )
+import RegAllocInfo ( findReservedRegs )
import Stix ( StixTree(..), StixReg(..),
- pprStixTrees, ppStixTree, CodeSegment(..),
+ pprStixTrees, pprStixTree, CodeSegment(..),
stixCountTempUses, stixSubst,
NatM, initNat, mapNat,
NatM_State, mkNatM_State,
uniqOfNatM_State, deltaOfNatM_State )
-import PrimRep ( isFloatingRep, PrimRep(..) )
import UniqSupply ( returnUs, thenUs, mapUs, initUs,
- initUs_, UniqSM, UniqSupply )
+ initUs_, UniqSM, UniqSupply,
+ lazyThenUs, lazyMapUs )
import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) )
import OrdList ( fromOL, concatOL )
-import Outputable
+import Outputable
\end{code}
\begin{code}
nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc)
nativeCodeGen absC us
- = let (stixRaw, us1) = initUs us (genCodeAbstractC absC)
- stixOpt = map genericOpt stixRaw
- insns = initUs_ us1 (codeGen stixOpt)
- debug_stix = vcat (map pprStixTrees stixOpt)
- in
- trace "nativeGen: begin"
- (debug_stix, insns)
-\end{code}
-
-@codeGen@ is the top-level code-generation function:
-\begin{code}
-codeGen :: [[StixTree]] -> UniqSM SDoc
-
-codeGen stixFinal
- = mapUs genMachCode stixFinal `thenUs` \ dynamic_codes ->
- let
- fp_kludge :: [Instr] -> [Instr]
- fp_kludge = IF_ARCH_i386(i386_insert_ffrees,id)
-
- static_instrss :: [[Instr]]
- static_instrss = map fp_kludge (scheduleMachCode dynamic_codes)
- docs = map (vcat . map pprInstr) static_instrss
-
- -- for debugging only
- docs_prealloc = map (vcat . map pprInstr . fromOL)
- dynamic_codes
- text_prealloc = vcat (intersperse (char ' ' $$ char ' ') docs_prealloc)
- in
- -- trace (showSDoc text_prealloc) (
- returnUs (vcat (intersperse (char ' '
- $$ ptext SLIT("# ___stg_split_marker")
- $$ char ' ')
- docs))
- -- )
+ = let absCstmts = mkAbsCStmtList absC
+ (sdoc_pairs, us1) = initUs us (lazyMapUs absCtoNat absCstmts)
+ stix_sdocs = map fst sdoc_pairs
+ insn_sdocs = map snd sdoc_pairs
+
+ insn_sdoc = my_vcat insn_sdocs
+ stix_sdoc = vcat stix_sdocs
+
+# ifdef NCG_DEBUG
+ my_trace m x = trace m x
+ my_vcat sds = vcat (intersperse (char ' '
+ $$ ptext SLIT("# ___ncg_debug_marker")
+ $$ char ' ')
+ sds)
+# else
+ my_vcat sds = vcat sds
+ my_trace m x = x
+# endif
+ in
+ my_trace "nativeGen: begin"
+ (stix_sdoc, insn_sdoc)
+
+
+absCtoNat :: AbstractC -> UniqSM (SDoc, SDoc)
+absCtoNat absC
+ = genCodeAbstractC absC `thenUs` \ stixRaw ->
+ genericOpt stixRaw `bind` \ stixOpt ->
+ genMachCode stixOpt `thenUs` \ pre_regalloc ->
+ regAlloc pre_regalloc `bind` \ almost_final ->
+ x86fp_kludge almost_final `bind` \ final_mach_code ->
+ vcat (map pprInstr final_mach_code) `bind` \ final_sdoc ->
+ pprStixTrees stixOpt `bind` \ stix_sdoc ->
+ returnUs (stix_sdoc, final_sdoc)
+ where
+ bind f x = x f
+
+ x86fp_kludge :: [Instr] -> [Instr]
+ x86fp_kludge = IF_ARCH_i386(i386_insert_ffrees,id)
+
+ regAlloc :: InstrBlock -> [Instr]
+ regAlloc = runRegAllocate allocatableRegs findReservedRegs
\end{code}
Top level code generator for a chunk of stix code. For this part of
(int final_delta)
\end{code}
-The next bit does the code scheduling. The scheduler must also deal
-with register allocation of temporaries. Much parallelism can be
-exposed via the OrdList, but more might occur, so further analysis
-might be needed.
-
-\begin{code}
-scheduleMachCode :: [InstrBlock] -> [[Instr]]
-
-scheduleMachCode
- = map (runRegAllocate freeRegsState findReservedRegs)
- where
- freeRegsState = mkMRegsState (extractMappedRegNos freeRegs)
-\end{code}
-
%************************************************************************
%* *
\subsection[NCOpt]{The Generic Optimiser}
-- second assignment would be substituted for, giving nonsense
-- code. As far as I can see, StixTemps are only ever assigned
-- to once. It would be nice to be sure!
+
stixPeep ( t1@(StAssign pka (StReg (StixTemp u pk)) rhs)
: t2
: ts )
| stixCountTempUses u t2 == 1
&& sum (map (stixCountTempUses u) ts) == 0
- = trace ("nativeGen: stixInline: " ++ showSDoc (ppStixTree rhs))
+ =
+# ifdef NCG_DEBUG
+ trace ("nativeGen: inlining " ++ showSDoc (pprStixTree rhs))
+# endif
(stixPeep (stixSubst u rhs t2 : ts))
stixPeep (t1:t2:ts) = t1 : stixPeep (t2:ts)
stixPeep [t1] = [t1]
stixPeep [] = []
+
+-- disable stix inlining until we figure out how to fix the
+-- latent bugs in the register allocator which are exposed by
+-- the inliner.
+--stixPeep = id
\end{code}
For most nodes, just optimize the children.
stixConFold (StAssign pk dst src)
= StAssign pk (stixConFold dst) (stixConFold src)
-stixConFold (StJump addr) = StJump (stixConFold addr)
+stixConFold (StJump dsts addr) = StJump dsts (stixConFold addr)
stixConFold (StCondJump addr test)
= StCondJump addr (stixConFold test)
FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp,
DoubleGtOp, DoubleGeOp, DoubleEqOp, DoubleNeOp, DoubleLtOp, DoubleLeOp
]
-\end{code}
\ No newline at end of file
+\end{code}
projects / ghc-hetmet.git / blobdiff