[project @ 2000-12-07 11:00:43 by sewardj]

Minor enhancements to printing machinery to aid debugging the BC generator.

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index f53a56f..7d28354 100644 (file)
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -35,7 +35,8 @@ module CoreSyn (
        seqRules, seqExpr, seqExprs, seqUnfolding,
 
        -- Annotated expressions
-       AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate',
+       AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
+       deAnnotate, deAnnotate', deAnnAlt,
 
        -- Core rules
        CoreRules(..),  -- Representation needed by friends
@@ -572,7 +573,8 @@ deAnnotate' (AnnLet bind body)
 
 deAnnotate' (AnnCase scrut v alts)
   = Case (deAnnotate scrut) v (map deAnnAlt alts)
-  where
-    deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
+
+deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 \end{code}
 

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 22de1fc..004d830 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -11,7 +11,7 @@
 module PprCore (
        pprCoreExpr, pprParendExpr,
        pprCoreBinding, pprCoreBindings, pprIdBndr,
-       pprCoreBinding, pprCoreBindings,
+       pprCoreBinding, pprCoreBindings, pprCoreAlt,
        pprCoreRules, pprCoreRule, pprIdCoreRule
     ) where
 
@@ -71,6 +71,7 @@ pprCoreBinding  = pprTopBind pprCoreEnv
 pprCoreExpr     = ppr_noparend_expr pprCoreEnv
 pprParendExpr   = ppr_parend_expr   pprCoreEnv
 pprArg                 = ppr_arg pprCoreEnv
+pprCoreAlt      = ppr_alt pprCoreEnv
 
 pprCoreEnv = initCoreEnv pprCoreBinder
 \end{code}
@@ -206,14 +207,12 @@ ppr_expr add_par pe (Case expr var alts)
   = add_par $
     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
              ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
-        nest 4 (sep (punctuate semi (map ppr_alt alts))),
+        nest 4 (sep (punctuate semi (map (ppr_alt pe) alts))),
         char '}'
     ]
   where
     ppr_bndr = pBndr pe CaseBind
  
-    ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
-                                   4 (ppr_noparend_expr pe rhs)
 
 -- special cases: let ... in let ...
 -- ("disgusting" SLPJ)
@@ -271,6 +270,9 @@ ppr_expr add_par pe (Note InlineCall expr)
 ppr_expr add_par pe (Note InlineMe expr)
   = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
 
+ppr_alt pe (con, args, rhs) 
+  = hang (ppr_case_pat pe con args) 4 (ppr_noparend_expr pe rhs)
+
 ppr_case_pat pe con@(DataAlt dc) args
   | isTupleTyCon tc
   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 915e404..204a6c3 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -16,6 +16,7 @@ import OrdList                ( OrdList, consOL, snocOL, appOL, unitOL,
 import FiniteMap       ( FiniteMap, addListToFM, listToFM, 
                          addToFM, lookupFM, fmToList, emptyFM )
 import CoreSyn
+import PprCore         ( pprCoreExpr, pprCoreAlt )
 import Literal         ( Literal(..) )
 import PrimRep         ( PrimRep(..) )
 import CoreFVs         ( freeVars )
@@ -109,10 +110,12 @@ pprAltCode discrs_n_codes
      where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
 
 instance Outputable a => Outputable (ProtoBCO a) where
-   ppr (ProtoBCO name instrs)
+   ppr (ProtoBCO name instrs origin)
       = (text "ProtoBCO" <+> ppr name <> colon)
         $$ nest 6 (vcat (map ppr (fromOL instrs)))
-
+        $$ case origin of
+              Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
+              Right rhs -> pprCoreExpr (deAnnotate rhs)
 \end{code}
 
 %************************************************************************
@@ -125,7 +128,13 @@ instance Outputable a => Outputable (ProtoBCO a) where
 
 type BCInstrList = OrdList BCInstr
 
-data ProtoBCO a = ProtoBCO a BCInstrList
+data ProtoBCO a 
+   = ProtoBCO a                        -- name, in some sense
+              BCInstrList              -- instrs
+                                       -- what the BCO came from
+              (Either [AnnAlt Id VarSet]
+                      (AnnExpr Id VarSet))
+
 
 type Sequel = Int      -- back off to this depth before ENTER
 
@@ -154,7 +163,7 @@ schemeR_wrk nm (args, body)
          argcheck  = if null args then nilOL else unitOL (ARGCHECK szw_args)
      in
      schemeE szw_args 0 p_init body            `thenBc` \ body_code ->
-     emitBc (ProtoBCO (getName nm) (appOL argcheck body_code))
+     emitBc (ProtoBCO (getName nm) (appOL argcheck body_code) (Right body))
 
 
 -- Compile code to apply the given expression to the remaining args
@@ -242,7 +251,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
      mkMultiBranch alt_stuff                           `thenBc` \ alt_final ->
      let 
          alt_bco_name = getName bndr
-         alt_bco      = ProtoBCO alt_bco_name alt_final
+         alt_bco      = ProtoBCO alt_bco_name alt_final (Left alts)
      in
      schemeE (d + ret_frame_sizeW) 
              (d + ret_frame_sizeW) p scrut             `thenBc` \ scrut_code ->
@@ -552,7 +561,7 @@ data BCO a = BCO [Word16]   -- instructions
 
 -- Top level assembler fn.
 assembleBCO :: ProtoBCO Name -> BCO Name
-assembleBCO (ProtoBCO nm instrs_ordlist)
+assembleBCO (ProtoBCO nm instrs_ordlist origin)
    = let
          -- pass 1: collect up the offsets of the local labels
          instrs = fromOL instrs_ordlist