X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=4a5ceec9c07683fe1c3fb89c8fca9a1be96621c4;hb=b603a1b76fc2bf27e9f194b09206c00d073aabb6;hp=fa14ef65ef7dec1b818e73f86c3da4fdb5842028;hpb=d59ed8de0b03c0eeba23f5a5e08f3c24b87dc3ab;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index fa14ef6..4a5ceec 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -23,8 +23,10 @@ import qualified CoreUtils
 import qualified Type
 import qualified Id
 import qualified Var
+import qualified Name
 import qualified VarSet
 import qualified CoreFVs
+import qualified Class
 import qualified MkCore
 import Outputable ( showSDoc, ppr, nest )
 
@@ -32,6 +34,7 @@ import Outputable ( showSDoc, ppr, nest )
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Normalize.NormalizeTools
+import CLasH.VHDL.Constants (builtinIds)
 import qualified CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.BinderTools
@@ -338,35 +341,124 @@ inlinetoplevel, inlinetopleveltop :: Transform
 -- Any system name is candidate for inlining. Never inline user-defined
 -- functions, to preserve structure.
 inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
-  norm <- isNormalizeable f
-  -- See if this is a top level binding for which we have a body
-  body_maybe <- Trans.lift $ getGlobalBind f
-  if norm && Maybe.isJust body_maybe
-    then do
-      -- Get the normalized version
-      norm <- Trans.lift $ getNormalized f
-      if needsInline norm 
-        then do
-          -- Regenerate all uniques in the to-be-inlined expression
-          norm_uniqued <- Trans.lift $ genUniques norm
-          change norm_uniqued
-        else
-          return expr
-    else
-      -- No body or not normalizeable.
-      return expr
+  body_maybe <- needsInline f
+  case body_maybe of
+    Just body -> do
+        -- Regenerate all uniques in the to-be-inlined expression
+        body_uniqued <- Trans.lift $ genUniques body
+        -- And replace the variable reference with the unique'd body.
+        change body_uniqued
+        -- No need to inline
+    Nothing -> return expr
+
+
 -- Leave all other expressions unchanged
 inlinetoplevel expr = return expr
 inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel)
