{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}

-- | Put the program in A-normal form where only varrefs and literals are
-- allowed in operand position.
module Gibbon.Passes.Flatten
    ( flattenL0, flattenL1, flattenL2, flattenL3 ) where

import Control.Monad
import Text.PrettyPrint.GenericPretty
import Prelude hiding (exp)
import qualified Data.Map as M

import Gibbon.Common
import Gibbon.L1.Syntax
import Gibbon.L2.Syntax
import Gibbon.L3.Syntax
import qualified Gibbon.L0.Syntax as L0


-- | Flatten ensures that function operands are "trivial".
--
--   In the process, it also lifts lets out of case scrutinees, if
--   conditions, and tuple operands.
--
--   Note that it does not require tail expressions to be trivial.
--   For example, it allows AppE and PrimAppE in the body of a
--   let-expression.
flattenL1 :: Prog1 -> PassM Prog1
flattenL1 :: Prog1 -> PassM Prog1
flattenL1 prg :: Prog1
prg@(Prog DDefs (TyOf Exp1)
defs FunDefs Exp1
funs Maybe (Exp1, TyOf Exp1)
main) = do
    Maybe (Exp1, UrTy ())
main' <- case Maybe (Exp1, TyOf Exp1)
main of
               Just (Exp1
e,TyOf Exp1
ty) -> (Exp1, UrTy ()) -> Maybe (Exp1, UrTy ())
forall a. a -> Maybe a
Just ((Exp1, UrTy ()) -> Maybe (Exp1, UrTy ()))
-> (Exp1 -> (Exp1, UrTy ())) -> Exp1 -> Maybe (Exp1, UrTy ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (,TyOf Exp1
UrTy ()
ty) (Exp1 -> Maybe (Exp1, UrTy ()))
-> PassM Exp1 -> PassM (Maybe (Exp1, UrTy ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DDefs (TyOf Exp1) -> Env2 (TyOf Exp1) -> Exp1 -> PassM Exp1
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e
gFlattenExp DDefs (TyOf Exp1)
defs Env2 (TyOf Exp1)
env20 Exp1
e
               Maybe (Exp1, TyOf Exp1)
Nothing -> Maybe (Exp1, UrTy ()) -> PassM (Maybe (Exp1, UrTy ()))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp1, UrTy ())
forall a. Maybe a
Nothing
    FunDefs Exp1
funs' <- FunDefs Exp1 -> PassM (FunDefs Exp1)
flattenFuns FunDefs Exp1
funs
    Prog1 -> PassM Prog1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog1 -> PassM Prog1) -> Prog1 -> PassM Prog1
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp1)
-> FunDefs Exp1 -> Maybe (Exp1, TyOf Exp1) -> Prog1
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp1)
defs FunDefs Exp1
funs' Maybe (Exp1, TyOf Exp1)
Maybe (Exp1, UrTy ())
main'
  where
    flattenFuns :: FunDefs Exp1 -> PassM (FunDefs Exp1)
flattenFuns = (FunDef Exp1 -> PassM (FunDef Exp1))
-> FunDefs Exp1 -> PassM (FunDefs Exp1)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM FunDef Exp1 -> PassM (FunDef Exp1)
flattenFun
    flattenFun :: FunDef Exp1 -> PassM (FunDef Exp1)
flattenFun (FunDef Var
nam [Var]
narg ([UrTy ()]
targ, UrTy ()
ty) Exp1
bod FunMeta
meta) = do
      let env2 :: Env2 (UrTy ())
env2 = TyEnv (UrTy ()) -> TyEnv (ArrowTy (UrTy ())) -> Env2 (UrTy ())
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 ([(Var, UrTy ())] -> TyEnv (UrTy ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, UrTy ())] -> TyEnv (UrTy ()))
-> [(Var, UrTy ())] -> TyEnv (UrTy ())
forall a b. (a -> b) -> a -> b
$ [Var] -> [UrTy ()] -> [(Var, UrTy ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
narg [UrTy ()]
targ) (Env2 (UrTy ()) -> TyEnv (ArrowTy (UrTy ()))
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf Exp1)
Env2 (UrTy ())
env20)
      Exp1
bod' <- DDefs (TyOf Exp1) -> Env2 (TyOf Exp1) -> Exp1 -> PassM Exp1
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e
gFlattenExp DDefs (TyOf Exp1)
defs Env2 (TyOf Exp1)
Env2 (UrTy ())
env2 Exp1
bod
      FunDef Exp1 -> PassM (FunDef Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef Exp1 -> PassM (FunDef Exp1))
-> FunDef Exp1 -> PassM (FunDef Exp1)
forall a b. (a -> b) -> a -> b
$ Var
-> [Var] -> ArrowTy (TyOf Exp1) -> Exp1 -> FunMeta -> FunDef Exp1
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
nam [Var]
narg ([UrTy ()]
targ, UrTy ()
ty) Exp1
bod' FunMeta
meta

    env20 :: Env2 (TyOf Exp1)
env20 = Prog1 -> Env2 (TyOf Exp1)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog1
prg


flattenL2 :: Flattenable (E2Ext Var (UrTy LocVar)) => Prog2 -> PassM Prog2
flattenL2 :: Flattenable (E2Ext Var (UrTy Var)) => Prog2 -> PassM Prog2
flattenL2 prg :: Prog2
prg@(Prog DDefs (TyOf Exp2)
defs FunDefs Exp2
funs Maybe (Exp2, TyOf Exp2)
main) = do
    Maybe (Exp2, UrTy Var)
main' <-
      case Maybe (Exp2, TyOf Exp2)
main of
        Maybe (Exp2, TyOf Exp2)
Nothing -> Maybe (Exp2, UrTy Var) -> PassM (Maybe (Exp2, UrTy Var))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp2, UrTy Var)
forall a. Maybe a
Nothing
        Just (Exp2
ex,TyOf Exp2
ty) -> (Exp2 -> Maybe (Exp2, UrTy Var))
-> PassM Exp2 -> PassM (Maybe (Exp2, UrTy Var))
forall a b. (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp2, UrTy Var) -> Maybe (Exp2, UrTy Var)
forall a. a -> Maybe a
Just ((Exp2, UrTy Var) -> Maybe (Exp2, UrTy Var))
-> (Exp2 -> (Exp2, UrTy Var)) -> Exp2 -> Maybe (Exp2, UrTy Var)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,TyOf Exp2
UrTy Var
ty)) (DDefs (TyOf Exp2) -> Env2 (TyOf Exp2) -> Exp2 -> PassM Exp2
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e
gFlattenExp DDefs (TyOf Exp2)
defs Env2 (TyOf Exp2)
env20 Exp2
ex)
    FunDefs Exp2
