cλash/CLasH/Normalize.hs

   1 {-# LANGUAGE PackageImports #-}
   2 --
   3 -- Functions to bring a Core expression in normal form. This module provides a
   4 -- top level function "normalize", and defines the actual transformation passes that
   5 -- are performed.
   6 --
   7 module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where
   8
   9 -- Standard modules
  10 import Debug.Trace
  11 import qualified Maybe
  12 import qualified List
  13 import qualified "transformers" Control.Monad.Trans as Trans
  14 import qualified Control.Monad as Monad
  15 import qualified Control.Monad.Trans.Writer as Writer
  16 import qualified Data.Map as Map
  17 import qualified Data.Monoid as Monoid
  18 import Data.Accessor
  19
  20 -- GHC API
  21 import CoreSyn
  22 import qualified UniqSupply
  23 import qualified CoreUtils
  24 import qualified Type
  25 import qualified TcType
  26 import qualified Id
  27 import qualified Var
  28 import qualified VarSet
  29 import qualified NameSet
  30 import qualified CoreFVs
  31 import qualified CoreUtils
  32 import qualified MkCore
  33 import qualified HscTypes
  34 import Outputable ( showSDoc, ppr, nest )
  35
  36 -- Local imports
  37 import CLasH.Normalize.NormalizeTypes
  38 import CLasH.Translator.TranslatorTypes
  39 import CLasH.Normalize.NormalizeTools
  40 import CLasH.VHDL.VHDLTypes
  41 import qualified CLasH.Utils as Utils
  42 import CLasH.Utils.Core.CoreTools
  43 import CLasH.Utils.Core.BinderTools
  44 import CLasH.Utils.Pretty
  45
  46 --------------------------------
  47 -- Start of transformations
  48 --------------------------------
  49
  50 --------------------------------
  51 -- η abstraction
  52 --------------------------------
  53 eta, etatop :: Transform
  54 eta expr | is_fun expr && not (is_lam expr) = do
  55   let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
  56   id <- Trans.lift $ mkInternalVar "param" arg_ty
  57   change (Lam id (App expr (Var id)))
  58 -- Leave all other expressions unchanged
  59 eta e = return e
  60 etatop = notappargs ("eta", eta)
  61
  62 --------------------------------
  63 -- β-reduction
  64 --------------------------------
  65 beta, betatop :: Transform
  66 -- Substitute arg for x in expr
  67 beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
  68 -- Propagate the application into the let
  69 beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
  70 -- Propagate the application into each of the alternatives
  71 beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
  72   where
  73     alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
  74     ty' = CoreUtils.applyTypeToArg ty arg
  75 -- Leave all other expressions unchanged
  76 beta expr = return expr
  77 -- Perform this transform everywhere
  78 betatop = everywhere ("beta", beta)
  79
  80 --------------------------------
  81 -- Cast propagation
  82 --------------------------------
  83 -- Try to move casts as much downward as possible.
  84 castprop, castproptop :: Transform
  85 castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
  86 castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
  87   where
  88     alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
  89 -- Leave all other expressions unchanged
  90 castprop expr = return expr
  91 -- Perform this transform everywhere
  92 castproptop = everywhere ("castprop", castprop)
  93
  94 --------------------------------
  95 -- Cast simplification. Mostly useful for state packing and unpacking, but
  96 -- perhaps for others as well.
  97 --------------------------------
  98 castsimpl, castsimpltop :: Transform
  99 castsimpl expr@(Cast val ty) = do
 100   -- Don't extract values that are already simpl
 101   local_var <- Trans.lift $ is_local_var val
 102   -- Don't extract values that are not representable, to prevent loops with
 103   -- inlinenonrep
 104   repr <- isRepr val
 105   if (not local_var) && repr
 106     then do
 107       -- Generate a binder for the expression
 108       id <- Trans.lift $ mkBinderFor val "castval"
 109       -- Extract the expression
 110       change $ Let (NonRec id val) (Cast (Var id) ty)
 111     else
 112       return expr
 113 -- Leave all other expressions unchanged
 114 castsimpl expr = return expr
 115 -- Perform this transform everywhere
 116 castsimpltop = everywhere ("castsimpl", castsimpl)
 117
 118 --------------------------------
 119 -- let derecursification
 120 --------------------------------
 121 letderec, letderectop :: Transform
 122 letderec expr@(Let (Rec binds) res) = case liftable of
 123   -- Nothing is liftable, just return
 124   [] -> return expr
 125   -- Something can be lifted, generate a new let expression
 126   _ -> change $ MkCore.mkCoreLets newbinds res
 127   where
 128     -- Make a list of all the binders bound in this recursive let
 129     bndrs = map fst binds
 130     -- See which bindings are liftable
 131     (liftable, nonliftable) = List.partition canlift binds
 132     -- Create nonrec bindings for each liftable binding and a single recursive
 133     -- binding for all others
 134     newbinds = (map (uncurry NonRec) liftable) ++ [Rec nonliftable]
 135     -- Any expression that does not use any of the binders in this recursive let
 136     -- can be lifted into a nonrec let. It can't use its own binder either,
 137     -- since that would mean the binding is self-recursive and should be in a
 138     -- single bind recursive let.
 139     canlift (bndr, e) = not $ expr_uses_binders bndrs e
 140 -- Leave all other expressions unchanged
 141 letderec expr = return expr
 142 -- Perform this transform everywhere
 143 letderectop = everywhere ("letderec", letderec)
 144
 145 --------------------------------
 146 -- let simplification
 147 --------------------------------
 148 letsimpl, letsimpltop :: Transform
 149 -- Put the "in ..." value of a let in its own binding, but not when the
 150 -- expression is already a local variable, or not representable (to prevent loops with inlinenonrep).
 151 letsimpl expr@(Let (Rec binds) res) = do
 152   repr <- isRepr res
 153   local_var <- Trans.lift $ is_local_var res
 154   if not local_var && repr
 155     then do
 156       -- If the result is not a local var already (to prevent loops with
 157       -- ourselves), extract it.
 158       id <- Trans.lift $ mkBinderFor res "foo"
 159       let bind = (id, res)
 160       change $ Let (Rec (bind:binds)) (Var id)
 161     else
 162       -- If the result is already a local var, don't extract it.
 163       return expr
 164
 165 -- Leave all other expressions unchanged
 166 letsimpl expr = return expr
 167 -- Perform this transform everywhere
 168 letsimpltop = everywhere ("letsimpl", letsimpl)
 169
 170 --------------------------------
 171 -- let flattening
 172 --------------------------------
 173 letflat, letflattop :: Transform
 174 letflat (Let (Rec binds) expr) = do
 175   -- Turn each binding into a list of bindings (possibly containing just one
 176   -- element, of course)
 177   bindss <- Monad.mapM flatbind binds
 178   -- Concat all the bindings
 179   let binds' = concat bindss
 180   -- Return the new let. We don't use change here, since possibly nothing has
 181   -- changed. If anything has changed, flatbind has already flagged that
 182   -- change.
 183   return $ Let (Rec binds') expr
 184   where
 185     -- Turns a binding of a let into a multiple bindings, or any other binding
 186     -- into a list with just that binding
 187     flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
 188     flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
 189     flatbind (b, expr) = return [(b, expr)]
 190 -- Leave all other expressions unchanged
 191 letflat expr = return expr
 192 -- Perform this transform everywhere
 193 letflattop = everywhere ("letflat", letflat)
 194
 195 --------------------------------
 196 -- Simple let binding removal
 197 --------------------------------
 198 -- Remove a = b bindings from let expressions everywhere
 199 letremovetop :: Transform
 200 letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
 201
 202 --------------------------------
 203 -- Unused let binding removal
 204 --------------------------------
 205 letremoveunused, letremoveunusedtop :: Transform
 206 letremoveunused expr@(Let (Rec binds) res) = do
 207   -- Filter out all unused binds.
 208   let binds' = filter dobind binds
 209   -- Only set the changed flag if binds got removed
 210   changeif (length binds' /= length binds) (Let (Rec binds') res)
 211     where
 212       bound_exprs = map snd binds
 213       -- For each bind check if the bind is used by res or any of the bound
 214       -- expressions
 215       dobind (bndr, _) = any (expr_uses_binders [bndr]) (res:bound_exprs)
 216 -- Leave all other expressions unchanged
 217 letremoveunused expr = return expr
 218 letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
 219
 220 --------------------------------
 221 -- Identical let binding merging
 222 --------------------------------
 223 -- Merge two bindings in a let if they are identical
 224 -- TODO: We would very much like to use GHC's CSE module for this, but that
 225 -- doesn't track if something changed or not, so we can't use it properly.
 226 letmerge, letmergetop :: Transform
 227 letmerge expr@(Let (Rec binds) res) = do
 228   binds' <- domerge binds
 229   return (Let (Rec binds') res)
 230   where
 231     domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)]
 232     domerge [] = return []
 233     domerge (e:es) = do
 234       es' <- mapM (mergebinds e) es
 235       es'' <- domerge es'
 236       return (e:es'')
 237
 238     -- Uses the second bind to simplify the second bind, if applicable.
 239     mergebinds :: (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
 240     mergebinds (b1, e1) (b2, e2)
 241       -- Identical expressions? Replace the second binding with a reference to
 242       -- the first binder.
 243       | CoreUtils.cheapEqExpr e1 e2 = change $ (b2, Var b1)
 244       -- Different expressions? Don't change
 245       | otherwise = return (b2, e2)
 246 -- Leave all other expressions unchanged
 247 letmerge expr = return expr
 248 letmergetop = everywhere ("letmerge", letmerge)
 249
 250 --------------------------------
 251 -- Function inlining
 252 --------------------------------
 253 -- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
 254 -- expressions everywhere. This means that any value that still needs to be
 255 -- applied to something else (polymorphic values need to be applied to a
 256 -- Type) will be inlined, and will eventually be applied to all their
 257 -- arguments.
 258 --
 259 -- This is a tricky function, which is prone to create loops in the
 260 -- transformations. To fix this, we make sure that no transformation will
 261 -- create a new let binding with a function type. These other transformations
 262 -- will just not work on those function-typed values at first, but the other
 263 -- transformations (in particular β-reduction) should make sure that the type
 264 -- of those values eventually becomes primitive.
 265 inlinenonreptop :: Transform
 266 inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 267
 268 --------------------------------
 269 -- Scrutinee simplification
 270 --------------------------------
 271 scrutsimpl,scrutsimpltop :: Transform
 272 -- Don't touch scrutinees that are already simple
 273 scrutsimpl expr@(Case (Var _) _ _ _) = return expr
 274 -- Replace all other cases with a let that binds the scrutinee and a new
 275 -- simple scrutinee, but only when the scrutinee is representable (to prevent
 276 -- loops with inlinenonrep, though I don't think a non-representable scrutinee
 277 -- will be supported anyway...)
 278 scrutsimpl expr@(Case scrut b ty alts) = do
 279   repr <- isRepr scrut
 280   if repr
 281     then do
 282       id <- Trans.lift $ mkBinderFor scrut "scrut"
 283       change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
 284     else
 285       return expr
 286 -- Leave all other expressions unchanged
 287 scrutsimpl expr = return expr
 288 -- Perform this transform everywhere
 289 scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
 290
 291 --------------------------------
 292 -- Case binder wildening
 293 --------------------------------
 294 casesimpl, casesimpltop :: Transform
 295 -- This is already a selector case (or, if x does not appear in bndrs, a very
 296 -- simple case statement that will be removed by caseremove below). Just leave
 297 -- it be.
 298 casesimpl expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
 299 -- Make sure that all case alternatives have only wild binders and simple
 300 -- expressions.
 301 -- This is done by creating a new let binding for each non-wild binder, which
 302 -- is bound to a new simple selector case statement and for each complex
 303 -- expression. We do this only for representable types, to prevent loops with
 304 -- inlinenonrep.
 305 casesimpl expr@(Case scrut b ty alts) = do
 306   (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
 307   let bindings = concat bindingss
 308   -- Replace the case with a let with bindings and a case
 309   let newlet = (Let (Rec bindings) (Case scrut b ty alts'))
 310   -- If there are no non-wild binders, or this case is already a simple
 311   -- selector (i.e., a single alt with exactly one binding), already a simple
 312   -- selector altan no bindings (i.e., no wild binders in the original case),
 313   -- don't change anything, otherwise, replace the case.
 314   if null bindings then return expr else change newlet
 315   where
 316   -- Generate a single wild binder, since they are all the same
 317   wild = MkCore.mkWildBinder
 318   -- Wilden the binders of one alt, producing a list of bindings as a
 319   -- sideeffect.
 320   doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
 321   doalt (con, bndrs, expr) = do
 322     -- Make each binder wild, if possible
 323     bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
 324     let (newbndrs, bindings_maybe) = unzip bndrs_res
 325     -- Extract a complex expression, if possible. For this we check if any of
 326     -- the new list of bndrs are used by expr. We can't use free_vars here,
 327     -- since that looks at the old bndrs.
 328     let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
 329     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
 330     -- Create a new alternative
 331     let newalt = (con, newbndrs, expr')
 332     let bindings = Maybe.catMaybes (exprbinding_maybe : bindings_maybe)
 333     return (bindings, newalt)
 334     where
 335       -- Make wild alternatives for each binder
 336       wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
 337       -- A set of all the binders that are used by the expression
 338       free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
 339       -- Look at the ith binder in the case alternative. Return a new binder
 340       -- for it (either the same one, or a wild one) and optionally a let
 341       -- binding containing a case expression.
 342       dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
 343       dobndr b i = do
 344         repr <- isRepr (Var b)
 345         -- Is b wild (e.g., not a free var of expr. Since b is only in scope
 346         -- in expr, this means that b is unused if expr does not use it.)
 347         let wild = not (VarSet.elemVarSet b free_vars)
 348         -- Create a new binding for any representable binder that is not
 349         -- already wild and is representable (to prevent loops with
 350         -- inlinenonrep).
 351         if (not wild) && repr
 352           then do
 353             -- Create on new binder that will actually capture a value in this
 354             -- case statement, and return it.
 355             let bty = (Id.idType b)
 356             id <- Trans.lift $ mkInternalVar "sel" bty
 357             let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
 358             let caseexpr = Case scrut b bty [(con, binders, Var id)]
 359             return (wildbndrs!!i, Just (b, caseexpr))
 360           else
 361             -- Just leave the original binder in place, and don't generate an
 362             -- extra selector case.
 363             return (b, Nothing)
 364       -- Process the expression of a case alternative. Accepts an expression
 365       -- and whether this expression uses any of the binders in the
 366       -- alternative. Returns an optional new binding and a new expression.
 367       doexpr :: CoreExpr -> Bool -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreExpr)
 368       doexpr expr uses_bndrs = do
 369         local_var <- Trans.lift $ is_local_var expr
 370         repr <- isRepr expr
 371         -- Extract any expressions that do not use any binders from this
 372         -- alternative, is not a local var already and is representable (to
 373         -- prevent loops with inlinenonrep).
 374         if (not uses_bndrs) && (not local_var) && repr
 375           then do
 376             id <- Trans.lift $ mkBinderFor expr "caseval"
 377             -- We don't flag a change here, since casevalsimpl will do that above
 378             -- based on Just we return here.
 379             return $ (Just (id, expr), Var id)
 380           else
 381             -- Don't simplify anything else
 382             return (Nothing, expr)
 383 -- Leave all other expressions unchanged
 384 casesimpl expr = return expr
 385 -- Perform this transform everywhere
 386 casesimpltop = everywhere ("casesimpl", casesimpl)
 387
 388 --------------------------------
 389 -- Case removal
 390 --------------------------------
 391 -- Remove case statements that have only a single alternative and only wild
 392 -- binders.
 393 caseremove, caseremovetop :: Transform
 394 -- Replace a useless case by the value of its single alternative
 395 caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
 396     -- Find if any of the binders are used by expr
 397     where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
 398 -- Leave all other expressions unchanged
 399 caseremove expr = return expr
 400 -- Perform this transform everywhere
 401 caseremovetop = everywhere ("caseremove", caseremove)
 402
 403 --------------------------------
 404 -- Argument extraction
 405 --------------------------------
 406 -- Make sure that all arguments of a representable type are simple variables.
 407 appsimpl, appsimpltop :: Transform
 408 -- Simplify all representable arguments. Do this by introducing a new Let
 409 -- that binds the argument and passing the new binder in the application.
 410 appsimpl expr@(App f arg) = do
 411   -- Check runtime representability
 412   repr <- isRepr arg
 413   local_var <- Trans.lift $ is_local_var arg
 414   if repr && not local_var
 415     then do -- Extract representable arguments
 416       id <- Trans.lift $ mkBinderFor arg "arg"
 417       change $ Let (NonRec id arg) (App f (Var id))
 418     else -- Leave non-representable arguments unchanged
 419       return expr
 420 -- Leave all other expressions unchanged
 421 appsimpl expr = return expr
 422 -- Perform this transform everywhere
 423 appsimpltop = everywhere ("appsimpl", appsimpl)
 424
 425 --------------------------------
 426 -- Function-typed argument propagation
 427 --------------------------------
 428 -- Remove all applications to function-typed arguments, by duplication the
 429 -- function called with the function-typed parameter replaced by the free
 430 -- variables of the argument passed in.
 431 argprop, argproptop :: Transform
 432 -- Transform any application of a named function (i.e., skip applications of
 433 -- lambda's). Also skip applications that have arguments with free type
 434 -- variables, since we can't inline those.
 435 argprop expr@(App _ _) | is_var fexpr = do
 436   -- Find the body of the function called
 437   body_maybe <- Trans.lift $ getGlobalBind f
 438   case body_maybe of
 439     Just body -> do
 440       -- Process each of the arguments in turn
 441       (args', changed) <- Writer.listen $ mapM doarg args
 442       -- See if any of the arguments changed
 443       case Monoid.getAny changed of
 444         True -> do
 445           let (newargs', newparams', oldargs) = unzip3 args'
 446           let newargs = concat newargs'
 447           let newparams = concat newparams'
 448           -- Create a new body that consists of a lambda for all new arguments and
 449           -- the old body applied to some arguments.
 450           let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
 451           -- Create a new function with the same name but a new body
 452           newf <- Trans.lift $ mkFunction f newbody
 453           -- Replace the original application with one of the new function to the
 454           -- new arguments.
 455           change $ MkCore.mkCoreApps (Var newf) newargs
 456         False ->
 457           -- Don't change the expression if none of the arguments changed
 458           return expr
 459
 460     -- If we don't have a body for the function called, leave it unchanged (it
 461     -- should be a primitive function then).
 462     Nothing -> return expr
 463   where
 464     -- Find the function called and the arguments
 465     (fexpr, args) = collectArgs expr
 466     Var f = fexpr
 467
 468     -- Process a single argument and return (args, bndrs, arg), where args are
 469     -- the arguments to replace the given argument in the original
 470     -- application, bndrs are the binders to include in the top-level lambda
 471     -- in the new function body, and arg is the argument to apply to the old
 472     -- function body.
 473     doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
 474     doarg arg = do
 475       repr <- isRepr arg
 476       bndrs <- Trans.lift getGlobalBinders
 477       let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
 478       if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
 479         then do
 480           -- Propagate all complex arguments that are not representable, but not
 481           -- arguments with free type variables (since those would require types
 482           -- not known yet, which will always be known eventually).
 483           -- Find interesting free variables, each of which should be passed to
 484           -- the new function instead of the original function argument.
 485           --
 486           -- Interesting vars are those that are local, but not available from the
 487           -- top level scope (functions from this module are defined as local, but
 488           -- they're not local to this function, so we can freely move references
 489           -- to them into another function).
 490           let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
 491           -- Mark the current expression as changed
 492           setChanged
 493           return (map Var free_vars, free_vars, arg)
 494         else do
 495           -- Representable types will not be propagated, and arguments with free
 496           -- type variables will be propagated later.
 497           -- TODO: preserve original naming?
 498           id <- Trans.lift $ mkBinderFor arg "param"
 499           -- Just pass the original argument to the new function, which binds it
 500           -- to a new id and just pass that new id to the old function body.
 501           return ([arg], [id], mkReferenceTo id)
 502 -- Leave all other expressions unchanged
 503 argprop expr = return expr
 504 -- Perform this transform everywhere
 505 argproptop = everywhere ("argprop", argprop)
 506
 507 --------------------------------
 508 -- Function-typed argument extraction
 509 --------------------------------
 510 -- This transform takes any function-typed argument that cannot be propagated
 511 -- (because the function that is applied to it is a builtin function), and
 512 -- puts it in a brand new top level binder. This allows us to for example
 513 -- apply map to a lambda expression This will not conflict with inlinenonrep,
 514 -- since that only inlines local let bindings, not top level bindings.
 515 funextract, funextracttop :: Transform
 516 funextract expr@(App _ _) | is_var fexpr = do
 517   body_maybe <- Trans.lift $ getGlobalBind f
 518   case body_maybe of
 519     -- We don't have a function body for f, so we can perform this transform.
 520     Nothing -> do
 521       -- Find the new arguments
 522       args' <- mapM doarg args
 523       -- And update the arguments. We use return instead of changed, so the
 524       -- changed flag doesn't get set if none of the args got changed.
 525       return $ MkCore.mkCoreApps fexpr args'
 526     -- We have a function body for f, leave this application to funprop
 527     Just _ -> return expr
 528   where
 529     -- Find the function called and the arguments
 530     (fexpr, args) = collectArgs expr
 531     Var f = fexpr
 532     -- Change any arguments that have a function type, but are not simple yet
 533     -- (ie, a variable or application). This means to create a new function
 534     -- for map (\f -> ...) b, but not for map (foo a) b.
 535     --
 536     -- We could use is_applicable here instead of is_fun, but I think
 537     -- arguments to functions could only have forall typing when existential
 538     -- typing is enabled. Not sure, though.
 539     doarg arg | not (is_simple arg) && is_fun arg = do
 540       -- Create a new top level binding that binds the argument. Its body will
 541       -- be extended with lambda expressions, to take any free variables used
 542       -- by the argument expression.
 543       let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
 544       let body = MkCore.mkCoreLams free_vars arg
 545       id <- Trans.lift $ mkBinderFor body "fun"
 546       Trans.lift $ addGlobalBind id body
 547       -- Replace the argument with a reference to the new function, applied to
 548       -- all vars it uses.
 549       change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
 550     -- Leave all other arguments untouched
 551     doarg arg = return arg
 552
 553 -- Leave all other expressions unchanged
 554 funextract expr = return expr
 555 -- Perform this transform everywhere
 556 funextracttop = everywhere ("funextract", funextract)
 557
 558 --------------------------------
 559 -- End of transformations
 560 --------------------------------
 561
 562
 563
 564
 565 -- What transforms to run?
 566 transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letderectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop]
 567
 568 -- | Returns the normalized version of the given function.
 569 getNormalized ::
 570   CoreBndr -- ^ The function to get
 571   -> TranslatorSession CoreExpr -- The normalized function body
 572
 573 getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
 574   if is_poly (Var bndr)
 575     then
 576       -- This should really only happen at the top level... TODO: Give
 577       -- a different error if this happens down in the recursion.
 578       error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
 579     else do
 580       expr <- getBinding bndr
 581       normalizeExpr (show bndr) expr
 582
 583 -- | Normalize an expression
 584 normalizeExpr ::
 585   String -- ^ What are we normalizing? For debug output only.
 586   -> CoreSyn.CoreExpr -- ^ The expression to normalize
 587   -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
 588
 589 normalizeExpr what expr = do
 590       -- Introduce an empty Let at the top level, so there will always be
 591       -- a let in the expression (none of the transformations will remove
 592       -- the last let).
 593       let expr' = Let (Rec []) expr
 594       -- Normalize this expression
 595       trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
 596       expr'' <- dotransforms transforms expr'
 597       trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr'')) $ return ()
 598       return expr''
 599
 600 -- | Get the value that is bound to the given binder at top level. Fails when
 601 --   there is no such binding.
 602 getBinding ::
 603   CoreBndr -- ^ The binder to get the expression for
 604   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 605
 606 getBinding bndr = Utils.makeCached bndr tsBindings $ do
 607   -- If the binding isn't in the "cache" (bindings map), then we can't create
 608   -- it out of thin air, so return an error.
 609   error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr
 610
 611 -- | Split a normalized expression into the argument binders, top level
 612 --   bindings and the result binder.
 613 splitNormalized ::
 614   CoreExpr -- ^ The normalized expression
 615   -> ([CoreBndr], [Binding], CoreBndr)
 616 splitNormalized expr = (args, binds, res)
 617   where
 618     (args, letexpr) = CoreSyn.collectBinders expr
 619     (binds, resexpr) = flattenLets letexpr
 620     res = case resexpr of
 621       (Var x) -> x
 622       _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
 623
 624 -- | Flattens nested lets into a single list of bindings. The expression
 625 --   passed does not have to be a let expression, if it isn't an empty list of
 626 --   bindings is returned.
 627 flattenLets ::
 628   CoreExpr -- ^ The expression to flatten.
 629   -> ([Binding], CoreExpr) -- ^ The bindings and resulting expression.
 630 flattenLets (Let binds expr) =
 631   (bindings ++ bindings', expr')
 632   where
 633     -- Recursively flatten the contained expression
 634     (bindings', expr') =flattenLets expr
 635     -- Flatten our own bindings to remove the Rec / NonRec constructors
 636     bindings = CoreSyn.flattenBinds [binds]
 637 flattenLets expr = ([], expr)