From: sewardj <unknown>
Date: Thu, 7 Dec 2000 11:00:43 +0000 (+0000)
Subject: [project @ 2000-12-07 11:00:43 by sewardj]
X-Git-Tag: Approximately_9120_patches~3174
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3d9ef04df6daad6ea2477be03659b94ae23648a9;p=ghc-hetmet.git

[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
--- 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
--- 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
--- 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