[project @ 2001-05-03 09:02:44 by simonpj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / AsmCodeGen.lhs

diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 8e15db8..60d9b49 100644 (file)
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -16,23 +16,23 @@ import MachCode
 import PprMach
 
 import AbsCStixGen     ( genCodeAbstractC )
-import AbsCSyn         ( AbstractC, MagicId )
+import AbsCSyn         ( AbstractC )
 import AbsCUtils       ( mkAbsCStmtList )
 import AsmRegAlloc     ( runRegAllocate )
 import PrimOp          ( commutableOp, PrimOp(..) )
 import RegAllocInfo    ( findReservedRegs )
 import Stix            ( StixTree(..), StixReg(..), 
-                          pprStixTrees, pprStixTree, CodeSegment(..),
+                          pprStixTrees, pprStixTree, 
                           stixCountTempUses, stixSubst,
-                          NatM, initNat, mapNat,
-                          NatM_State, mkNatM_State,
+                          initNat, mapNat,
+                          mkNatM_State,
                           uniqOfNatM_State, deltaOfNatM_State )
-import UniqSupply      ( returnUs, thenUs, mapUs, initUs, 
-                          initUs_, UniqSM, UniqSupply,
-                         lazyThenUs, lazyMapUs )
+import UniqSupply      ( returnUs, thenUs, initUs, 
+                          UniqSM, UniqSupply,
+                         lazyMapUs )
 import MachMisc                ( IF_ARCH_i386(i386_insert_ffrees,) )
 
-import OrdList         ( fromOL, concatOL )
+import OrdList         ( concatOL )
 import Outputable
 
 \end{code}
@@ -95,7 +95,7 @@ nativeCodeGen absC us
          insn_sdoc         = my_vcat insn_sdocs
          stix_sdoc         = vcat stix_sdocs
 
-#        if NCG_DEBUG
+#        ifdef NCG_DEBUG
          my_trace m x = trace m x
          my_vcat sds = vcat (intersperse (char ' ' 
                                           $$ ptext SLIT("# ___ncg_debug_marker")
@@ -112,13 +112,13 @@ nativeCodeGen absC us
 
 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 ->
+   = _scc_ "genCodeAbstractC" genCodeAbstractC absC        `thenUs` \ stixRaw ->
+     _scc_ "genericOpt"       genericOpt stixRaw           `bind`   \ stixOpt ->
+     _scc_ "genMachCode"      genMachCode stixOpt          `thenUs` \ pre_regalloc ->
+     _scc_ "regAlloc"         regAlloc pre_regalloc        `bind`   \ almost_final ->
+     _scc_ "x86fp_kludge"     x86fp_kludge almost_final    `bind`   \ final_mach_code ->
+     _scc_ "vcat"     vcat (map pprInstr final_mach_code)  `bind`   \ final_sdoc ->
+     _scc_ "pprStixTrees"    pprStixTrees stixOpt          `bind`   \ stix_sdoc ->
      returnUs (stix_sdoc, final_sdoc)
      where
         bind f x = x f
@@ -150,12 +150,10 @@ supply breaks abstraction.  Is that bad?
 genMachCode :: [StixTree] -> UniqSM InstrBlock
 
 genMachCode stmts initial_us
-  = let initial_st         = mkNatM_State initial_us 0
-        (blocks, final_st) = initNat initial_st 
-                                     (mapNat stmt2Instrs stmts)
-        instr_list         = concatOL blocks
-        final_us           = uniqOfNatM_State final_st
-        final_delta        = deltaOfNatM_State final_st
+  = let initial_st             = mkNatM_State initial_us 0
+        (instr_list, final_st) = initNat initial_st (stmtsToInstrs stmts)
+        final_us               = uniqOfNatM_State final_st
+        final_delta            = deltaOfNatM_State final_st
     in
         if   final_delta == 0
         then (instr_list, final_us)
@@ -224,7 +222,7 @@ stixConFold (StInd pk addr) = StInd pk (stixConFold addr)
 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)