+  
+-- | Does the given binder need to be inlined? If so, return the body to
+-- be used for inlining.
+needsInline :: CoreBndr -> TransformMonad (Maybe CoreExpr)
+needsInline f = do
+  body_maybe <- Trans.lift $ getGlobalBind f
+  case body_maybe of
+    -- No body available?
+    Nothing -> return Nothing
+    Just body -> case CoreSyn.collectArgs body of
+      -- The body is some (top level) binder applied to 0 or more
+      -- arguments. That should be simple enough to inline.
+      (Var f, args) -> return $ Just body
+      -- Body is more complicated, try normalizing it
+      _ -> do
+        norm_maybe <- Trans.lift $ getNormalized_maybe f
+        case norm_maybe of
+          -- Noth normalizeable
+          Nothing -> return Nothing 
+          Just norm -> case splitNormalized norm of
+            -- The function has just a single binding, so that's simple
+            -- enough to inline.
+            (args, [bind], res) -> return $ Just norm
+            -- More complicated function, don't inline
+            _ -> return Nothing
+            
+--------------------------------
+-- Dictionary inlining
+--------------------------------
+-- Inline all top level dictionaries, so we can use them to resolve
+-- class methods based on the dictionary passed. 
+inlinedict expr@(Var f) | Id.isDictId f = do
+  body_maybe <- Trans.lift $ getGlobalBind f
+  case body_maybe of
+    Nothing -> return expr
+    Just body -> change body
+
+-- Leave all other expressions unchanged
+inlinedict expr = return expr
+inlinedicttop = everywhere ("inlinedict", inlinedict)
+
+--------------------------------
+-- ClassOp resolution
+--------------------------------
+-- Resolves any class operation to the actual operation whenever
+-- possible. Class methods (as well as parent dictionary selectors) are
+-- special "functions" that take a type and a dictionary and evaluate to
+-- the corresponding method. A dictionary is nothing more than a
+-- special dataconstructor applied to the type the dictionary is for,
+-- each of the superclasses and all of the class method definitions for
+-- that particular type. Since dictionaries all always inlined (top
+-- levels dictionaries are inlined by inlinedict, local dictionaries are
+-- inlined by inlinenonrep), we will eventually have something like:
+--
+--   baz
+--     @ CLasH.HardwareTypes.Bit
+--     (D:Baz @ CLasH.HardwareTypes.Bit bitbaz)
+--
+-- Here, baz is the method selector for the baz method, while
+-- D:Baz is the dictionary constructor for the Baz and bitbaz is the baz
+-- method defined in the Baz Bit instance declaration.
+--
+-- To resolve this, we can look at the ClassOp IdInfo from the baz Id,
+-- which contains the Class it is defined for. From the Class, we can
+-- get a list of all selectors (both parent class selectors as well as
+-- method selectors). Since the arguments to D:Baz (after the type
+-- argument) correspond exactly to this list, we then look up baz in
+-- that list and replace the entire expression by the corresponding 
+-- argument to D:Baz.
+--
+-- We don't resolve methods that have a builtin translation (such as
+-- ==), since the actual implementation is not always (easily)
+-- translateable. For example, when deriving ==, GHC generates code
+-- using $con2tag functions to translate a datacon to an int and compare
+-- that with GHC.Prim.==# . Better to avoid that for now.
+classopresolution, classopresolutiontop :: Transform
+classopresolution expr@(App (App (Var sel) ty) dict) | not is_builtin =
+  case Id.isClassOpId_maybe sel of
+    -- Not a class op selector
+    Nothing -> return expr
+    Just cls -> case collectArgs dict of
+      (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet)
+      (Var dictdc, (ty':selectors)) | not (Maybe.isJust (Id.isDataConId_maybe dictdc)) -> return expr -- Dictionary is not a datacon yet (but e.g., a top level binder)
+                                | tyargs_neq ty ty' -> error $ "Applying class selector to dictionary without matching type?\n" ++ pprString expr
+                                | otherwise ->
+        let selector_ids = Class.classSelIds cls in
+        -- Find the selector used in the class' list of selectors
+        case List.elemIndex sel selector_ids of
+          Nothing -> error $ "Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids
+          -- Get the corresponding argument from the dictionary
+          Just n -> change (selectors!!n)
+      (_, _) -> return expr -- Not applying a variable? Don't touch
+  where
+    -- Compare two type arguments, returning True if they are _not_
+    -- equal
+    tyargs_neq (Type ty1) (Type ty2) = not $ Type.coreEqType ty1 ty2
+    tyargs_neq _ _ = True
+    -- Is this a builtin function / method?
+    is_builtin = elem (Name.getOccString sel) builtinIds
 
-needsInline :: CoreExpr -> Bool
-needsInline expr = case splitNormalized expr of
-  -- Inline any function that only has a single definition, it is probably
-  -- simple enough. This might inline some stuff that it shouldn't though it
-  -- will never inline user-defined functions (inlinetoplevel only tries
-  -- system names) and inlining should never break things.
-  (args, [bind], res) -> True
-  _ -> False
+-- Leave all other expressions unchanged
+classopresolution expr = return expr
+-- Perform this transform everywhere
+classopresolutiontop = everywhere ("classopresolution", classopresolution)
 
 --------------------------------
 -- Scrutinee simplification
@@ -430,17 +522,20 @@ casesimpl expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
 -- is bound to a new simple selector case statement and for each complex
 -- expression. We do this only for representable types, to prevent loops with
 -- inlinenonrep.
-casesimpl expr@(Case scrut b ty alts) = do
+casesimpl expr@(Case scrut bndr ty alts) | not bndr_used = do
   (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
   let bindings = concat bindingss
   -- Replace the case with a let with bindings and a case
-  let newlet = mkNonRecLets bindings (Case scrut b ty alts')
+  let newlet = mkNonRecLets bindings (Case scrut bndr ty alts')
   -- If there are no non-wild binders, or this case is already a simple
   -- selector (i.e., a single alt with exactly one binding), already a simple
   -- selector altan no bindings (i.e., no wild binders in the original case),
   -- don't change anything, otherwise, replace the case.
   if null bindings then return expr else change newlet 
   where
+  -- Check if the scrutinee binder is used
+  is_used (_, _, expr) = expr_uses_binders [bndr] expr
+  bndr_used = or $ map is_used alts
   -- Generate a single wild binder, since they are all the same
   wild = MkCore.mkWildBinder
   -- Wilden the binders of one alt, producing a list of bindings as a
@@ -522,7 +617,7 @@ caseremove, caseremovetop :: Transform
 -- Replace a useless case by the value of its single alternative
 caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
     -- Find if any of the binders are used by expr
-    where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+    where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` b:bndrs))) expr
 -- Leave all other expressions unchanged
 caseremove expr = return expr
 -- Perform this transform everywhere
@@ -724,7 +819,7 @@ simplrestop expr = do
 
 
 -- What transforms to run?
-transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
+transforms = [inlinedicttop, inlinetopleveltop, classopresolutiontop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
 
 -- | Returns the normalized version of the given function, or an error
 -- if it is not a known global binder.
@@ -734,20 +829,21 @@ getNormalized ::
 getNormalized bndr = do
   norm <- getNormalized_maybe bndr
   return $ Maybe.fromMaybe
-    (error $ "Normalize.getNormalized: Unknown function requested: " ++ show bndr)
+    (error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr)
     norm
 
 -- | Returns the normalized version of the given function, or Nothing
--- when the binder is not a known global binder.
+-- when the binder is not a known global binder or is not normalizeable.
 getNormalized_maybe ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession (Maybe CoreExpr) -- The normalized function body
 
 getNormalized_maybe bndr = do
     expr_maybe <- getGlobalBind bndr
-    if Maybe.isNothing expr_maybe
+    normalizeable <- isNormalizeable' bndr
+    if not normalizeable || Maybe.isNothing expr_maybe
       then
-        -- Binder not found
+        -- Binder not normalizeable or not found
         return Nothing
       else if is_poly (Var bndr)
         then