X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=a299fd3673acc2d6f50788098aa6ae8896296b01;hb=7eb34cb0e082185b256b7231ee84cb04e006f51c;hp=93369213e5260f4a3661e1f67769713d00ec4c76;hpb=fba82861c8ba2aa62c47d718abe9b1ccfd502de9;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Normalize.hs b/Normalize.hs
index 9336921..a299fd3 100644
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -21,9 +21,11 @@ import CoreSyn
 import qualified UniqSupply
 import qualified CoreUtils
 import qualified Type
+import qualified TcType
 import qualified Id
 import qualified Var
 import qualified VarSet
+import qualified NameSet
 import qualified CoreFVs
 import qualified CoreUtils
 import qualified MkCore
@@ -140,7 +142,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) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> return True; otherwise -> return False))
 
 --------------------------------
 -- Function inlining
@@ -157,8 +159,8 @@ letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v)
 -- will just not work on those function-typed values at first, but the other
 -- transformations (in particular β-reduction) should make sure that the type
 -- of those values eventually becomes primitive.
-inlinefuntop :: Transform
-inlinefuntop = everywhere ("inlinefun", inlinebind (is_applicable . snd))
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 
 --------------------------------
 -- Scrutinee simplification
@@ -291,61 +293,33 @@ caseremovetop = everywhere ("caseremove", caseremove)
 appsimpl, appsimpltop :: Transform
 -- Don't simplify arguments that are already simple.
 appsimpl expr@(App f (Var 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
--- the new binder in the application.
-appsimpl (App f expr) | (not $ is_applicable expr) && (not $ CoreSyn.isTypeArg expr) = do
-  id <- mkInternalVar "arg" (CoreUtils.exprType expr)
-  change $ Let (Rec [(id, expr)]) (App f (Var id))
+-- Simplify all representable arguments. Do this by introducing a new Let
+-- that binds the argument and passing the new binder in the application.
+appsimpl expr@(App f arg) = do
+  -- Check runtime representability
+  repr <- isRepr arg
+  if repr
+    then do -- Extract representable arguments
+      id <- mkInternalVar "arg" (CoreUtils.exprType arg)
+      change $ Let (Rec [(id, arg)]) (App f (Var id))
+    else -- Leave non-representable arguments unchanged
+      return expr
 -- Leave all other expressions unchanged
 appsimpl expr = return expr
 -- Perform this transform everywhere
 appsimpltop = everywhere ("appsimpl", appsimpl)
 
-
---------------------------------
--- Type argument propagation
---------------------------------
--- Remove all applications to type arguments, by duplicating the function
--- called with the type application in its new definition. We leave
--- dictionaries that might be associated with the type untouched, the funprop
--- transform should propagate these later on.
-typeprop, typeproptop :: Transform
--- Transform any function that is applied to a type argument. Since type
--- arguments are always the first ones to apply and we'll remove all type
--- arguments, we can simply do them one by one. We only propagate type
--- arguments without any free tyvars, since tyvars those wouldn't be in scope
--- in the new function.
-typeprop expr@(App (Var f) arg@(Type ty)) | not $ has_free_tyvars arg = do
-  body_maybe <- Trans.lift $ getGlobalBind f
-  case body_maybe of
-    Just body -> do
-      let newbody = App body (Type ty)
-      -- Create a new function with the same name but a new body
-      newf <- mkFunction f newbody
-      -- Replace the application with this new function
-      change (Var newf)
-    -- If we don't have a body for the function called, leave it unchanged (it
-    -- should be a primitive function then).
-    Nothing -> return expr
--- Leave all other expressions unchanged
-typeprop expr = return expr
--- Perform this transform everywhere
-typeproptop = everywhere ("typeprop", typeprop)
-
-
 --------------------------------
 -- Function-typed argument propagation
 --------------------------------
 -- Remove all applications to function-typed arguments, by duplication the
 -- function called with the function-typed parameter replaced by the free
 -- variables of the argument passed in.
-funprop, funproptop :: Transform
+argprop, argproptop :: Transform
 -- Transform any application of a named function (i.e., skip applications of
 -- lambda's). Also skip applications that have arguments with free type
 -- variables, since we can't inline those.
-funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do
+argprop expr@(App _ _) | is_var fexpr = do
   -- Find the body of the function called
   body_maybe <- Trans.lift $ getGlobalBind f
   case body_maybe of
@@ -384,32 +358,38 @@ funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do
     -- in the new function body, and arg is the argument to apply to the old
     -- function body.
     doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
-    doarg arg | is_fun arg = do
+    doarg arg = do
+      repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders
-      -- Find interesting free variables, each of which should be passed to
-      -- the new function instead of the original function argument.
-      -- 
-      -- Interesting vars are those that are local, but not available from the
-      -- top level scope (functions from this module are defined as local, but
-      -- they're not local to this function, so we can freely move references
-      -- to them into another function).
       let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
-      let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
-      -- Mark the current expression as changed
-      setChanged
-      return (map Var free_vars, free_vars, arg)
-    -- Non-functiontyped arguments can be unchanged. Note that this handles
-    -- both values and types.
-    doarg arg = do
-      -- TODO: preserve original naming?
-      id <- mkBinderFor arg "param"
-      -- Just pass the original argument to the new function, which binds it
-      -- to a new id and just pass that new id to the old function body.
-      return ([arg], [id], mkReferenceTo id) 
+      if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
+        then do
+          -- Propagate all complex arguments that are not representable, but not
+          -- arguments with free type variables (since those would require types
+          -- not known yet, which will always be known eventually).
+          -- Find interesting free variables, each of which should be passed to
+          -- the new function instead of the original function argument.
+          -- 
+          -- Interesting vars are those that are local, but not available from the
+          -- top level scope (functions from this module are defined as local, but
+          -- they're not local to this function, so we can freely move references
+          -- to them into another function).
+          let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
+          -- Mark the current expression as changed
+          setChanged
+          return (map Var free_vars, free_vars, arg)
+        else do
+          -- Representable types will not be propagated, and arguments with free
+          -- type variables will be propagated later.
+          -- TODO: preserve original naming?
+          id <- mkBinderFor arg "param"
+          -- Just pass the original argument to the new function, which binds it
+          -- to a new id and just pass that new id to the old function body.
+          return ([arg], [id], mkReferenceTo id) 
 -- Leave all other expressions unchanged
-funprop expr = return expr
+argprop expr = return expr
 -- Perform this transform everywhere
-funproptop = everywhere ("funprop", funprop)
+argproptop = everywhere ("argprop", argprop)
 
 --------------------------------
 -- Function-typed argument extraction
@@ -470,7 +450,7 @@ funextracttop = everywhere ("funextract", funextract)
 
 
 -- What transforms to run?
-transforms = [typeproptop, funproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
 
 -- Turns the given bind into VHDL
 normalizeModule :: 
@@ -534,6 +514,25 @@ normalizeBind bndr =
                 let used_funcs = VarSet.varSetElems used_funcs_set
                 -- Process each of the used functions recursively
                 mapM normalizeBind used_funcs
+                -- FIXME: Can't we inline these 'implicit' function calls or something?
+                -- TODO: Add an extra let expression to the current finding, so the VHDL
+                --       Will make a signa assignment for this 'implicit' function call
+                --
+                -- Find all the other free variables used that are used. This applies to
+                -- variables that are actually a reference to a Class function. Example:
+                --
+                -- functiontest :: SizedInt D8 -> SizedInt D8
+                -- functiontest = \a -> let r = a + 1 in r
+                --
+                -- The literal(Lit) '1' will be turned into a variable (Var)
+                -- As it will call the 'fromInteger' class function that belongs
+                -- to the Num class. So we need to translate the refenced function
+                -- let used_vars_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isAlgType . snd . Type.splitForAllTys . Id.idType) v) expr'
+                -- let used_vars = VarSet.varSetElems used_vars_set
+                -- -- Filter for dictionary args, they should not be translated
+                -- -- FIXME: check for other non-translatable stuff as well
+                -- let trans_vars = filter (\v -> (not . TcType.isDictTy . Id.idType) v) used_vars
+                -- mapM normalizeBind trans_vars
                 return ()
               -- We don't have a value for this binder. This really shouldn't
               -- happen for local id's...