dph-plugin: more work on pretty printer
authorBen Lippmeier <benl@ouroborus.net>
Thu, 2 Aug 2012 02:37:29 +0000 (12:37 +1000)
committerBen Lippmeier <benl@ouroborus.net>
Thu, 2 Aug 2012 02:37:29 +0000 (12:37 +1000)
dph-plugin/DPH/Core/Pretty.hs
dph-plugin/DPH/Pipeline.hs

index a93a87c..337e28d 100644 (file)
@@ -12,6 +12,8 @@ import Name
 import OccName
 import DataCon
 import Literal
+import Id
+import Unique
 
 
 -- Top Binds ------------------------------------------------------------------
@@ -44,21 +46,25 @@ pprBinding (binder, x)
               
 
 
-
 -- Expr -----------------------------------------------------------------------
 instance Pretty a => Pretty (Expr a) where
  pprPrec d xx
   = case xx of
-        Var  name       -> ppr name
-        Type _          -> empty        -- Discard Types
-        Coercion _      -> empty        -- Discard Coercions
+        Var  ident
+         -> pprBound ident 
+
+        -- Discard types and coersions
+        Type _          -> empty 
+        Coercion _      -> empty
+
+        -- Literals.
         Lit ll          -> ppr ll
 
+        -- Suppress Casts completely.
         Cast x _co
          -> pprPrec d x
---         pprParen' (d > 10)
---         $  pprPrec 11 x <+> text "`cast`" <+> text "..."
 
+        -- Abstractions.
         Lam{}
          -> pprParen' (d > 2)
          $  let (bndrs, body) = collectBinders xx
@@ -68,6 +74,7 @@ instance Pretty a => Pretty (Expr a) where
                         $ (breakWhen $ not $ isSimpleX body)
                          <> ppr body)
 
+        -- Applications.
         App x1 x2
          |  isTypeArg x2
          -> pprPrec d x1
@@ -78,12 +85,13 @@ instance Pretty a => Pretty (Expr a) where
                 <> nest 4 (breakWhen (not $ isSimpleX x2) 
                                 <> pprPrec 11 x2)
 
+        -- Destructors.
         Case x1 var ty [(con, binds, x2)]
          -> pprParen' (d > 2)
          $  text "let" 
                 <+> (fill 12 (ppr con <+> hsep (map ppr binds)))
 --                <>  breakWhen (not $ isSimpleX x1)
-                        <>  text "<-"
+                        <+>  text "<-"
                         <+> ppr x1
                         <+> text "in"
                 <$$> ppr x2
@@ -97,7 +105,7 @@ instance Pretty a => Pretty (Expr a) where
                         <> vcat (punctuate semi $ map pprAlt alts))
          <>  line <> rbrace
 
-
+        -- Binding.
         Let (NonRec b x1) x2
          -> pprParen' (d > 2)
          $  text "let" 
@@ -127,6 +135,19 @@ instance Pretty AltCon where
         DEFAULT         -> text "_"
 
 
+-- | Pretty print bound occurrences of an identifier
+pprBound :: Id -> Doc
+pprBound i
+        -- Suppress uniqueids from primops, dictionary functions and data constructors
+        -- These are unlikely to have conflicting base names.
+        |   isPrimOpId i || isDFunId i || isDataConWorkId i
+        =  ppr (idName i)
+
+        | otherwise
+        = ppr (idName i) <> text "_" <> text (show $ idUnique i)
+
+
+
 -- Literal --------------------------------------------------------------------
 instance Pretty Literal where
  ppr _  = text "<LITERAL>"
@@ -143,16 +164,17 @@ instance Pretty Coercion where
 
 
 -- Names ----------------------------------------------------------------------
-instance Pretty DataCon where
- ppr con 
-        = ppr (dataConName con)
-
-
 instance Pretty CoreBndr where
  ppr bndr
-        = ppr (Var.varName bndr)
+        =  ppr (idName bndr)
+        <> text "_"
+        <> text (show $ idUnique bndr)
 
 
+instance Pretty DataCon where
+ ppr con 
+        = ppr (dataConName con)
+
 instance Pretty Name where
  ppr name
         = ppr (nameOccName name)
index e2e7ff9..3bda3b8 100644 (file)
@@ -32,7 +32,7 @@ vectoriserPipeline
 
         -- Run the vectoriser.
    ,    CoreDoVectorisation 
-   ,    CoreDoPluginPass "Dump" (passDump "vectorised")
+   ,    CoreDoPluginPass "Dump" (passDump "1-vectorised")
 
         ---------------------
         -- In the following stages we inline the different combinator
@@ -50,7 +50,7 @@ vectoriserPipeline
                 , sm_inline     = True
                 , sm_case_case  = True } 
 
-   ,    CoreDoPluginPass "Dump" (passDump "closures")
+   ,    CoreDoPluginPass "Dump" (passDump "2-closures")
 
         -- Inline PArray and PData combinators.
    ,    CoreDoSimplify 10
@@ -62,7 +62,7 @@ vectoriserPipeline
                 , sm_inline     = True
                 , sm_case_case  = True } 
 
-   ,    CoreDoPluginPass "Dump" (passDump "parray")
+   ,    CoreDoPluginPass "Dump" (passDump "3-parray")
 
         -- Inline unlifted backend.
    ,    CoreDoSimplify 10
@@ -74,7 +74,7 @@ vectoriserPipeline
                 , sm_inline     = True
                 , sm_case_case  = True } 
 
-   ,    CoreDoPluginPass "Dump" (passDump "backend")
+   ,    CoreDoPluginPass "Dump" (passDump "4-backend")
 
         -- Inline stream functions.
    ,    CoreDoSimplify 10
@@ -86,7 +86,7 @@ vectoriserPipeline
                 , sm_inline     = True
                 , sm_case_case  = True } 
 
-   ,    CoreDoPluginPass "Dump" (passDump "stream")
+   ,    CoreDoPluginPass "Dump" (passDump "5-stream")
 
         -- Inline inner loops and everything else.
    ,    CoreDoSimplify 10
@@ -98,7 +98,7 @@ vectoriserPipeline
                 , sm_inline     = True
                 , sm_case_case  = True } 
 
-   ,    CoreDoPluginPass "Dump" (passDump "inner")
+   ,    CoreDoPluginPass "Dump" (passDump "6-inner")
 
 
         ---------------------