funs' <- FunDefs Exp2 -> PassM (FunDefs Exp2)
flattenFuns FunDefs Exp2
funs
    Prog2 -> PassM Prog2
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog2 -> PassM Prog2) -> Prog2 -> PassM Prog2
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp2)
-> FunDefs Exp2 -> Maybe (Exp2, TyOf Exp2) -> Prog2
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp2)
defs FunDefs Exp2
funs' Maybe (Exp2, TyOf Exp2)
Maybe (Exp2, UrTy Var)
main'
  where
    flattenFuns :: FunDefs Exp2 -> PassM (FunDefs Exp2)
flattenFuns = (FunDef Exp2 -> PassM (FunDef Exp2))
-> FunDefs Exp2 -> PassM (FunDefs Exp2)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM FunDef Exp2 -> PassM (FunDef Exp2)
flattenFun
    flattenFun :: FunDef Exp2 -> PassM (FunDef Exp2)
flattenFun (FunDef Var
nam [Var]
narg ArrowTy (TyOf Exp2)
ty Exp2
bod FunMeta
meta) = do
      let env2 :: Env2 (UrTy Var)
env2 = TyEnv (UrTy Var) -> TyEnv (ArrowTy (UrTy Var)) -> Env2 (UrTy Var)
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 ([(Var, UrTy Var)] -> TyEnv (UrTy Var)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, UrTy Var)] -> TyEnv (UrTy Var))
-> [(Var, UrTy Var)] -> TyEnv (UrTy Var)
forall a b. (a -> b) -> a -> b
$ [Var] -> [UrTy Var] -> [(Var, UrTy Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
narg (ArrowTy2 (UrTy Var) -> [UrTy Var]
forall ty2. ArrowTy2 ty2 -> [ty2]
arrIns ArrowTy (TyOf Exp2)
ArrowTy2 (UrTy Var)
ty)) (Env2 (UrTy Var) -> TyEnv (ArrowTy (UrTy Var))
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf Exp2)
Env2 (UrTy Var)
env20)
      Exp2
bod' <- DDefs (TyOf Exp2) -> Env2 (TyOf Exp2) -> Exp2 -> PassM Exp2
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e
gFlattenExp DDefs (TyOf Exp2)
defs Env2 (TyOf Exp2)
Env2 (UrTy Var)
env2 Exp2
bod
      FunDef Exp2 -> PassM (FunDef Exp2)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef Exp2 -> PassM (FunDef Exp2))
-> FunDef Exp2 -> PassM (FunDef Exp2)
forall a b. (a -> b) -> a -> b
$ Var
-> [Var] -> ArrowTy (TyOf Exp2) -> Exp2 -> FunMeta -> FunDef Exp2
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
nam [Var]
narg ArrowTy (TyOf Exp2)
ty Exp2
bod' FunMeta
meta

    env20 :: Env2 (TyOf Exp2)
env20 = Prog2 -> Env2 (TyOf Exp2)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog2
prg


flattenL3 :: Prog3 -> PassM Prog3
flattenL3 :: Prog3 -> PassM Prog3
flattenL3 prg :: Prog3
prg@(Prog DDefs (TyOf Exp3)
defs FunDefs Exp3
funs Maybe (Exp3, TyOf Exp3)
main) = do
    Maybe (Exp3, UrTy ())
main' <-
      case Maybe (Exp3, TyOf Exp3)
main of
        Maybe (Exp3, TyOf Exp3)
Nothing -> Maybe (Exp3, UrTy ()) -> PassM (Maybe (Exp3, UrTy ()))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp3, UrTy ())
forall a. Maybe a
Nothing
        Just (Exp3
ex,TyOf Exp3
ty) -> (Exp3 -> Maybe (Exp3, UrTy ()))
-> PassM Exp3 -> PassM (Maybe (Exp3, UrTy ()))
forall a b. (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp3, UrTy ()) -> Maybe (Exp3, UrTy ())
forall a. a -> Maybe a
Just ((Exp3, UrTy ()) -> Maybe (Exp3, UrTy ()))
-> (Exp3 -> (Exp3, UrTy ())) -> Exp3 -> Maybe (Exp3, UrTy ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,TyOf Exp3
UrTy ()
ty)) (DDefs (TyOf Exp3) -> Env2 (TyOf Exp3) -> Exp3 -> PassM Exp3
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e
gFlattenExp DDefs (TyOf Exp3)
defs Env2 (TyOf Exp3)
env20 Exp3
ex)
    FunDefs Exp3
funs' <- FunDefs Exp3 -> PassM (FunDefs Exp3)
flattenFuns FunDefs Exp3
funs
    Prog3 -> PassM Prog3
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog3 -> PassM Prog3) -> Prog3 -> PassM Prog3
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp3)
-> FunDefs Exp3 -> Maybe (Exp3, TyOf Exp3) -> Prog3
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp3)
defs FunDefs Exp3
funs' Maybe (Exp3, TyOf Exp3)
Maybe (Exp3, UrTy ())
main'
  where
    flattenFuns :: FunDefs Exp3 -> PassM (FunDefs Exp3)
flattenFuns = (FunDef Exp3 -> PassM (FunDef Exp3))
-> FunDefs Exp3 -> PassM (FunDefs Exp3)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM FunDef Exp3 -> PassM (FunDef Exp3)
flattenFun
    flattenFun :: FunDef Exp3 -> PassM (FunDef Exp3)
flattenFun (FunDef Var
nam [Var]
narg ArrowTy (TyOf Exp3)
ty Exp3
bod FunMeta
meta) = do
      let env2 :: Env2 (UrTy ())
env2 = TyEnv (UrTy ()) -> TyEnv (ArrowTy (UrTy ())) -> Env2 (UrTy ())
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 ([(Var, UrTy ())] -> TyEnv (UrTy ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, UrTy ())] -> TyEnv (UrTy ()))
-> [(Var, UrTy ())] -> TyEnv (UrTy ())
forall a b. (a -> b) -> a -> b
$ [Var] -> [UrTy ()] -> [(Var, UrTy ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
narg (([UrTy ()], UrTy ()) -> [UrTy ()]
forall a b. (a, b) -> a
fst ([UrTy ()], UrTy ())
ArrowTy (TyOf Exp3)
ty)) (Env2 (UrTy ()) -> TyEnv (ArrowTy (UrTy ()))
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf Exp3)
Env2 (UrTy ())
env20)
      Exp3
