[project @ 2000-01-13 12:59:58 by sewardj]

Added a rudimentary implementation of -ddump-stix.

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 197bee5..da827f5 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -360,6 +360,7 @@ pprAbsC (CCodeBlock lbl abs_C) _
     else
     case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
     vcat [
+        char ' ',
        hcat [text (if (externallyVisibleCLabel lbl)
                          then "FN_("   -- abbreviations to save on output
                          else "IFN_("),
@@ -370,7 +371,8 @@ pprAbsC (CCodeBlock lbl abs_C) _
        nest 8 (ptext SLIT("FB_")),
        nest 8 (pprAbsC abs_C (costs abs_C)),
        nest 8 (ptext SLIT("FE_")),
-       char '}' ]
+       char '}',
+        char ' ' ]
     }
 
 

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 2d105bd..589b517 100644 (file)
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -43,6 +43,7 @@ module CmdLineOpts (
        opt_D_show_passes,
        opt_D_dump_rn_trace,
        opt_D_dump_rn_stats,
+        opt_D_dump_stix,
        opt_D_source_stats,
        opt_D_verbose_core2core,
        opt_D_verbose_stg2stg,
@@ -330,6 +331,7 @@ opt_D_dump_worker_wrapper   = opt_D_dump_most || lookUp  SLIT("-ddump-workwrap")
 opt_D_show_passes              = opt_D_dump_most || lookUp  SLIT("-dshow-passes")
 opt_D_dump_rn_trace            = opt_D_dump_all  || lookUp  SLIT("-ddump-rn-trace")
 opt_D_dump_rn_stats            = opt_D_dump_most || lookUp  SLIT("-ddump-rn-stats")
+opt_D_dump_stix                = opt_D_dump_all  || lookUp  SLIT("-ddump-stix")
 opt_D_dump_simpl_stats         = opt_D_dump_most || lookUp  SLIT("-ddump-simpl-stats")
 opt_D_source_stats             = opt_D_dump_most || lookUp  SLIT("-dsource-stats")
 opt_D_verbose_core2core                = opt_D_dump_all  || lookUp  SLIT("-dverbose-simpl")

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 81e1760..cf2f0df 100644 (file)
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -36,6 +36,8 @@ codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs
     -- but not both.  [Allowing for both gives a space leak on
     -- flat_abstractC.  WDP 94/10]
 
+    dumpIfSet opt_D_dump_stix "Final stix code" stix_final >>
+
     dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d   >>
     doOutput opt_ProduceS ncg_output_w                         >>
 
@@ -73,7 +75,8 @@ codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs
     ncg_output_d = error "*** GHC not built with a native-code generator ***"
     ncg_output_w = ncg_output_d
 #else
-    ncg_output_d = nativeCodeGen flat_absC_ncg ncg_uniqs
+    (stix_raw, stix_opt, stix_final, ncg_output_d)
+       = nativeCodeGen flat_absC_ncg ncg_uniqs
     ncg_output_w = (\ f -> printForAsm f ncg_output_d)
 #endif
 

diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 1a08d46..7e92c9f 100644 (file)
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -20,7 +20,7 @@ import AsmRegAlloc    ( runRegAllocate )
 import OrdList         ( OrdList )
 import PrimOp          ( commutableOp, PrimOp(..) )
 import RegAllocInfo    ( mkMRegsState, MRegsState )
-import Stix            ( StixTree(..), StixReg(..) )
+import Stix            ( StixTree(..), StixReg(..), pprStixTrees )
 import PrimRep         ( isFloatingRep )
 import UniqSupply      ( returnUs, thenUs, mapUs, initUs_, UniqSM, UniqSupply )
 import UniqFM          ( UniqFM, emptyUFM, addToUFM, lookupUFM )
@@ -77,34 +77,39 @@ The machine-dependent bits break down as follows:
 
 So, here we go:
 \begin{code}
-nativeCodeGen :: AbstractC -> UniqSupply -> SDoc
+nativeCodeGen :: AbstractC -> UniqSupply -> (SDoc, SDoc, SDoc, SDoc)
 nativeCodeGen absC us = initUs_ us (runNCG absC)
 
+runNCG :: AbstractC -> UniqSM (SDoc, SDoc, SDoc, SDoc)
 runNCG absC
-  = genCodeAbstractC absC      `thenUs` \ treelists ->
+  = genCodeAbstractC absC      `thenUs` \ stixRaw ->
     let
-       stix = map (map genericOpt) treelists
-    in
+       stixOpt   = map (map genericOpt) stixRaw
 #if i386_TARGET_ARCH
-    let
-       stix' = map floatFix stix
-    in
-    codeGen stix'
+        stixFinal = map floatFix stixOpt
 #else
-    codeGen stix
+        stixFinal = stixOpt
 #endif
+    in
+        codeGen (stixRaw, stixOpt, stixFinal)
 \end{code}
 
 @codeGen@ is the top-level code-generation function:
 \begin{code}
-codeGen :: [[StixTree]] -> UniqSM SDoc
+codeGen :: ([[StixTree]],[[StixTree]],[[StixTree]]) 
+           -> UniqSM (SDoc, SDoc, SDoc, SDoc)
 
-codeGen trees
-  = mapUs genMachCode trees    `thenUs` \ dynamic_codes ->
+codeGen (stixRaw, stixOpt, stixFinal)
+  = mapUs genMachCode stixFinal        `thenUs` \ dynamic_codes ->
     let
        static_instrs = scheduleMachCode dynamic_codes
     in
-    returnUs (vcat (map pprInstr static_instrs))
+    returnUs (
+       text "ppr'd stixRaw",
+       text "ppr'd stixOpt",
+       vcat (map pprStixTrees stixFinal),
+       vcat (map pprInstr static_instrs)
+    )
 \end{code}
 
 Top level code generator for a chunk of stix code:

diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 89bb3cc..92761f2 100644 (file)
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -5,7 +5,7 @@
 \begin{code}
 module Stix (
        CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
-       sStLitLbl,
+       sStLitLbl, pprStixTrees,
 
        stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim, stgTagReg,
        getUniqLabelNCG,
@@ -19,10 +19,10 @@ import Ratio                ( Rational )
 
 import AbsCSyn         ( node, tagreg, MagicId(..) )
 import AbsCUtils       ( magicIdPrimRep )
-import CallConv                ( CallConv )
-import CLabel          ( mkAsmTempLabel, CLabel )
-import PrimRep          ( PrimRep )
-import PrimOp           ( PrimOp )
+import CallConv                ( CallConv, pprCallConv )
+import CLabel          ( mkAsmTempLabel, CLabel, pprCLabel )
+import PrimRep          ( PrimRep, showPrimRep )
+import PrimOp           ( PrimOp, pprPrimOp )
 import Unique           ( Unique )
 import SMRep           ( fixedHdrSize, arrHdrSize )
 import UniqSupply      ( returnUs, thenUs, getUniqueUs, UniqSM )
@@ -105,6 +105,49 @@ data StixTree
 
 sStLitLbl :: FAST_STRING -> StixTree
 sStLitLbl s = StLitLbl (ptext s)
+
+
+pprStixTrees :: [StixTree] -> SDoc
+pprStixTrees ts 
+  = vcat [
+       vcat (map ppStixTree ts),
+       char ' ',
+       char ' '
+    ]
+
+paren t = char '(' <> t <> char ')'
+
+ppStixTree :: StixTree -> SDoc
+ppStixTree t 
+   = case t of
+       StSegment cseg -> paren (ppCodeSegment cseg)
+       StInt i        -> paren (integer i)
+       StDouble        rat   -> paren (text "Double" <+> rational rat)
+       StString str   -> paren (text "Str" <+> ptext str)
+       StComment str  -> paren (text "Comment" <+> ptext str)
+       StLitLbl sd    -> sd
+       StLitLit ll    -> paren (text "LitLit" <+> ptext ll)
+       StCLbl lbl     -> pprCLabel lbl
+       StReg reg      -> ppStixReg reg
+       StIndex k b o  -> paren (ppStixTree b <+> char '+' <> 
+                                pprPrimRep k <+> ppStixTree o)
+       StInd k t      -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']'
+       StAssign k d s -> ppStixTree d <> text "  :=" <> pprPrimRep k 
+                                          <> text "  " <> ppStixTree s
+       StLabel ll     -> pprCLabel ll <+> char ':'
+       StFunBegin ll  -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
+       StFunEnd ll    -> paren (text "FunEnd" <+> pprCLabel ll)
+       StJump t       -> paren (text "Jump" <+> ppStixTree t)
+       StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
+       StCondJump l t -> paren (text "JumpC" <+> pprCLabel l <+> ppStixTree t)
+       StData k ds -> paren (text "Data" <+> pprPrimRep k <+>
+                      hsep (map ppStixTree ds))
+       StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+> hsep (map ppStixTree ts))
+       StCall nm cc k args
+          -> paren (text "Call" <+> ptext nm <+>
+               pprCallConv cc <+> pprPrimRep k <+> hsep (map ppStixTree args))
+     where 
+        pprPrimRep = text . showPrimRep
 \end{code}
 
 Stix registers can have two forms.  They {\em may} or {\em may not}
@@ -116,6 +159,25 @@ data StixReg
 
   | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
                                        -- the abstract C.
+
+ppStixReg (StixMagicId mid)
+   = ppMId mid
+ppStixReg (StixTemp u pr)
+   = hcat [text "Temp(", ppr u, ppr pr, char ')']
+
+
+ppMId BaseReg              = text "BaseReg"
+ppMId (VanillaReg kind n)  = hcat [text "IntReg(", int (I# n), char ')']
+ppMId (FloatReg n)         = hcat [text "FltReg(", int (I# n), char ')']
+ppMId (DoubleReg n)        = hcat [text "DblReg(", int (I# n), char ')']
+ppMId (LongReg kind n)     = hcat [text "LongReg(", int (I# n), char ')']
+ppMId Sp                   = text "Sp"
+ppMId Su                   = text "Su"
+ppMId SpLim                = text "SpLim"
+ppMId Hp                   = text "Hp"
+ppMId HpLim                = text "HpLim"
+ppMId CurCostCentre        = text "CCC"
+ppMId VoidReg              = text "VoidReg"
 \end{code}
 
 We hope that every machine supports the idea of data segment and text
@@ -123,7 +185,8 @@ segment (or that it has no segments at all, and we can lump these
 together).
 
 \begin{code}
-data CodeSegment = DataSegment | TextSegment deriving Eq
+data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
+ppCodeSegment = text . show
 
 type StixTreeList = [StixTree] -> [StixTree]
 \end{code}