[project @ 2002-04-29 14:03:38 by simonmar]

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

diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index cf37bc9..d3acf16 100644 (file)
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -16,7 +16,7 @@ import MachCode
 import PprMach
 
 import AbsCStixGen     ( genCodeAbstractC )
-import AbsCSyn         ( AbstractC )
+import AbsCSyn         ( AbstractC, MagicId(..) )
 import AbsCUtils       ( mkAbsCStmtList, magicIdPrimRep )
 import AsmRegAlloc     ( runRegAllocate )
 import MachOp          ( MachOp(..), isCommutableMachOp, isComparisonMachOp )
@@ -35,6 +35,7 @@ import MachMisc               ( IF_ARCH_i386(i386_insert_ffrees,) )
 
 import qualified Pretty
 import Outputable
+import FastString
 
 -- DEBUGGING ONLY
 --import OrdList
@@ -98,7 +99,7 @@ nativeCodeGen absC us
          insn_sdoc         = my_vcat insn_sdocs
          stix_sdoc         = vcat stix_sdocs
 
-#        ifdef NCG_DEBUG */
+#        ifdef NCG_DEBUG
          my_trace m x = trace m x
          my_vcat sds = Pretty.vcat (
                           intersperse (
@@ -127,7 +128,8 @@ absCtoNat absC
      _scc_ "x86fp_kludge"     x86fp_kludge almost_final    `bind`   \ final_mach_code ->
      _scc_ "vcat"     Pretty.vcat (map pprInstr final_mach_code)  `bind`   \ final_sdoc ->
      _scc_ "pprStixTrees"     pprStixStmts stixOpt         `bind`   \ stix_sdoc ->
-     returnUs (stix_sdoc, final_sdoc)
+     returnUs ({-\_ -> Pretty.vcat (map pprInstr almost_final),-}
+               stix_sdoc, final_sdoc)
      where
         bind f x = x f
 
@@ -227,17 +229,19 @@ stixStmt_ConFold stmt
            -> StAssignReg pk reg (stixExpr_ConFold src)
         StAssignReg pk reg@(StixMagicId mid) src
            -- Replace register leaves with appropriate StixTrees for 
-           -- the given target.
-           -> case get_MagicId_reg_or_addr mid of
-                 Left  realreg 
-                    -> StAssignReg pk reg (stixExpr_ConFold src)
-                 Right baseRegAddr 
-                    -> stixStmt_ConFold
-                          (StAssignMem pk baseRegAddr src)
+           -- the given target. MagicIds which map to a reg on this arch are left unchanged. 
+           -- Assigning to BaseReg is always illegal, so we check for that.
+           -> case mid of { 
+                 BaseReg -> panic "stixStmt_ConFold: assignment to BaseReg";
+                 other ->
+                 case get_MagicId_reg_or_addr mid of
+                    Left  realreg 
+                       -> StAssignReg pk reg (stixExpr_ConFold src)
+                    Right baseRegAddr 
+                       -> stixStmt_ConFold (StAssignMem pk baseRegAddr src)
+              }
         StAssignMem pk addr src
            -> StAssignMem pk (stixExpr_ConFold addr) (stixExpr_ConFold src)
-        StAssignMachOp lhss mop args
-           -> StAssignMachOp lhss mop (map stixExpr_ConFold args)
         StVoidable expr
            -> StVoidable (stixExpr_ConFold expr)
         StJump dsts addr
@@ -246,7 +250,7 @@ stixStmt_ConFold stmt
            -> let test_opt = stixExpr_ConFold test
               in 
               if  manifestlyZero test_opt
-              then StComment (_PK_ ("deleted: " ++ showSDoc (pprStixStmt stmt)))
+              then StComment (mkFastString ("deleted: " ++ showSDoc (pprStixStmt stmt)))
               else StCondJump addr (stixExpr_ConFold test)
         StData pk datas
            -> StData pk (map stixExpr_ConFold datas)
@@ -276,11 +280,16 @@ stixExpr_ConFold expr
            -> stixMachOpFold mop (map stixExpr_ConFold args)
         StReg (StixMagicId mid)
            -- Replace register leaves with appropriate StixTrees for 
-           -- the given target.
+           -- the given target.  MagicIds which map to a reg on this arch are left unchanged. 
+           -- For the rest, BaseReg is taken to mean the address of the reg table 
+           -- in MainCapability, and for all others we generate an indirection to 
+           -- its location in the register table.
            -> case get_MagicId_reg_or_addr mid of
                  Left  realreg -> expr
                  Right baseRegAddr 
-                    -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr)
+                    -> case mid of 
+                          BaseReg -> stixExpr_ConFold baseRegAddr
+                          other   -> stixExpr_ConFold (StInd (magicIdPrimRep mid) baseRegAddr)
         other
            -> other
 \end{code}