bod' <- DDefs (TyOf Exp3) -> Env2 (TyOf Exp3) -> Exp3 -> PassM Exp3
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM e
gFlattenExp DDefs (TyOf Exp3)
defs Env2 (TyOf Exp3)
Env2 (UrTy ())
env2 Exp3
bod
      FunDef Exp3 -> PassM (FunDef Exp3)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef Exp3 -> PassM (FunDef Exp3))
-> FunDef Exp3 -> PassM (FunDef Exp3)
forall a b. (a -> b) -> a -> b
$ Var
-> [Var] -> ArrowTy (TyOf Exp3) -> Exp3 -> FunMeta -> FunDef Exp3
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
nam [Var]
narg ArrowTy (TyOf Exp3)
ty Exp3
bod' FunMeta
meta

    env20 :: Env2 (TyOf Exp3)
env20 = Prog3 -> Env2 (TyOf Exp3)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog3
prg


-- NOTE: / FIXME
-- If we would just include arrow types in the grammar from the start,
-- the the typeenv could contain function types too.  Data constructors could
-- go in there too.  Everything would be simpler. We would simply have to
-- use other means to remember that L1 programs are first order.

-- type Binds e = (Var,[LocOf e],TyOf e, e)


-- Constraints we need to write a generic Flatten.
type FlattenDeps e l d = (Show l, Out l, Show d, Out d,
                          Expression (e l d),
                          TyOf (e l d) ~ TyOf (PreExp e l d),
                          Typeable (PreExp e l d),
                          Flattenable (e l d))

instance FlattenDeps e l d => Flattenable (PreExp e l d) where

  gFlattenExp :: DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM (PreExp e l d)
gFlattenExp DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env PreExp e l d
ex = do ([(Var, [l], d, PreExp e l d)]
b,PreExp e l d
e') <- DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM ([Binds e], e)
gFlattenGatherBinds DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env PreExp e l d
ex
                               PreExp e l d -> PassM (PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (PreExp e l d -> PassM (PreExp e l d))
-> PreExp e l d -> PassM (PreExp e l d)
forall a b. (a -> b) -> a -> b
$ [(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [l], d, PreExp e l d)]
b PreExp e l d
e'
  gFlattenGatherBinds :: DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
gFlattenGatherBinds = DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
forall (e :: * -> * -> *) l d.
FlattenDeps e l d =>
DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
exp


exp :: forall e l d. FlattenDeps e l d
    => DDefs (TyOf (PreExp e l d))
    -> Env2 (TyOf (PreExp e l d))
    -> (PreExp e l d)
    -> PassM ([Binds (PreExp e l d)], (PreExp e l d))
exp :: forall (e :: * -> * -> *) l d.
FlattenDeps e l d =>
DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
exp DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env2 PreExp e l d
e0 =
  let triv :: String -> (PreExp e l d) -> PassM ([Binds (PreExp e l d)], (PreExp e l d))
      triv :: [Char]
-> PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
triv [Char]
m PreExp e l d
e = -- Force something to be trivial
        if PreExp e l d -> Bool
forall e. Expression e => e -> Bool
isTrivial PreExp e l d
e
        then ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],PreExp e l d
e)
        else do Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ [Char] -> Var
toVar ([Char] -> Var) -> [Char] -> Var
forall a b. (a -> b) -> a -> b
$ [Char]
"flt" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m
                let ty :: TyOf (PreExp e l d)
ty = DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> TyOf (PreExp e l d)
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env2 PreExp e l d
e
                ([(Var, [l], d, PreExp e l d)]
bnds,PreExp e l d
e') <- DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
forall (e :: * -> * -> *) l d.
FlattenDeps e l d =>
DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
exp DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env2 PreExp e l d
e
                ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(Var, [l], d, PreExp e l d)]
bnds[(Var, [l], d, PreExp e l d)]
-> [(Var, [l], d, PreExp e l d)] -> [(Var, [l], d, PreExp e l d)]
forall a. [a] -> [a] -> [a]
++[(Var
tmp,[],d
TyOf (PreExp e l d)
ty,PreExp e l d
e')]
                       , Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp)

      go :: (PreExp e l d) -> PassM ([Binds (PreExp e l d)], (PreExp e l d))
      go :: PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go = DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
forall (e :: * -> * -> *) l d.
FlattenDeps e l d =>
DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
exp DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env2

      gols :: ([PreExp e l d] -> PreExp e l d)
-> [PreExp e l d]
-> [Char]
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
gols [PreExp e l d] -> PreExp e l d
f [PreExp e l d]
ls [Char]
m = do ([[(Var, [l], d, PreExp e l d)]]
bndss,[PreExp e l d]
ls') <- [([(Var, [l], d, PreExp e l d)], PreExp e l d)]
-> ([[(Var, [l], d, PreExp e l d)]], [PreExp e l d])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [l], d, PreExp e l d)], PreExp e l d)]
 -> ([[(Var, [l], d, PreExp e l d)]], [PreExp e l d]))
-> PassM [([(Var, [l], d, PreExp e l d)], PreExp e l d)]
-> PassM ([[(Var, [l], d, PreExp e l d)]], [PreExp e l d])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PreExp e l d
 -> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d))
-> [PreExp e l d]
-> PassM [([(Var, [l], d, PreExp e l d)], PreExp e l d)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char]
-> PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
triv [Char]
m) [PreExp e l d]
ls
                       ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Var, [l], d, PreExp e l d)]] -> [(Var, [l], d, PreExp e l d)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [l], d, PreExp e l d)]]
bndss, [PreExp e l d] -> PreExp e l d
f [PreExp e l d]
ls')

  in
  case PreExp e l d
e0 of
    Ext e l d
ext   -> do ([(Var, [LocOf (e l d)], d, e l d)]
_bnds,e l d
e) <- DDefs (TyOf (e l d))
-> Env2 (TyOf (e l d)) -> e l d -> PassM ([Binds (e l d)], e l d)
forall e.
Flattenable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> PassM ([Binds e], e)
gFlattenGatherBinds DDefs (TyOf (e l d))
DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (e l d))
Env2 (TyOf (PreExp e l d))
env2 e l d
ext
                    ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return  ([], e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext e l d
e)

    LitE Int
