From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Tue, 8 Jun 2010 13:48:06 +0000 (+0200)
Subject: Merge branch 'master' of git://github.com/christiaanb/clash
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=ef7d876bddac1ebf8ae72dfac9aff33023650f53;hp=c86f74b8af5fb3ca467c7a22fa2d14498b46fb1a;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Merge branch 'master' of git://github.com/christiaanb/clash

* 'master' of git://github.com/christiaanb/clash:
  Do not be overzealous with inlining results of polymorphic functions
  Do not function extract functions that still have free type variables
  Add setup file
  Fix cabal file to reflect temp bug fixes
  Temporarily disable "inlinenonrepresult" transformation, and apply eta-expansion transformation to all expressions
  Rename cλash dir to clash so it behaves well within the ghc build tree
  update cabal file to upload to hackage
  Remove defunct makeVHDLStrings function, messes with haddock
  Update reducer to use new integer types
  Reflect moving TFVec and TFP Integers into clash in sourcefiles related to builtin types
  Update package dependencies
  Move TFVec and TFP integers (Signed, Unsiged and Index) into clash
---

diff --git a/clash/CLasH/Normalize.hs b/clash/CLasH/Normalize.hs
index a70829a..11212f9 100644
--- a/clash/CLasH/Normalize.hs
+++ b/clash/CLasH/Normalize.hs
@@ -410,15 +410,14 @@ funextract c expr = return expr
 -- Make sure the scrutinee of a case expression is a local variable
 -- reference.
 scrutsimpl :: Transform
--- Don't touch scrutinees that are already simple
-scrutsimpl c expr@(Case (Var _) _ _ _) = return expr
--- Replace all other cases with a let that binds the scrutinee and a new
+-- Replace a case expression with a let that binds the scrutinee and a new
 -- simple scrutinee, but only when the scrutinee is representable (to prevent
 -- loops with inlinenonrep, though I don't think a non-representable scrutinee
--- will be supported anyway...) 
+-- will be supported anyway...) and is not a local variable already.
 scrutsimpl c expr@(Case scrut b ty alts) = do
   repr <- isRepr scrut
-  if repr
+  local_var <- Trans.lift $ is_local_var scrut
+  if repr && not local_var
     then do
       id <- Trans.lift $ mkBinderFor scrut "scrut"
       change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
@@ -821,6 +820,10 @@ inlinenonrepresult context expr | not (is_applicable expr) && not (has_free_tyva
 -- Leave all other expressions unchanged
 inlinenonrepresult c expr = return expr
 
+----------------------------------------------------------------
+-- Type-class transformations
+----------------------------------------------------------------
+
 --------------------------------
 -- ClassOp resolution
 --------------------------------
diff --git a/clash/CLasH/Utils/GhcTools.hs b/clash/CLasH/Utils/GhcTools.hs
index f1fe6ba..022a997 100644
--- a/clash/CLasH/Utils/GhcTools.hs
+++ b/clash/CLasH/Utils/GhcTools.hs
@@ -19,6 +19,7 @@ import qualified Name
 import qualified Serialized
 import qualified Var
 import qualified Outputable
+import Outputable(($+$), (<+>), nest, empty, text, vcat)
 import qualified Class
 
 -- Local Imports
@@ -27,6 +28,11 @@ import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
 import CLasH.Utils
 
+-- How far to indent the values after a Foo: header
+align = 20
+-- How far to indent all lines after the first
+indent = 5
+
 listBindings :: FilePath -> [FilePath] -> IO ()
 listBindings libdir filenames = do
   (cores,_,_) <- loadModules libdir filenames Nothing
@@ -37,27 +43,28 @@ listBindings libdir filenames = do
   mapM listClass classes
   return ()
 
+-- Slightly different version of hang, that always uses vcat instead of
+-- sep, so the first line of d2 preserves its nesting.
+hang' d1 n d2 = vcat [d1, nest n d2]
+
 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
-listBinding (b, e) = do
-  putStr "\nBinder: "
-  putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]"
-  putStr "\nType of Binder: \n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
-  putStr "\n\nExpression: \n"
-  putStr $ prettyShow e
-  putStr "\n\n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr e
-  putStr "\n\nType of Expression: \n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
-  putStr "\n\n"
+listBinding (b, e) = putStr $ Outputable.showSDoc $
+  (text "Binder:") <+> (text $ show b ++ "[" ++ show (Var.varUnique b) ++ "]")
+  $+$ nest indent (
+    hang' (text "Type of Binder:") align (Outputable.ppr $ Var.varType b)
+    $+$ hang' (text "Expression:") align (text $ prettyShow e)
+    $+$ nest align (Outputable.ppr e)
+    $+$ hang' (text "Type of Expression:") align (Outputable.ppr $ CoreUtils.exprType e)
+  )
+  $+$ (text "\n") -- Add an empty line
 
 listClass :: Class.Class -> IO ()
-listClass c = do
-  putStr "\nClass: "
-  putStr $ show (Class.className c)
-  putStr "\nSelectors: "
-  putStr $ show (Class.classSelIds c)
-  putStr "\n"
+listClass c = putStr $ Outputable.showSDoc $
+  (text "Class:") <+> (text $ show (Class.className c))
+  $+$ nest indent (
+    hang' (text "Selectors:") align (text $ show (Class.classSelIds c))
+  )
+  $+$ (text "\n") -- Add an empty line
   
 -- | Show the core structure of the given binds in the given file.
 listBind :: FilePath -> [FilePath] -> String -> IO ()