X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=9ee919ab524be8a211b99fe4b22bd7a03478079a;hb=69f55a9c6716f385e22378ce8be378e08b02377d;hp=93e89b615a0b493ef8a64ebdb99d9029f7ec5f15;hpb=9e042c5d285ad14daeee9847116e6338aa609903;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Normalize.hs b/Normalize.hs
index 93e89b6..9ee919a 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -33,6 +33,7 @@ import Outputable ( showSDoc, ppr, nest )
 import NormalizeTypes
 import NormalizeTools
 import CoreTools
+import Pretty
 
 --------------------------------
 -- Start of transformations
@@ -48,7 +49,7 @@ eta expr | is_fun expr && not (is_lam expr) = do
   change (Lam id (App expr (Var id)))
 -- Leave all other expressions unchanged
 eta e = return e
-etatop = notapplied ("eta", eta)
+etatop = notappargs ("eta", eta)
 
 --------------------------------
 -- β-reduction
@@ -68,6 +69,20 @@ beta expr = return expr
 -- Perform this transform everywhere
 betatop = everywhere ("beta", beta)
 
+--------------------------------
+-- Cast propagation
+--------------------------------
+-- Try to move casts as much downward as possible.
+castprop, castproptop :: Transform
+castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
+castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
+  where
+    alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
+-- Leave all other expressions unchanged
+castprop expr = return expr
+-- Perform this transform everywhere
+castproptop = everywhere ("castprop", castprop)
+
 --------------------------------
 -- let recursification
 --------------------------------
@@ -125,7 +140,7 @@ letflattop = everywhere ("letflat", letflat)
 --------------------------------
 -- Remove a = b bindings from let expressions everywhere
 letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
 
 --------------------------------
 -- Function inlining
@@ -273,8 +288,9 @@ caseremovetop = everywhere ("caseremove", caseremove)
 --------------------------------
 -- Make sure that all arguments in an application are simple variables.
 appsimpl, appsimpltop :: Transform
--- Don't simplify arguments that are already simple
-appsimpl expr@(App f (Var _)) = return expr
+-- Don't simplify arguments that are already simple. Do simplify datacons,
+-- however, since we can't portmap literals.
+appsimpl expr@(App f (Var v)) | not $ Id.isDataConWorkId v = return expr
 -- Simplify all non-applicable (to prevent loops with inlinefun) arguments,
 -- except for type arguments (since a let can't bind type vars, only a lambda
 -- can). Do this by introducing a new Let that binds the argument and passing
@@ -406,7 +422,7 @@ funproptop = everywhere ("funprop", funprop)
 
 
 -- What transforms to run?
-transforms = [typeproptop, funproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [typeproptop, funproptop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
 
 -- Turns the given bind into VHDL
 normalizeModule :: 
@@ -429,34 +445,48 @@ normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession
   return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings
 
 normalizeBind :: CoreBndr -> TransformSession ()
-normalizeBind bndr = do
-  normalized_funcs <- getA tsNormalized
-  -- See if this function was normalized already
-  if VarSet.elemVarSet bndr normalized_funcs
-    then
-      -- Yup, don't do it again
-      return ()
-    else do
-      -- Nope, note that it has been and do it.
-      modA tsNormalized (flip VarSet.extendVarSet bndr)
-      expr_maybe <- getGlobalBind bndr
-      case expr_maybe of 
-        Just expr -> do
-          -- Normalize this expression
-          trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
-          expr' <- dotransforms transforms expr
-          trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
-          -- And store the normalized version in the session
-          modA tsBindings (Map.insert bndr expr')
-          -- Find all vars used with a function type. All of these should be global
-          -- binders (i.e., functions used), since any local binders with a function
-          -- type should have been inlined already.
-          let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr'
-          let used_funcs = VarSet.varSetElems used_funcs_set
-          -- Process each of the used functions recursively
-          mapM normalizeBind used_funcs
-          return ()
-        -- We don't have a value for this binder, let's assume this is a builtin
-        -- function. This might need some extra checking and a nice error
-        -- message).
-        Nothing -> return ()
+normalizeBind bndr =
+  -- Don't normalize global variables, these should be either builtin
+  -- functions or data constructors.
+  Monad.when (Var.isLocalIdVar bndr) $ do
+    -- Skip binders that have a polymorphic type, since it's impossible to
+    -- create polymorphic hardware.
+    if is_poly (Var bndr)
+      then
+        -- This should really only happen at the top level... TODO: Give
+        -- a different error if this happens down in the recursion.
+        error $ "Function " ++ show bndr ++ " is polymorphic, can't normalize"
+      else do
+        normalized_funcs <- getA tsNormalized
+        -- See if this function was normalized already
+        if VarSet.elemVarSet bndr normalized_funcs
+          then
+            -- Yup, don't do it again
+            return ()
+          else do
+            -- Nope, note that it has been and do it.
+            modA tsNormalized (flip VarSet.extendVarSet bndr)
+            expr_maybe <- getGlobalBind bndr
+            case expr_maybe of 
+              Just expr -> do
+                -- Introduce an empty Let at the top level, so there will always be
+                -- a let in the expression (none of the transformations will remove
+                -- the last let).
+                let expr' = Let (Rec []) expr
+                -- Normalize this expression
+                trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
+                expr' <- dotransforms transforms expr'
+                trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+                -- And store the normalized version in the session
+                modA tsBindings (Map.insert bndr expr')
+                -- Find all vars used with a function type. All of these should be global
+                -- binders (i.e., functions used), since any local binders with a function
+                -- type should have been inlined already.
+                let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr'
+                let used_funcs = VarSet.varSetElems used_funcs_set
+                -- Process each of the used functions recursively
+                mapM normalizeBind used_funcs
+                return ()
+              -- We don't have a value for this binder. This really shouldn't
+              -- happen for local id's...
+              Nothing -> error $ "No value found for binder " ++ pprString bndr ++ "? This should not happen!"