_    -> ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],PreExp e l d
e0)
    CharE Char
_   -> ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],PreExp e l d
e0)
    FloatE{}  -> ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],PreExp e l d
e0)
    VarE    Var
_ -> ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],PreExp e l d
e0)
    LitSymE Var
_ -> ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],PreExp e l d
e0)

    AppE Var
f [l]
lvs [PreExp e l d]
ls     -> ([PreExp e l d] -> PreExp e l d)
-> [PreExp e l d]
-> [Char]
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
gols (Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [l]
lvs)  [PreExp e l d]
ls [Char]
"AppE"
    PrimAppE Prim d
p [PreExp e l d]
ls     -> ([PreExp e l d] -> PreExp e l d)
-> [PreExp e l d]
-> [Char]
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
gols (Prim d -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim d
p)  [PreExp e l d]
ls [Char]
"Prm"
    MkProdE [PreExp e l d]
ls        -> ([PreExp e l d] -> PreExp e l d)
-> [PreExp e l d]
-> [Char]
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
gols  [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE      [PreExp e l d]
ls [Char]
"Prd"
    DataConE l
loc [Char]
k [PreExp e l d]
ls -> ([PreExp e l d] -> PreExp e l d)
-> [PreExp e l d]
-> [Char]
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
gols (l -> [Char] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE l
loc [Char]
k) [PreExp e l d]
ls [Char]
"Pkd"

    LetE (Var
v1,[l]
lv1,d
t1, ((LetE (Var
v2,[l]
lv2,d
t2,PreExp e l d
rhs2) PreExp e l d
rhs1))) PreExp e l d
bod -> do
      ([(Var, [l], d, PreExp e l d)]
bnd, PreExp e l d
rhs) <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go ((Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v2,[l]
lv2,d
t2,PreExp e l d
rhs2) (PreExp e l d -> PreExp e l d) -> PreExp e l d -> PreExp e l d
forall a b. (a -> b) -> a -> b
$
                        (Var, [l], d, PreExp e l d) -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v1,[l]
lv1,d
t1,PreExp e l d
rhs1) PreExp e l d
bod)
      ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [l], d, PreExp e l d)]
bnd, PreExp e l d
rhs)

    LetE (Var
v,[l]
locs,d
t,PreExp e l d
rhs) PreExp e l d
bod -> do ([(Var, [l], d, PreExp e l d)]
bnd1,PreExp e l d
rhs') <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go PreExp e l d
rhs
                                  ([(Var, [l], d, PreExp e l d)]
bnd2,PreExp e l d
bod') <- DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
forall (e :: * -> * -> *) l d.
FlattenDeps e l d =>
DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
exp DDefs (TyOf (PreExp e l d))
ddfs (Var -> d -> Env2 d -> Env2 d
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v d
t Env2 d
Env2 (TyOf (PreExp e l d))
env2) PreExp e l d
bod
                                  ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [l], d, PreExp e l d)]
bnd1[(Var, [l], d, PreExp e l d)]
-> [(Var, [l], d, PreExp e l d)] -> [(Var, [l], d, PreExp e l d)]
forall a. [a] -> [a] -> [a]
++[(Var
v,[l]
locs,d
t,PreExp e l d
rhs')][(Var, [l], d, PreExp e l d)]
-> [(Var, [l], d, PreExp e l d)] -> [(Var, [l], d, PreExp e l d)]
forall a. [a] -> [a] -> [a]
++[(Var, [l], d, PreExp e l d)]
bnd2, PreExp e l d
bod')
    IfE PreExp e l d
a PreExp e l d
b PreExp e l d
c -> do ([(Var, [l], d, PreExp e l d)]
b1,PreExp e l d
a') <- [Char]
-> PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
triv [Char]
"If" PreExp e l d
a
                    ([(Var, [l], d, PreExp e l d)]
b2,PreExp e l d
b') <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go PreExp e l d
b
                    ([(Var, [l], d, PreExp e l d)]
b3,PreExp e l d
c') <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go PreExp e l d
c
                    ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [l], d, PreExp e l d)]
b1, PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE PreExp e l d
a' ([(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [l], d, PreExp e l d)]
b2 PreExp e l d
b') ([(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [l], d, PreExp e l d)]
b3 PreExp e l d
c'))
    -- This can happen anywhere, but doing it here prevents
    -- unneccessary bloat where we can ill afford it:
    ProjE Int
ix (MkProdE [PreExp e l d]
ls) -> do
      -- dbgTrace 5 (" [flatten] Reducing project-of-tuple, index "++show ix++
      --             " expr:  "++take 80 (show ls)++"...")
      ([(Var, [l], d, PreExp e l d)]
bnd,PreExp e l d
rhs) <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go ([PreExp e l d]
ls [PreExp e l d] -> Int -> PreExp e l d
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix)
      ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [l], d, PreExp e l d)]
bnd, PreExp e l d
rhs)

    ProjE Int
ix PreExp e l d
e -> do ([(Var, [l], d, PreExp e l d)]
b,PreExp e l d
e') <- [Char]
-> PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
triv [Char]
"Prj" PreExp e l d
e
                     ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [l], d, PreExp e l d)]
b, Int -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
ix PreExp e l d
e')

    CaseE PreExp e l d
e [([Char], [(Var, l)], PreExp e l d)]
ls -> do ([(Var, [l], d, PreExp e l d)]
b,PreExp e l d
e') <- [Char]
-> PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
triv [Char]
"Cse" PreExp e l d
e
                     [([Char], [(Var, l)], PreExp e l d)]
ls' <- [([Char], [(Var, l)], PreExp e l d)]
-> (([Char], [(Var, l)], PreExp e l d)
    -> PassM ([Char], [(Var, l)], PreExp e l d))
-> PassM [([Char], [(Var, l)], PreExp e l d)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [(Var, l)], PreExp e l d)]
ls ((([Char], [(Var, l)], PreExp e l d)
  -> PassM ([Char], [(Var, l)], PreExp e l d))
 -> PassM [([Char], [(Var, l)], PreExp e l d)])
-> (([Char], [(Var, l)], PreExp e l d)
    -> PassM ([Char], [(Var, l)], PreExp e l d))
-> PassM [([Char], [(Var, l)], PreExp e l d)]
forall a b. (a -> b) -> a -> b
$ \ ([Char]
k,[(Var, l)]
vrs,PreExp e l d
rhs) -> do
                              let tys :: [d]
tys = DDefs d -> [Char] -> [d]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs d
DDefs (TyOf (PreExp e l d))
ddfs [Char]
k
                                  vrs' :: [Var]
vrs' = ((Var, l) -> Var) -> [(Var, l)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, l) -> Var
forall a b. (a, b) -> a
fst [(Var, l)]
vrs
                                  env2' :: Env2 d
env2' = Map Var d -> Env2 d -> Env2 d
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, d)] -> Map Var d
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [d] -> [(Var, d)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vrs' [d]
tys)) Env2 d
Env2 (TyOf (PreExp e l d))
env2
                              ([(Var, [l], d, PreExp e l d)]
b2,PreExp e l d
rhs') <- DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
forall (e :: * -> * -> *) l d.
FlattenDeps e l d =>
DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> PassM ([Binds (PreExp e l d)], PreExp e l d)
exp DDefs (TyOf (PreExp e l d))
ddfs Env2 d
Env2 (TyOf (PreExp e l d))
env2' PreExp e l d
rhs
                              ([Char], [(Var, l)], PreExp e l d)
-> PassM ([Char], [(Var, l)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
k,[(Var, l)]
vrs, [(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [l], d, PreExp e l d)]
b2 PreExp e l d
rhs')
                     ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [l], d, PreExp e l d)]
b, PreExp e l d
-> [([Char], [(Var, l)], PreExp e l d)] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp e l d
e' [([Char], [(Var, l)], PreExp e l d)]
ls')
    -- TimeIt is treated like a conditional.  Don't lift out of it:
    TimeIt PreExp e l d
e d
_t Bool
b -> do
      ([(Var, [l], d, PreExp e l d)]
bnd,PreExp e l d
e') <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go PreExp e l d
e
      ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], PreExp e l d -> d -> Bool -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt ([(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [l], d, PreExp e l d)]
bnd PreExp e l d
e') (DDefs (TyOf (PreExp e l d))
-> Env2 (TyOf (PreExp e l d))
-> PreExp e l d
-> TyOf (PreExp e l d)
forall e.
Typeable e =>
DDefs (TyOf e) -> Env2 (TyOf e) -> e -> TyOf e
gRecoverType DDefs (TyOf (PreExp e l d))
ddfs Env2 (TyOf (PreExp e l d))
env2 PreExp e l d
e) Bool
b)

    SpawnE Var
f [l]
lvs [PreExp e l d]
ls -> ([PreExp e l d] -> PreExp e l d)
-> [PreExp e l d]
-> [Char]
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
gols (Var -> [l] -> [PreExp e l d] -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [l]
lvs)  [PreExp e l d]
ls [Char]
"SpawnE"
    PreExp e l d
SyncE -> ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], PreExp e l d
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE)

    WithArenaE Var
v PreExp e l d
e -> do
      ([(Var, [l], d, PreExp e l d)]
bnd, PreExp e l d
e') <- PreExp e l d -> PassM ([Binds (PreExp e l d)], PreExp e l d)
go PreExp e l d
e
      ([(Var, [l], d, PreExp e l d)], PreExp e l d)
-> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Var -> PreExp e l d -> PreExp e l d
forall (ext :: * -> * -> *) loc dec.
Var -> PreExp ext loc dec -> PreExp ext loc dec
WithArenaE Var
v ([(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [l], d, PreExp e l d)]
bnd PreExp e l d
e'))

    MapE (Var, d, PreExp e l d)
_ PreExp e l d
_      -> [Char] -> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. HasCallStack => [Char] -> a
error [Char]
"FINISHLISTS"
    FoldE (Var, d, PreExp e l d)
_ (Var, d, PreExp e l d)
_ PreExp e l d
_   -> [Char] -> PassM ([(Var, [l], d, PreExp e l d)], PreExp e l d)
forall a. HasCallStack => [Char] -> a
error [Char]
"FINISHLISTS"

-----------------------------------------------------------------------------------------

-- We have duplicate code here because exp depends on Typeable, and it cannot
-- be derived for L0. See the comment above L0.Syntax.recoverType for details.

flattenL0 :: L0.Prog0 -> PassM L0.Prog0
flattenL0 :: Prog0 -> PassM Prog0
flattenL0 prg :: Prog0
prg@(Prog DDefs (TyOf Exp0)
defs FunDefs Exp0
funs Maybe (Exp0, TyOf Exp0)
main) = do
    Maybe (Exp0, Ty0)
main' <-
      case Maybe (Exp0, TyOf Exp0)
main of
        Maybe (Exp0, TyOf Exp0)
Nothing -> Maybe (Exp0, Ty0) -> PassM (Maybe (Exp0, Ty0))
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Exp0, Ty0)
forall a. Maybe a
Nothing
        Just (Exp0
ex,TyOf Exp0
ty) -> (Exp0 -> Maybe (Exp0, Ty0))
-> PassM Exp0 -> PassM (Maybe (Exp0, Ty0))
forall a b. (a -> b) -> PassM a -> PassM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Exp0, Ty0) -> Maybe (Exp0, Ty0)
forall a. a -> Maybe a
Just ((Exp0, Ty0) -> Maybe (Exp0, Ty0))
-> (Exp0 -> (Exp0, Ty0)) -> Exp0 -> Maybe (Exp0, Ty0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,TyOf Exp0
Ty0
ty)) (([(Var, [Ty0], Ty0, Exp0)], Exp0) -> Exp0
forall a b. (a, b) -> b
snd (([(Var, [Ty0], Ty0, Exp0)], Exp0) -> Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0) -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs (TyOf Exp0)
DDefs0
defs Env2 (TyOf Exp0)
Env2 Ty0
env20 Exp0
ex)
    FunDefs Exp0
funs' <- FunDefs Exp0 -> PassM (FunDefs Exp0)
flattenFuns FunDefs Exp0
funs
    Prog0 -> PassM Prog0
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Prog0 -> PassM Prog0) -> Prog0 -> PassM Prog0
forall a b. (a -> b) -> a -> b
$ DDefs (TyOf Exp0)
-> FunDefs Exp0 -> Maybe (Exp0, TyOf Exp0) -> Prog0
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
Prog DDefs (TyOf Exp0)
defs FunDefs Exp0
funs' Maybe (Exp0, TyOf Exp0)
Maybe (Exp0, Ty0)
main'
  where
    flattenFuns :: FunDefs Exp0 -> PassM (FunDefs Exp0)
flattenFuns = (FunDef Exp0 -> PassM (FunDef Exp0))
-> FunDefs Exp0 -> PassM (FunDefs Exp0)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Var a -> m (Map Var b)
mapM FunDef Exp0 -> PassM (FunDef Exp0)
flattenFun
    flattenFun :: FunDef Exp0 -> PassM (FunDef Exp0)
flattenFun (FunDef Var
nam [Var]
nargs ArrowTy (TyOf Exp0)
ty Exp0
bod FunMeta
meta) = do
      let env2 :: Env2 Ty0
env2 = TyEnv Ty0 -> TyEnv (ArrowTy Ty0) -> Env2 Ty0
forall a. TyEnv a -> TyEnv (ArrowTy a) -> Env2 a
Env2 ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Var, Ty0)] -> TyEnv Ty0) -> [(Var, Ty0)] -> TyEnv Ty0
forall a b. (a -> b) -> a -> b
$ [Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
nargs (TyScheme -> [Ty0]
L0.arrIns ArrowTy (TyOf Exp0)
TyScheme
ty)) (Env2 Ty0 -> TyEnv (ArrowTy Ty0)
forall a. Env2 a -> TyEnv (ArrowTy a)
fEnv Env2 (TyOf Exp0)
Env2 Ty0
env20)
      Exp0
bod' <- ([(Var, [Ty0], Ty0, Exp0)], Exp0) -> Exp0
forall a b. (a, b) -> b
snd (([(Var, [Ty0], Ty0, Exp0)], Exp0) -> Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0) -> PassM Exp0
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs (TyOf Exp0)
DDefs0
defs Env2 Ty0
env2 Exp0
bod
      FunDef Exp0 -> PassM (FunDef Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef Exp0 -> PassM (FunDef Exp0))
-> FunDef Exp0 -> PassM (FunDef Exp0)
forall a b. (a -> b) -> a -> b
$ Var
-> [Var] -> ArrowTy (TyOf Exp0) -> Exp0 -> FunMeta -> FunDef Exp0
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
nam [Var]
nargs ArrowTy (TyOf Exp0)
ty Exp0
bod' FunMeta
meta
    env20 :: Env2 (TyOf Exp0)
env20 = Prog0 -> Env2 (TyOf Exp0)
forall a. Prog a -> Env2 (TyOf a)
progToEnv Prog0
prg

flattenExp0 :: L0.DDefs0 -> Env2 L0.Ty0 -> L0.Exp0
            -> PassM ([Binds (L0.Exp0)], L0.Exp0)
flattenExp0 :: DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs Env2 Ty0
env2 Exp0
e0 =
  let triv :: String -> L0.Exp0 -> PassM ([Binds (L0.Exp0)], L0.Exp0)
      triv :: [Char] -> Exp0 -> PassM ([Binds Exp0], Exp0)
triv [Char]
m Exp0
e = -- Force something to be trivial
        if Exp0 -> Bool
forall e. Expression e => e -> Bool
isTrivial Exp0
e
        then ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp0
e)
        else do Var
tmp <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (Var -> PassM Var) -> Var -> PassM Var
forall a b. (a -> b) -> a -> b
$ [Char] -> Var
toVar ([Char] -> Var) -> [Char] -> Var
forall a b. (a -> b) -> a -> b
$ [Char]
"flt" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m
                let ty :: Ty0
ty = DDefs0 -> Env2 Ty0 -> Exp0 -> Ty0
L0.recoverType DDefs0
ddfs Env2 Ty0
env2 Exp0
e
                ([(Var, [Ty0], Ty0, Exp0)]
bnds,Exp0
e') <- DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs Env2 Ty0
env2 Exp0
e
                ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [(Var, [Ty0], Ty0, Exp0)]
bnds[(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++[(Var
tmp,[],Ty0
ty,Exp0
e')]
                       , Var -> Exp0
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
tmp)

      go :: L0.Exp0 -> PassM ([Binds (L0.Exp0)], L0.Exp0)
      go :: Exp0 -> PassM ([Binds Exp0], Exp0)
go = DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs Env2 Ty0
env2

      gols :: ([Exp0] -> b)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
gols [Exp0] -> b
f [Exp0]
ls [Char]
m = do ([[(Var, [Ty0], Ty0, Exp0)]]
bndss,[Exp0]
ls') <- [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> Exp0 -> PassM ([Binds Exp0], Exp0)
triv [Char]
m) [Exp0]
ls
                       [Char] -> PassM () -> PassM ()
forall a. [Char] -> a -> a
dbgTraceIt ([Exp0] -> [Char]
forall a. Out a => a -> [Char]
sdoc [Exp0]
ls) (() -> PassM ()
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                       ([(Var, [Ty0], Ty0, Exp0)], b)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
bndss, [Exp0] -> b
f [Exp0]
ls')

  in
  case Exp0
e0 of
    LitE Int
_    -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp0
e0)
    CharE Char
_   -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp0
e0)
    FloatE{}  -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp0
e0)
    VarE    Var
_ -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp0
e0)
    LitSymE Var
_ -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([],Exp0
e0)

    AppE Var
f [Ty0]
lvs [Exp0]
ls     -> ([Exp0] -> Exp0)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall {b}.
([Exp0] -> b)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
gols (Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
f [Ty0]
lvs)  [Exp0]
ls [Char]
"AppE"
    PrimAppE Prim Ty0
p [Exp0]
ls     -> ([Exp0] -> Exp0)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall {b}.
([Exp0] -> b)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
gols (Prim Ty0 -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty0
p)  [Exp0]
ls [Char]
"Prm"
    MkProdE [Exp0]
ls        -> ([Exp0] -> Exp0)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall {b}.
([Exp0] -> b)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
gols  [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE      [Exp0]
ls [Char]
"Prd"
    DataConE Ty0
loc [Char]
k [Exp0]
ls -> ([Exp0] -> Exp0)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall {b}.
([Exp0] -> b)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
gols (Ty0 -> [Char] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
loc -> [Char] -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE Ty0
loc [Char]
k) [Exp0]
ls [Char]
"Pkd"

    LetE (Var
v1,[Ty0]
lv1,Ty0
t1, ((LetE (Var
v2,[Ty0]
lv2,Ty0
t2,Exp0
rhs2) Exp0
rhs1))) Exp0
bod -> do
      ([(Var, [Ty0], Ty0, Exp0)]
bnd, Exp0
rhs) <- Exp0 -> PassM ([Binds Exp0], Exp0)
go ((Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v2,[Ty0]
lv2,Ty0
t2,Exp0
rhs2) (Exp0 -> Exp0) -> Exp0 -> Exp0
forall a b. (a -> b) -> a -> b
$
                        (Var, [Ty0], Ty0, Exp0) -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v1,[Ty0]
lv1,Ty0
t1,Exp0
rhs1) Exp0
bod)
      ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [Ty0], Ty0, Exp0)]
bnd, Exp0
rhs)

    LetE (Var
v,[Ty0]
locs,Ty0
t,Exp0
rhs) Exp0
bod -> do ([(Var, [Ty0], Ty0, Exp0)]
bnd1,Exp0
rhs') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
rhs
                                  ([(Var, [Ty0], Ty0, Exp0)]
bnd2,Exp0
bod') <- DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs (Var -> Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Var -> a -> Env2 a -> Env2 a
extendVEnv Var
v Ty0
t Env2 Ty0
env2) Exp0
bod
                                  ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [Ty0], Ty0, Exp0)]
bnd1[(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++[(Var
v,[Ty0]
locs,Ty0
t,Exp0
rhs')][(Var, [Ty0], Ty0, Exp0)]
-> [(Var, [Ty0], Ty0, Exp0)] -> [(Var, [Ty0], Ty0, Exp0)]
forall a. [a] -> [a] -> [a]
++[(Var, [Ty0], Ty0, Exp0)]
bnd2, Exp0
bod')
    IfE Exp0
a Exp0
b Exp0
c -> do ([(Var, [Ty0], Ty0, Exp0)]
b1,Exp0
a') <- [Char] -> Exp0 -> PassM ([Binds Exp0], Exp0)
triv [Char]
"If" Exp0
a
                    ([(Var, [Ty0], Ty0, Exp0)]
b2,Exp0
b') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
b
                    ([(Var, [Ty0], Ty0, Exp0)]
b3,Exp0
c') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
c
                    ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [Ty0], Ty0, Exp0)]
b1, Exp0 -> Exp0 -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp0
a' ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [Ty0], Ty0, Exp0)]
b2 Exp0
b') ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [Ty0], Ty0, Exp0)]
b3 Exp0
c'))
    -- This can happen anywhere, but doing it here prevents
    -- unneccessary bloat where we can ill afford it:
    ProjE Int
ix (MkProdE [Exp0]
ls) -> do
      -- dbgTrace 5 (" [flatten] Reducing project-of-tuple, index "++show ix++
      --             " expr:  "++take 80 (show l)++"...")
      ([(Var, [Ty0], Ty0, Exp0)]
bnd,Exp0
rhs) <- Exp0 -> PassM ([Binds Exp0], Exp0)
go ([Exp0]
ls [Exp0] -> Int -> Exp0
forall a. HasCallStack => [a] -> Int -> a
!! Int
ix)
      ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [Ty0], Ty0, Exp0)]
bnd, Exp0
rhs)

    ProjE Int
ix Exp0
e -> do ([(Var, [Ty0], Ty0, Exp0)]
b,Exp0
e') <- [Char] -> Exp0 -> PassM ([Binds Exp0], Exp0)
triv [Char]
"Prj" Exp0
e
                     ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [Ty0], Ty0, Exp0)]
b, Int -> Exp0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
ix Exp0
e')

    CaseE Exp0
e [([Char], [(Var, Ty0)], Exp0)]
ls -> do ([(Var, [Ty0], Ty0, Exp0)]
b,Exp0
e') <- [Char] -> Exp0 -> PassM ([Binds Exp0], Exp0)
triv [Char]
"Cse" Exp0
e
                     [([Char], [(Var, Ty0)], Exp0)]
ls' <- [([Char], [(Var, Ty0)], Exp0)]
-> (([Char], [(Var, Ty0)], Exp0)
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [(Var, Ty0)], Exp0)]
ls ((([Char], [(Var, Ty0)], Exp0)
  -> PassM ([Char], [(Var, Ty0)], Exp0))
 -> PassM [([Char], [(Var, Ty0)], Exp0)])
-> (([Char], [(Var, Ty0)], Exp0)
    -> PassM ([Char], [(Var, Ty0)], Exp0))
-> PassM [([Char], [(Var, Ty0)], Exp0)]
forall a b. (a -> b) -> a -> b
$ \ ([Char]
k,[(Var, Ty0)]
vrs,Exp0
rhs) -> do
                              let tys :: [Ty0]
tys = DDefs0 -> [Char] -> [Ty0]
forall a. Out a => DDefs a -> [Char] -> [a]
lookupDataCon DDefs0
ddfs [Char]
k
                                  vrs' :: [Var]
vrs' = ((Var, Ty0) -> Var) -> [(Var, Ty0)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Ty0) -> Var
forall a b. (a, b) -> a
fst [(Var, Ty0)]
vrs
                                  env2' :: Env2 Ty0
env2' = TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Var] -> [Ty0] -> [(Var, Ty0)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vrs' [Ty0]
tys)) Env2 Ty0
env2
                              ([(Var, [Ty0], Ty0, Exp0)]
b2,Exp0
rhs') <- DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs Env2 Ty0
env2' Exp0
rhs
                              ([Char], [(Var, Ty0)], Exp0) -> PassM ([Char], [(Var, Ty0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
k,[(Var, Ty0)]
vrs, [(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [Ty0], Ty0, Exp0)]
b2 Exp0
rhs')
                     ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, [Ty0], Ty0, Exp0)]
b, Exp0 -> [([Char], [(Var, Ty0)], Exp0)] -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [([Char], [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp0
e' [([Char], [(Var, Ty0)], Exp0)]
ls')
    -- TimeIt is treated like a conditional.  Don't lift out of it:
    TimeIt Exp0
e Ty0
_t Bool
b -> do
      ([(Var, [Ty0], Ty0, Exp0)]
bnd,Exp0
e') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
e
      ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Exp0 -> Ty0 -> Bool -> Exp0
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [Ty0], Ty0, Exp0)]
bnd Exp0
e') (DDefs0 -> Env2 Ty0 -> Exp0 -> Ty0
L0.recoverType DDefs0
ddfs Env2 Ty0
env2 Exp0
e) Bool
b)

    SpawnE Var
f [Ty0]
lvs [Exp0]
ls -> ([Exp0] -> Exp0)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall {b}.
([Exp0] -> b)
-> [Exp0] -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], b)
gols (Var -> [Ty0] -> [Exp0] -> Exp0
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
SpawnE Var
f [Ty0]
lvs)  [Exp0]
ls [Char]
"AppE"
    Exp0
SyncE -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
forall (ext :: * -> * -> *) loc dec. PreExp ext loc dec
SyncE)
    WithArenaE{}  -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. HasCallStack => [Char] -> a
error [Char]
"flattenL0: WitnArenaE not handled."
    MapE (Var, Ty0, Exp0)
_ Exp0
_      -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. HasCallStack => [Char] -> a
error [Char]
"FINISHLISTS"
    FoldE (Var, Ty0, Exp0)
_ (Var, Ty0, Exp0)
_ Exp0
_   -> [Char] -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. HasCallStack => [Char] -> a
error [Char]
"FINISHLISTS"

    Ext E0Ext Ty0 Ty0
ext ->
      case E0Ext Ty0 Ty0
ext of
        L0.LambdaE [(Var, Ty0)]
args Exp0
bod -> do
          ([(Var, [Ty0], Ty0, Exp0)]
bnd1,Exp0
bod') <- DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs (TyEnv Ty0 -> Env2 Ty0 -> Env2 Ty0
forall a. Map Var a -> Env2 a -> Env2 a
extendsVEnv ([(Var, Ty0)] -> TyEnv Ty0
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Var, Ty0)]
args) Env2 Ty0
env2) Exp0
bod
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
bnd1, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ [(Var, Ty0)] -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
[(Var, dec)] -> PreExp E0Ext loc dec -> E0Ext loc dec
L0.LambdaE [(Var, Ty0)]
args Exp0
bod')
        L0.PolyAppE Exp0
a Exp0
b -> do
          ([(Var, [Ty0], Ty0, Exp0)]
ba,Exp0
a') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
a
          ([(Var, [Ty0], Ty0, Exp0)]
bb,Exp0
b') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
b
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Exp0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec.
PreExp E0Ext loc dec -> PreExp E0Ext loc dec -> E0Ext loc dec
L0.PolyAppE ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [Ty0], Ty0, Exp0)]
ba Exp0
a') ([(Var, [Ty0], Ty0, Exp0)] -> Exp0 -> Exp0
forall l d (e :: * -> * -> *).
[(Var, [l], d, PreExp e l d)] -> PreExp e l d -> PreExp e l d
flatLets [(Var, [Ty0], Ty0, Exp0)]
bb Exp0
b'))
        L0.FunRefE{} -> ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Exp0
e0)
        L0.BenchE Var
fn [Ty0]
tyapps [Exp0]
args Bool
b -> do
          ([[(Var, [Ty0], Ty0, Exp0)]]
bnds, [Exp0]
args') <- [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([(Var, [Ty0], Ty0, Exp0)], Exp0)]
 -> ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0]))
-> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
-> PassM ([[(Var, [Ty0], Ty0, Exp0)]], [Exp0])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0))
-> [Exp0] -> PassM [([(Var, [Ty0], Ty0, Exp0)], Exp0)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp0 -> PassM ([Binds Exp0], Exp0)
Exp0 -> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
go [Exp0]
args
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[(Var, [Ty0], Ty0, Exp0)]] -> [(Var, [Ty0], Ty0, Exp0)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Var, [Ty0], Ty0, Exp0)]]
bnds, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Var -> [Ty0] -> [Exp0] -> Bool -> E0Ext Ty0 Ty0
forall loc dec.
Var -> [loc] -> [PreExp E0Ext loc dec] -> Bool -> E0Ext loc dec
L0.BenchE Var
fn [Ty0]
tyapps [Exp0]
args' Bool
b)
        L0.ParE0 [Exp0]
_ls -> [Char] -> PassM ([Binds Exp0], Exp0)
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM ([Binds Exp0], Exp0))
-> [Char] -> PassM ([Binds Exp0], Exp0)
forall a b. (a -> b) -> a -> b
$ [Char]
"flattenL0: ParE0 wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e0
        L0.PrintPacked Ty0
ty Exp0
arg -> do
          ([(Var, [Ty0], Ty0, Exp0)]
bnds, Exp0
arg') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
arg
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
bnds, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
L0.PrintPacked Ty0
ty Exp0
arg')
        L0.CopyPacked Ty0
ty Exp0
arg -> do
          ([(Var, [Ty0], Ty0, Exp0)]
bnds, Exp0
arg') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
arg
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
bnds, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
L0.CopyPacked Ty0
ty Exp0
arg')
        L0.TravPacked Ty0
ty Exp0
arg -> do
          ([(Var, [Ty0], Ty0, Exp0)]
bnds, Exp0
arg') <- Exp0 -> PassM ([Binds Exp0], Exp0)
go Exp0
arg
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
bnds, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Ty0 -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. dec -> PreExp E0Ext loc dec -> E0Ext loc dec
L0.TravPacked Ty0
ty Exp0
arg')
        L0.L Loc
p Exp0
e -> do
          ([(Var, [Ty0], Ty0, Exp0)]
bnd1,Exp0
e') <- DDefs0 -> Env2 Ty0 -> Exp0 -> PassM ([Binds Exp0], Exp0)
flattenExp0 DDefs0
ddfs Env2 Ty0
env2 Exp0
e
          ([(Var, [Ty0], Ty0, Exp0)], Exp0)
-> PassM ([(Var, [Ty0], Ty0, Exp0)], Exp0)
forall a. a -> PassM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Var, [Ty0], Ty0, Exp0)]
bnd1, E0Ext Ty0 Ty0 -> Exp0
forall (ext :: * -> * -> *) loc dec.
ext loc dec -> PreExp ext loc dec
Ext (E0Ext Ty0 Ty0 -> Exp0) -> E0Ext Ty0 Ty0 -> Exp0
forall a b. (a -> b) -> a -> b
$ Loc -> Exp0 -> E0Ext Ty0 Ty0
forall loc dec. Loc -> PreExp E0Ext loc dec -> E0Ext loc dec
L0.L Loc
p Exp0
e')
        L0.LinearExt{} -> [Char] -> PassM ([Binds Exp0], Exp0)
forall a. HasCallStack => [Char] -> a
error ([Char] -> PassM ([Binds Exp0], Exp0))
-> [Char] -> PassM ([Binds Exp0], Exp0)
forall a b. (a -> b) -> a -> b
$ [Char]
"flattenExp0: a linear types extension wasn't desugared: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Exp0 -> [Char]
forall a. Out a => a -> [Char]
sdoc Exp0
e0