{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-all #-}

module Gibbon.Passes.Fusion2 (fusion2) where
import Prelude hiding (exp)
import Control.Arrow ((&&&))

import           Control.Exception
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Vector as V
import           Data.Char ( toLower )
import           Debug.Trace
import           Control.DeepSeq
import           GHC.Generics (Generic, Generic1)
import           Data.Tuple.All
import           Control.Monad
import Gibbon.Pretty
import Gibbon.Common
import Gibbon.Passes.Freshen (freshExp1)
import Gibbon.L1.Syntax as L1
import Data.Text  (breakOnAll, pack, splitOn)
--------------------------------------------------------------------------------

-- countFUS :: String -> Int
-- countFUS str =  length $ breakOnAll (pack "FUS")  (pack str)
--       --  `debug1` ("opppa" L.++
--       --      (show str) L.++"\nress:\n"
--       --      L.++ (show (breakOnAll (pack str) (pack "FUS") ))
--       --       )


wordCount :: String -> [(String, Int)]
wordCount :: String -> [(String, Int)]
wordCount = ([String] -> (String, Int)) -> [[String]] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
forall a. HasCallStack => [a] -> a
L.head ([String] -> String)
-> ([String] -> Int) -> [String] -> (String, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length) ([[String]] -> [(String, Int)])
-> (String -> [[String]]) -> String -> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
L.group ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
L.words (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
L.map Char -> Char
toLower

countFUS :: String -> (Int, Int)
countFUS :: String -> (Int, Int)
countFUS String
str = let ls1 :: [Text]
ls1= HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"_f_"  (String -> Text
pack String
str) in
               let ls2 :: [Text]
ls2 = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
L.concatMap (\Text
txt -> HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"_FUS" Text
txt ) [Text]
ls1 in
               let ls3 :: [Text]
ls3 = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (\Text
txt -> (Text
txtText -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") Bool -> Bool -> Bool
&& (Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"_")  ) [Text]
ls2 in
               let ls4 :: [[Text]]
ls4 = [Text] -> [[Text]]
forall a. Eq a => [a] -> [[a]]
L.group ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort [Text]
ls3) in
               let ls5 :: [Int]
ls5 = ([Text] -> Int) -> [[Text]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
L.map (\[Text]
ls ->[Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Text]
ls) [[Text]]
ls4 in
               let mx :: Int
mx =[Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ls5 in
               (Int
mx, [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Text]
ls3)
                  (Int, Int) -> String -> (Int, Int)
forall {c}. c -> String -> c
`debug1` ((Int -> String
forall a. Show a => a -> String
show Int
mx) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"opppa" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ ( [Int] -> String
forall a. Show a => a -> String
show [Int]
ls5) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ ([Text] -> String
forall a. Show a => a -> String
show [Text]
ls3) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (String -> String
forall a. Show a => a -> String
show String
str))



debug :: c -> String -> c
debug =  (String -> c -> c) -> c -> String -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> String -> c -> c
forall a. Int -> String -> a -> a
dbgTrace Int
5)
debug1 :: c -> String -> c
debug1 = (String -> c -> c) -> c -> String -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> String -> c -> c
forall a. Int -> String -> a -> a
dbgTrace Int
2)
{-

E.g.

    gibbon_main =
      let tinput = generateTree
          t1 = travers1(tinoput)
          t2 = traverse2(tinput)
      in 10

For htis program, the DefTAble looks like:

  {
    tinput -> DefTableEntry { def      = generateTree
                            , fun_uses = [ (traverse1(..), 0 , t1), (traverse2, 0 , t2) ],
                              all_use_count = 2
                            }

    t1 -> DefTableEntry { def      = traverse1(..)
                        , fun_uses = [ ],
                        , all_use_count = 0
                        }
  }

-}


type DefTable = M.Map Symbol DefTableEntry

{- There will be one entry for each variable in the table. Each entry consist of
    1)The function application expression.
    2)The index at which the definition  appears at in the argument list.
    3)The defined symbol, if the the consuming expression of the form let x=App.
-}
data DefTableEntry = DefTableEntry
  { DefTableEntry -> Exp1
def           :: !Exp1 -- ^ The expression that defines this variable
  , DefTableEntry -> [FunctionUses]
fun_uses      :: ![FunctionUses] -- ()
  , DefTableEntry -> Int
all_use_count :: !Int -- ^ total number of uses (calls and not)
  , DefTableEntry -> Ty1
varType       :: Ty1
  } deriving (Int -> DefTableEntry -> String -> String
[DefTableEntry] -> String -> String
DefTableEntry -> String
(Int -> DefTableEntry -> String -> String)
-> (DefTableEntry -> String)
-> ([DefTableEntry] -> String -> String)
-> Show DefTableEntry
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DefTableEntry -> String -> String
showsPrec :: Int -> DefTableEntry -> String -> String
$cshow :: DefTableEntry -> String
show :: DefTableEntry -> String
$cshowList :: [DefTableEntry] -> String -> String
showList :: [DefTableEntry] -> String -> String
Show , (forall x. DefTableEntry -> Rep DefTableEntry x)
-> (forall x. Rep DefTableEntry x -> DefTableEntry)
-> Generic DefTableEntry
forall x. Rep DefTableEntry x -> DefTableEntry
forall x. DefTableEntry -> Rep DefTableEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DefTableEntry -> Rep DefTableEntry x
from :: forall x. DefTableEntry -> Rep DefTableEntry x
$cto :: forall x. Rep DefTableEntry x -> DefTableEntry
to :: forall x. Rep DefTableEntry x -> DefTableEntry
Generic)

type FunctionUses =
  ( Exp1 -- The AppE that uses a variable.
  , Int  -- i where variable V is the i'th argument in this function call.
  , Maybe Symbol -- The variable that binds this AppE.
  )


type PotentialPair = (Symbol, Symbol)
type PotentialsList = [DefTableEntry]


freshFunction :: FunDef1 -> PassM FunDef1
freshFunction :: FunDef1 -> PassM FunDef1
freshFunction FunDef1
f = do
  Exp1
body' <- VarEnv -> Exp1 -> PassM Exp1
freshExp1 VarEnv
forall k a. Map k a
M.empty  (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
f)
  let  f' :: FunDef1
f' = FunDef1
f{funBody :: Exp1
funBody = Exp1
body' }
  let argsOld :: [Var]
argsOld = FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
f'
  [Var]
argsNew <- (Var -> PassM Var) -> [Var] -> PassM [Var]
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]
Prelude.mapM Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym [Var]
argsOld
  let f'' :: FunDef1
f'' = FunDef1
f'{funArgs :: [Var]
funArgs = [Var]
argsNew}
  FunDef1 -> PassM FunDef1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDef1 -> PassM FunDef1) -> FunDef1 -> PassM FunDef1
forall a b. (a -> b) -> a -> b
$ FunDef1 -> [Var] -> [Var] -> FunDef1
forall {e :: * -> * -> *} {l} {d}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
FunDef (PreExp e l d) -> [Var] -> [Var] -> FunDef (PreExp e l d)
substArgs FunDef1
f''  [Var]
argsOld [Var]
argsNew
 where
  substArgs :: FunDef (PreExp e l d) -> [Var] -> [Var] -> FunDef (PreExp e l d)
substArgs FunDef (PreExp e l d)
f [] [] = FunDef (PreExp e l d)
f
  substArgs FunDef (PreExp e l d)
f (Var
old:[Var]
told) (Var
new:[Var]
tnew) =
    let f' :: FunDef (PreExp e l d)
f' = FunDef (PreExp e l d)
f{funBody :: PreExp e l d
funBody = PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE (Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
old) (Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
new) (FunDef (PreExp e l d) -> PreExp e l d
forall ex. FunDef ex -> ex
funBody FunDef (PreExp e l d)
f)}
    in FunDef (PreExp e l d) -> [Var] -> [Var] -> FunDef (PreExp e l d)
substArgs FunDef (PreExp e l d)
f' [Var]
told [Var]
tnew

removeCommonExpressions ::  Exp1->  Exp1
removeCommonExpressions :: Exp1 -> Exp1
removeCommonExpressions = Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
(Expression (ext loc dec),
 SubstitutableExt (PreExp ext loc dec) (ext loc dec), Eq dec,
 Eq loc, Eq (ext loc dec), Show dec, Show loc, Out dec, Out loc) =>
PreExp ext loc dec -> PreExp ext loc dec
go
   where
    go :: PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
exp  = case PreExp ext loc dec
exp of
      LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
bind) PreExp ext loc dec
body ->
        case PreExp ext loc dec
bind of
            ProjE Int
i PreExp ext loc dec
e ->
              let oldExp :: PreExp ext loc dec
oldExp = Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                  newExp :: PreExp ext loc dec
newExp = Int -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i PreExp ext loc dec
e
                  body' :: PreExp ext loc dec
body' = PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp ext loc dec
oldExp PreExp ext loc dec
newExp PreExp ext loc dec
body
              in PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
body'-- `debug` ("replace ::"L.++ (show oldExp) L.++ "with" L.++ (show newExp))
            VarE Var
v' ->
              let oldExp :: PreExp ext loc dec
oldExp = Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                  newExp :: PreExp ext loc dec
newExp = Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v'
                  body' :: PreExp ext loc dec
body' = PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp ext loc dec
oldExp PreExp ext loc dec
newExp PreExp ext loc dec
body
              in PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
body'
            PreExp ext loc dec
otherwise ->
              let oldExp :: PreExp ext loc dec
oldExp = PreExp ext loc dec
bind
                  newExp :: PreExp ext loc dec
newExp = Var -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
                  body' :: PreExp ext loc dec
body' = PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp ext loc dec
oldExp PreExp ext loc dec
newExp PreExp ext loc dec
body --`debug` ("removing duplicates of "L.++ (show oldExp))
              in (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
bind) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
body')
      IfE PreExp ext loc dec
cond PreExp ext loc dec
thenBody PreExp ext loc dec
elseBody ->
        PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
cond) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
thenBody) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
elseBody)

      CaseE PreExp ext loc dec
e [(String, [(Var, loc)], PreExp ext loc dec)]
ls      -> let ls' :: [(String, [(Var, loc)], PreExp ext loc dec)]
ls' = ((String, [(Var, loc)], PreExp ext loc dec)
 -> (String, [(Var, loc)], PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [(String, [(Var, loc)], PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
x, [(Var, loc)]
y, PreExp ext loc dec
exp) -> (String
x, [(Var, loc)]
y, PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
exp)) [(String, [(Var, loc)], PreExp ext loc dec)]
ls
          in  PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e [(String, [(Var, loc)], PreExp ext loc dec)]
ls'

      TimeIt PreExp ext loc dec
exp dec
x Bool
y  ->  PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
exp) dec
x Bool
y
      PreExp ext loc dec
x       -> PreExp ext loc dec
x

simplifyProjections :: Exp1->  Exp1
simplifyProjections :: Exp1 -> Exp1
simplifyProjections Exp1
expin = Exp1 -> Exp1
removeCommonExpressions (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
expin Map Var (Vector Exp1)
forall k a. Map k a
M.empty)
   where
    go :: Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
exp Map Var (Vector Exp1)
mp = case Exp1
exp of
      LetE (Var
v, [()]
ls, Ty1
t, Exp1
bind) Exp1
body ->
        case Exp1
bind of
            MkProdE [Exp1]
prodList ->
              let bind' :: Exp1
bind' = Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
bind Map Var (Vector Exp1)
mp
                  mp' :: Map Var (Vector Exp1)
mp' = Var
-> Vector Exp1 -> Map Var (Vector Exp1) -> Map Var (Vector Exp1)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
prodList) Map Var (Vector Exp1)
mp
                  body' :: Exp1
body' = Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
body Map Var (Vector Exp1)
mp'
              in  (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
ls, Ty1
t, Exp1
bind')  Exp1
body'  Exp1 -> String -> Exp1
forall {c}. c -> String -> c
`debug1` (String
"here is one lol" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Doc -> String
render (Exp1 -> Doc
forall e. Pretty e => e -> Doc
pprint Exp1
expin) )

            Exp1
otherwise ->
              let bind' :: Exp1
bind' = Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
bind Map Var (Vector Exp1)
mp
                  body' :: Exp1
body' = Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
body Map Var (Vector Exp1)
mp
              in   (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
ls, Ty1
t, Exp1
bind')  Exp1
body'

      IfE Exp1
cond Exp1
thenBody Exp1
elseBody ->
        Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
cond Map Var (Vector Exp1)
mp ) (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
thenBody Map Var (Vector Exp1)
mp ) (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
elseBody Map Var (Vector Exp1)
mp)

      CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls      -> let ls' :: [(String, [(Var, ())], Exp1)]
ls' = ((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
x, [(Var, ())]
y, Exp1
exp) -> (String
x, [(Var, ())]
y, Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
exp Map Var (Vector Exp1)
mp)) [(String, [(Var, ())], Exp1)]
ls
          in  Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
e Map Var (Vector Exp1)
mp) [(String, [(Var, ())], Exp1)]
ls'

      PrimAppE Prim Ty1
p [Exp1]
ls ->
        let ls' :: [Exp1]
ls' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (Exp1 -> Map Var (Vector Exp1) -> Exp1
`go` Map Var (Vector Exp1)
mp) [Exp1]
ls
        in Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty1
p [Exp1]
ls'

      TimeIt Exp1
exp Ty1
x Bool
y  ->  Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
exp Map Var (Vector Exp1)
mp) Ty1
x Bool
y

      L1.ProjE Int
i Exp1
e ->
        case Exp1
e of
          VarE Var
v ->
            case Var -> Map Var (Vector Exp1) -> Maybe (Vector Exp1)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
v Map Var (Vector Exp1)
mp of
               Maybe (Vector Exp1)
Nothing ->  Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
L1.ProjE Int
i Exp1
e
               Just Vector Exp1
ls -> Vector Exp1
ls Vector Exp1 -> Int -> Exp1
forall a. Vector a -> Int -> a
V.! Int
i
          Exp1
otherwise -> Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
L1.ProjE Int
i (Exp1 -> Map Var (Vector Exp1) -> Exp1
go Exp1
e Map Var (Vector Exp1)
mp)
      DataConE ()
x String
y [Exp1]
ls->
        let ls' :: [Exp1]
ls' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (Exp1 -> Map Var (Vector Exp1) -> Exp1
`go` Map Var (Vector Exp1)
mp) [Exp1]
ls
        in () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
x String
y [Exp1]
ls'
      AppE Var
v [()]
loc [Exp1]
args  ->
          Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [()]
loc ((Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
map (Exp1 -> Map Var (Vector Exp1) -> Exp1
`go` Map Var (Vector Exp1)
mp) [Exp1]
args)
      MkProdE [Exp1]
ls->
        let ls' :: [Exp1]
ls' = (Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (Exp1 -> Map Var (Vector Exp1) -> Exp1
`go` Map Var (Vector Exp1)
mp) [Exp1]
ls
        in    [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE [Exp1]
ls'

      Exp1
x       -> Exp1
x

replaceLeafWithExp :: Exp1 ->  Exp1  -> Exp1
replaceLeafWithExp :: Exp1 -> Exp1 -> Exp1
replaceLeafWithExp Exp1
exp  Exp1
newTail  =
  Exp1 -> Exp1
go Exp1
exp
   where
     go :: Exp1 -> Exp1
go Exp1
ex =
      case Exp1
ex of
            L1.LetE (Var
v,[()]
ls,Ty1
t, Exp1
e1) Exp1
e2 -> (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (Var
v,[()]
ls,Ty1
t, Exp1
e1)  (Exp1 -> Exp1
go Exp1
e2)
            Exp1
x -> Exp1
newTail

replaceLeafWithBind :: Exp1 -> (Int -> Var) -> Ty1 -> Exp1 -> Exp1
replaceLeafWithBind :: Exp1 -> (Int -> Var) -> Ty1 -> Exp1 -> Exp1
replaceLeafWithBind Exp1
exp Int -> Var
genVar Ty1
varType Exp1
tailExp =
  Exp1 -> Exp1
go Exp1
exp
   where
     go :: Exp1 -> Exp1
go Exp1
ex =
      case Exp1
ex of
          L1.LetE (Var
v,[()]
ls,Ty1
t, Exp1
e1) Exp1
e2 -> (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (Var
v,[()]
ls,Ty1
t, Exp1
e1)  (Exp1 -> Exp1
go Exp1
e2)
          Exp1
x -> case Ty1
varType of
              ProdTy [Ty1]
ls2 ->
                  let xDestructed :: Vector Exp1
xDestructed = [Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList (case  Exp1
x of MkProdE [Exp1]
ls -> [Exp1]
ls)
                      newExp :: Exp1
newExp = (Exp1 -> Int -> Ty1 -> Exp1) -> Exp1 -> Vector Ty1 -> Exp1
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
                              (\Exp1
tExp Int
subscript Ty1
ty ->
                                let newVar :: Var
newVar = Int -> Var
genVar Int
subscript
                                in (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (Var
newVar,[],Ty1
ty, Vector Exp1
xDestructed Vector Exp1 -> Int -> Exp1
forall a. Vector a -> Int -> a
V.! Int
subscript) Exp1
tExp
                              ) Exp1
tailExp ([Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList [Ty1]
ls2)
                  in Exp1
newExp
              Ty1
otherwise ->
                let newVar :: Var
newVar = Int -> Var
genVar Int
0
                in  (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (Var
newVar,[],Ty1
varType, Exp1
x) Exp1
tailExp

addOuterTailCall:: Exp1 -> Var -> Var -> Ty1 ->  [Exp1] -> Exp1
addOuterTailCall :: Exp1 -> Var -> Var -> Ty1 -> [Exp1] -> Exp1
addOuterTailCall Exp1
exp Var
fName Var
parName Ty1
varType [Exp1]
outerArgs =
  Exp1 -> Exp1
removeCommonExpressions (Exp1 -> Exp1
go Exp1
exp)
   where
     go :: Exp1 -> Exp1
go Exp1
ex =
      case Exp1
ex of
          L1.LetE (Var
v,[()]
ls,Ty1
t, Exp1
e1) Exp1
e2 -> (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
L1.LetE (Var
v,[()]
ls,Ty1
t, Exp1
e1)  (Exp1 -> Exp1
go Exp1
e2)
          Exp1
x ->
            let newCall :: Exp1
newCall = Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fName [] ( (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
parName) Exp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
:[Exp1]
outerArgs)
                newLet :: Exp1
newLet = (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
parName, [], Ty1
varType, Exp1
x) Exp1
newCall
            in Exp1
newLet
{- This function≈ collect the following information for each defined variable:
  1) The defining expression. (stored in DefTableEntry::def)
  2) The consumer of the definition that are candidates for fusion;the function
  is consumed in the first argument. (stored in DefTableEntry::fun_uses)
  not: uses mutual exclusive paths are counted by adding them (each is
  considered  a use).
  3) Total number of uses (references) of the defined variable.
-}
buildDefTable :: Exp1 -> DefTable
buildDefTable :: Exp1 -> DefTable
buildDefTable Exp1
ex = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go Exp1
ex Maybe Symbol
forall a. Maybe a
Nothing DefTable
forall k a. Map k a
M.empty
  where
    go :: Exp1 -> Maybe Symbol -> DefTable -> DefTable
go Exp1
ex Maybe Symbol
definingSymbol DefTable
table =
      case Exp1
ex of
        VarE (Var Symbol
sym) -> (DefTableEntry -> Maybe DefTableEntry)
-> Symbol -> DefTable -> DefTable
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update DefTableEntry -> Maybe DefTableEntry
incrUses Symbol
sym DefTable
table
        LetE (Var Symbol
symLet, [()]
_, Ty1
t, Exp1
bind) Exp1
body ->
          let table' :: DefTable
table' =
                Symbol -> DefTableEntry -> DefTable -> DefTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert
                  Symbol
symLet
                  (DefTableEntry
                     { def :: Exp1
def = Exp1
bind
                     , fun_uses :: [FunctionUses]
fun_uses = []
                     , all_use_count :: Int
all_use_count = Int
0
                     , varType :: Ty1
varType = Ty1
t
                     })
                  DefTable
table
              table'' :: DefTable
table'' = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go Exp1
bind (Symbol -> Maybe Symbol
forall a. a -> Maybe a
Just Symbol
symLet) DefTable
table'
           in Exp1 -> Maybe Symbol -> DefTable -> DefTable
go Exp1
body Maybe Symbol
definingSymbol DefTable
table''

    -- The thing that is traversed is always the first argument.
    -- Here, we record a function use for the first argument
    -- in the DefTable.
    -- add function uses of interest
    -- [functions calls traversing tree in first argument]
        AppE Var
fName [()]
_ [Exp1]
args ->
          let addFunctionUse :: FunctionUses -> DefTableEntry -> Maybe DefTableEntry
addFunctionUse FunctionUses
newUse (DefTableEntry Exp1
def [FunctionUses]
fun_uses Int
c Ty1
t) =
                DefTableEntry -> Maybe DefTableEntry
forall a. a -> Maybe a
Just (DefTableEntry -> Maybe DefTableEntry)
-> DefTableEntry -> Maybe DefTableEntry
forall a b. (a -> b) -> a -> b
$ Exp1 -> [FunctionUses] -> Int -> Ty1 -> DefTableEntry
DefTableEntry Exp1
def (FunctionUses
newUse FunctionUses -> [FunctionUses] -> [FunctionUses]
forall a. a -> [a] -> [a]
: [FunctionUses]
fun_uses) Int
c Ty1
t
              table' :: DefTable
table' =
                if (([Exp1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp1]
args) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
                  then case ([Exp1] -> Exp1
forall a. HasCallStack => [a] -> a
head [Exp1]
args) of
                         VarE (Var Symbol
sym) ->
                           (DefTableEntry -> Maybe DefTableEntry)
-> Symbol -> DefTable -> DefTable
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update
                             (FunctionUses -> DefTableEntry -> Maybe DefTableEntry
addFunctionUse (Exp1
ex, Int
0, Maybe Symbol
definingSymbol))
                             Symbol
sym
                             DefTable
table
                              -- If it's anything else, it's not a candidate for fusion, and
                             -- we can ignore it.
                         Exp1
_ -> DefTable
table
                  else DefTable
table
           in (DefTable -> Exp1 -> DefTable) -> DefTable -> [Exp1] -> DefTable
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\DefTable
acc Exp1
a -> Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
a) Maybe Symbol
forall a. Maybe a
Nothing DefTable
acc) DefTable
table' [Exp1]
args
        MkProdE [Exp1]
argsList -> [Exp1] -> DefTable -> DefTable
buildDefTable_args [Exp1]
argsList DefTable
table
          where buildDefTable_args :: [Exp1] -> DefTable -> DefTable
buildDefTable_args [] DefTable
tb = DefTable
tb
                buildDefTable_args (Exp1
h:[Exp1]
tail) DefTable
table =
                  [Exp1] -> DefTable -> DefTable
buildDefTable_args [Exp1]
tail (Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
h) Maybe Symbol
forall a. Maybe a
Nothing DefTable
table)
        PrimAppE Prim Ty1
_ [Exp1]
ls -> (DefTable -> Exp1 -> DefTable) -> DefTable -> [Exp1] -> DefTable
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl DefTable -> Exp1 -> DefTable
f DefTable
table [Exp1]
ls
          where f :: DefTable -> Exp1 -> DefTable
f DefTable
tbl Exp1
exp = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
exp) Maybe Symbol
forall a. Maybe a
Nothing DefTable
tbl
        IfE Exp1
cond Exp1
thenBody Exp1
elseBody ->
          let table' :: DefTable
table' = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
cond) Maybe Symbol
forall a. Maybe a
Nothing DefTable
table
           in let table'' :: DefTable
table'' = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
thenBody) Maybe Symbol
definingSymbol DefTable
table'
               in Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
elseBody) Maybe Symbol
definingSymbol DefTable
table''
        CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls ->
          let table' :: DefTable
table' = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
e) Maybe Symbol
forall a. Maybe a
Nothing DefTable
table
           in (DefTable -> (String, [(Var, ())], Exp1) -> DefTable)
-> DefTable -> [(String, [(Var, ())], Exp1)] -> DefTable
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl DefTable -> (String, [(Var, ())], Exp1) -> DefTable
f DefTable
table' [(String, [(Var, ())], Exp1)]
ls
          where f :: DefTable -> (String, [(Var, ())], Exp1) -> DefTable
f DefTable
tbl (String
_, [(Var, ())]
_, Exp1
exp) = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
exp) Maybe Symbol
definingSymbol DefTable
tbl
        DataConE ()
_ String
_ [Exp1]
ls -> (DefTable -> Exp1 -> DefTable) -> DefTable -> [Exp1] -> DefTable
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl DefTable -> Exp1 -> DefTable
f DefTable
table [Exp1]
ls
          where f :: DefTable -> Exp1 -> DefTable
f DefTable
tbl Exp1
exp = Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
exp) Maybe Symbol
forall a. Maybe a
Nothing DefTable
tbl
        TimeIt Exp1
exp Ty1
_ Bool
_ -> Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
exp) Maybe Symbol
definingSymbol DefTable
table
        ProjE Int
index Exp1
exp -> Exp1 -> Maybe Symbol -> DefTable -> DefTable
go (Exp1
exp) Maybe Symbol
forall a. Maybe a
Nothing DefTable
table
        LitE Int
_ -> DefTable
table
        Exp1
x ->
          DefTable
table DefTable -> String -> DefTable
forall {c}. c -> String -> c
`debug`
          (String
"please handle:" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Exp1 -> String
forall a. Show a => a -> String
show Exp1
x String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"in buildDefTable\n")
      where
        incrUses :: DefTableEntry -> Maybe DefTableEntry
incrUses (DefTableEntry Exp1
def [FunctionUses]
fun_uses Int
c Ty1
t) =
          DefTableEntry -> Maybe DefTableEntry
forall a. a -> Maybe a
Just (DefTableEntry -> Maybe DefTableEntry)
-> DefTableEntry -> Maybe DefTableEntry
forall a b. (a -> b) -> a -> b
$ Exp1 -> [FunctionUses] -> Int -> Ty1 -> DefTableEntry
DefTableEntry Exp1
def [FunctionUses]
fun_uses (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Ty1
t


extractAppNameFromLet ::  Exp1 -> Var
extractAppNameFromLet :: Exp1 -> Var
extractAppNameFromLet (LetE (Var Symbol
symLet,[()]
_,Ty1
_,(AppE Var
var [()]
_ [Exp1]
_ )) Exp1
_)  = Var
var

extractLetSymbolFromLet ::  Exp1 -> Symbol
extractLetSymbolFromLet :: Exp1 -> Symbol
extractLetSymbolFromLet (LetE (Var Symbol
symLet,[()]
_,Ty1
_,(AppE Var
var [()]
_ [Exp1]
_ )) Exp1
_)  = Symbol
symLet

extractAppEName ::  Exp1 -> Var
extractAppEName :: Exp1 -> Var
extractAppEName (AppE Var
var [()]
_ [Exp1]
_ ) = Var
var
extractAppEName  Exp1
x = String -> Var
forall a. HasCallStack => String -> a
error(Exp1 -> String
forall a. Show a => a -> String
show Exp1
x)

-- Takes the table, and candidates which are already processed and
-- return one that isn't.
--
-- returns ((innerFun, outerFun), symbol defined by the outer)
findPotential :: DefTable -> [(Var, Var)] -> Maybe ((Var, Var), Maybe Symbol)
findPotential :: DefTable -> [(Var, Var)] -> Maybe ((Var, Var), Maybe Symbol)
findPotential DefTable
table [(Var, Var)]
skipList =
  case ((Symbol, DefTableEntry) -> Bool)
-> [(Symbol, DefTableEntry)] -> Maybe (Symbol, DefTableEntry)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Symbol, DefTableEntry) -> Bool
predicate (DefTable -> [(Symbol, DefTableEntry)]
forall k a. Map k a -> [(k, a)]
M.toList DefTable
table) of
    Maybe (Symbol, DefTableEntry)
Nothing -> Maybe ((Var, Var), Maybe Symbol)
forall a. Maybe a
Nothing
    Just (Symbol
_, DefTableEntry Exp1
def [FunctionUses]
fun_uses Int
use_count Ty1
t) ->
      ((Var, Var), Maybe Symbol) -> Maybe ((Var, Var), Maybe Symbol)
forall a. a -> Maybe a
Just
        ( (Exp1 -> Var
extractAppEName Exp1
def, Exp1 -> Var
extractAppEName (FunctionUses -> Exp1
forall a b. Sel1 a b => a -> b
sel1 ([FunctionUses] -> FunctionUses
forall a. HasCallStack => [a] -> a
L.head [FunctionUses]
fun_uses)))
        , FunctionUses -> Maybe Symbol
forall a b. Sel3 a b => a -> b
sel3 ([FunctionUses] -> FunctionUses
forall a. HasCallStack => [a] -> a
L.head [FunctionUses]
fun_uses))
  where
    predicate :: (Symbol, DefTableEntry) -> Bool
predicate (Symbol
_, DefTableEntry Exp1
def [FunctionUses]
fun_uses Int
use_count Ty1
t) =
      case Exp1
def of
        AppE Var
var [()]
_ [Exp1]
_ ->
          Bool -> Bool
not ([FunctionUses] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunctionUses]
fun_uses) Bool -> Bool -> Bool
&&
          (Var, Var) -> [(Var, Var)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
L.notElem
            (Exp1 -> Var
extractAppEName Exp1
def, Exp1 -> Var
extractAppEName (FunctionUses -> Exp1
forall a b. Sel1 a b => a -> b
sel1 ([FunctionUses] -> FunctionUses
forall a. HasCallStack => [a] -> a
L.head [FunctionUses]
fun_uses)))
            [(Var, Var)]
skipList
        Exp1
_ -> Bool
False

isPotential :: DefTable -> Maybe Symbol -> [(Var, Var)] -> Bool
isPotential :: DefTable -> Maybe Symbol -> [(Var, Var)] -> Bool
isPotential DefTable
table Maybe Symbol
symbol [(Var, Var)]
skipList =
  case Maybe Symbol
symbol of
    Maybe Symbol
Nothing -> Bool
False
    Just Symbol
symb ->
      case DefTable
table  DefTable -> Symbol -> Maybe DefTableEntry
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? Symbol
symb of
         Maybe DefTableEntry
Nothing       -> Bool
False --`debug`  (show skipList)
         Just (DefTableEntry Exp1
def [FunctionUses]
fun_uses Int
use_count Ty1
t)  ->
             ([FunctionUses] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [FunctionUses]
fun_uses Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) Bool -> Bool -> Bool
&& (Var, Var) -> [(Var, Var)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
L.notElem  (Exp1 -> Var
extractAppEName Exp1
def,
                Exp1 -> Var
extractAppEName(FunctionUses -> Exp1
forall a b. Sel1 a b => a -> b
sel1 ([FunctionUses] -> FunctionUses
forall a. HasCallStack => [a] -> a
L.head [FunctionUses]
fun_uses)) ) [(Var, Var)]
skipList

simplifyCases2 :: Exp1 ->  Exp1
simplifyCases2 :: Exp1 -> Exp1
simplifyCases2 = Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
(Expression (ext loc dec),
 SubstitutableExt (PreExp ext loc dec) (ext loc dec), Eq dec,
 Eq loc, Eq (ext loc dec), Show dec, Show loc, Out dec, Out loc) =>
PreExp ext loc dec -> PreExp ext loc dec
go
  where
    go :: PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
ex =
      case PreExp ext loc dec
ex of
        CaseE e1 :: PreExp ext loc dec
e1@((CaseE PreExp ext loc dec
e2 [(String, [(Var, loc)], PreExp ext loc dec)]
ls2)) [(String, [(Var, loc)], PreExp ext loc dec)]
ls1 -> PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e2 (((String, [(Var, loc)], PreExp ext loc dec)
 -> (String, [(Var, loc)], PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [(String, [(Var, loc)], PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f [(String, [(Var, loc)], PreExp ext loc dec)]
ls2)) --`debug` (show "original input was \n" L.++ (show (l (CaseE e2 (L.map f ls2)))))
          where f :: (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f (String, [(Var, loc)], PreExp ext loc dec)
oldItem = PreExp ext loc dec
-> (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
forall a b c. Upd3 a b c => a -> b -> c
upd3 (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE ((String, [(Var, loc)], PreExp ext loc dec) -> PreExp ext loc dec
forall a b. Sel3 a b => a -> b
sel3 (String, [(Var, loc)], PreExp ext loc dec)
oldItem) [(String, [(Var, loc)], PreExp ext loc dec)]
ls1) (String, [(Var, loc)], PreExp ext loc dec)
oldItem
        CaseE e1 :: PreExp ext loc dec
e1@((DataConE loc
loc String
k [PreExp ext loc dec]
constructorVars)) [(String, [(Var, loc)], PreExp ext loc dec)]
caseList ->
          let newBody :: Maybe (String, [(Var, loc)], PreExp ext loc dec)
newBody = ((String, [(Var, loc)], PreExp ext loc dec) -> Bool)
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> Maybe (String, [(Var, loc)], PreExp ext loc dec)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(String, [(Var, loc)], PreExp ext loc dec)
item -> (String, [(Var, loc)], PreExp ext loc dec) -> String
forall a b. Sel1 a b => a -> b
sel1 (String, [(Var, loc)], PreExp ext loc dec)
item String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k) [(String, [(Var, loc)], PreExp ext loc dec)]
caseList
           in case Maybe (String, [(Var, loc)], PreExp ext loc dec)
newBody of
                Maybe (String, [(Var, loc)], PreExp ext loc dec)
Nothing -> String -> PreExp ext loc dec
forall a. HasCallStack => String -> a
error String
"unmatched constructor!"
                Just (String
k, [(Var, loc)]
caseVars, PreExp ext loc dec
caseExp) ->
                  PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec -> PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall a b. (a -> b) -> a -> b
$[PreExp ext loc dec]
-> [(Var, loc)] -> PreExp ext loc dec -> PreExp ext loc dec
forall {e :: * -> * -> *} {l} {d} {b}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
[PreExp e l d] -> [(Var, b)] -> PreExp e l d -> PreExp e l d
case_subst [PreExp ext loc dec]
constructorVars [(Var, loc)]
caseVars PreExp ext loc dec
caseExp
                  where case_subst :: [PreExp e l d] -> [(Var, b)] -> PreExp e l d -> PreExp e l d
case_subst (PreExp e l d
x1:[PreExp e l d]
l1) ((Var, b)
x2:[(Var, b)]
l2) PreExp e l d
exp =
                          Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst ((Var, b) -> Var
forall a b. (a, b) -> a
fst (Var, b)
x2) PreExp e l d
x1 ([PreExp e l d] -> [(Var, b)] -> PreExp e l d -> PreExp e l d
case_subst [PreExp e l d]
l1 [(Var, b)]
l2 PreExp e l d
exp)
                        case_subst [] [] PreExp e l d
exp = PreExp e l d
exp
        CaseE (IfE PreExp ext loc dec
e1 PreExp ext loc dec
e2 PreExp ext loc dec
e3) [(String, [(Var, loc)], PreExp ext loc dec)]
ls ->
          PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec -> PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall a b. (a -> b) -> a -> b
$ PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE PreExp ext loc dec
e1 (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e2 [(String, [(Var, loc)], PreExp ext loc dec)]
ls) (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e3 [(String, [(Var, loc)], PreExp ext loc dec)]
ls)
        CaseE e1 :: PreExp ext loc dec
e1@(LetE (Var, [loc], dec, PreExp ext loc dec)
bind PreExp ext loc dec
body) [(String, [(Var, loc)], PreExp ext loc dec)]
ls1 ->
          let body' :: PreExp ext loc dec
body' = PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
body [(String, [(Var, loc)], PreExp ext loc dec)]
ls1)
           in (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [loc], dec, PreExp ext loc dec)
bind PreExp ext loc dec
body'
        CaseE PreExp ext loc dec
e1 [(String, [(Var, loc)], PreExp ext loc dec)]
ls1 -> PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e1 (((String, [(Var, loc)], PreExp ext loc dec)
 -> (String, [(Var, loc)], PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [(String, [(Var, loc)], PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f [(String, [(Var, loc)], PreExp ext loc dec)]
ls1)
          where f :: (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f (String, [(Var, loc)], PreExp ext loc dec)
item = PreExp ext loc dec
-> (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
forall a b c. Upd3 a b c => a -> b -> c
upd3 (PreExp ext loc dec -> PreExp ext loc dec
go ((String, [(Var, loc)], PreExp ext loc dec) -> PreExp ext loc dec
forall a b. Sel3 a b => a -> b
sel3 (String, [(Var, loc)], PreExp ext loc dec)
item)) (String, [(Var, loc)], PreExp ext loc dec)
item
        LetE (Var
v, [loc]
loc, dec
t, PreExp ext loc dec
rhs) PreExp ext loc dec
bod -> (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [loc]
loc, dec
t, PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
rhs) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
bod)
        AppE Var
v [loc]
loc [PreExp ext loc dec]
expList -> Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [loc]
loc ((PreExp ext loc dec -> PreExp ext loc dec)
-> [PreExp ext loc dec] -> [PreExp ext loc dec]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp ext loc dec -> PreExp ext loc dec
go [PreExp ext loc dec]
expList)
        IfE PreExp ext loc dec
e1 PreExp ext loc dec
e2 PreExp ext loc dec
e3 -> PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e1) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e2) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e3)
        TimeIt PreExp ext loc dec
e dec
d Bool
b -> PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e) dec
d Bool
b
        PreExp ext loc dec
ex -> PreExp ext loc dec
ex

inline2 :: FunDef1 -> FunDef1  -> PassM FunDef1
inline2 :: FunDef1 -> FunDef1 -> PassM FunDef1
inline2 FunDef1
inlined_fun FunDef1
outer_fun  =
 do
  Var
newTraversedTreeArg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"inputTree")
  let argTypes_outer :: [Ty1]
argTypes_outer = ([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
outer_fun)
      retType_outer :: Ty1
retType_outer = ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
outer_fun)
      argVar_outer :: Var
argVar_outer = [Var] -> Var
forall a. HasCallStack => [a] -> a
head ([Var] -> Var) -> [Var] -> Var
forall a b. (a -> b) -> a -> b
$ FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
outer_fun
      argTypes_inlined :: [Ty1]
argTypes_inlined = ([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
inlined_fun)
      argVar_inlined :: Var
argVar_inlined = [Var] -> Var
forall a. HasCallStack => [a] -> a
head ([Var] -> Var) -> [Var] -> Var
forall a b. (a -> b) -> a -> b
$ FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
inlined_fun
      retTypeInlined :: Ty1
retTypeInlined = ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
inlined_fun)
      traversedType :: Ty1
traversedType = [Ty1] -> Ty1
forall a. HasCallStack => [a] -> a
head [Ty1]
argTypes_inlined
      -- All arguments except the one that's traversed.

      -- is it ok that those are swapped lol!
      sideArgsTypesInlined :: [Ty1]
sideArgsTypesInlined = [Ty1] -> [Ty1]
forall a. HasCallStack => [a] -> [a]
tail [Ty1]
argTypes_inlined
      sidArgsTypesOuter :: [Ty1]
sidArgsTypesOuter = [Ty1] -> [Ty1]
forall a. HasCallStack => [a] -> [a]
tail [Ty1]
argTypes_outer
      newType :: ([Ty1], Ty1)
newType =
        ( [Ty1
traversedType] [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
++ [Ty1]
sideArgsTypesInlined [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
++ [Ty1]
sidArgsTypesOuter
        , Ty1
retType_outer)
      inlinedFunBody :: Exp1
inlinedFunBody =
        let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
argVar_inlined
            newExp :: Exp1
newExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newTraversedTreeArg
         in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
inlined_fun)

  -- the traversed tree in the outer is replaced with either a call to the inner
  -- or the body of the inner
  let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
argVar_outer
  let replaceWithCall :: Exp1 -> PassM Exp1
replaceWithCall Exp1
exp = do
        Var
newVar <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"innerCall")
        let rhs :: Exp1
rhs =
                (Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE
                   (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
inlined_fun)
                   []
                   ((Var -> Exp1) -> [Var] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE ( Var
newTraversedTreeArgVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
inlined_fun))))
            body :: Exp1
body = Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newVar) Exp1
exp
        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
newVar, [], Ty1
retTypeInlined, Exp1
rhs) Exp1
body

  let outerCaseList :: [(String, [(Var, ())], Exp1)]
outerCaseList =
        case (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
outer_fun) of
           CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls -> [(String, [(Var, ())], Exp1)]
ls

  Exp1
newBody <-
    case (Exp1
inlinedFunBody) of
      CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls -> do
        [(String, [(Var, ())], Exp1)]
ls' <-
          ((String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)]
-> PassM [(String, [(Var, ())], 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) -> [a] -> m [b]
Prelude.mapM
            (\(String
dataCon, [(Var, ())]
vars, Exp1
exp) -> do
              if Exp1 -> Bool
hasConstructorTail Exp1
exp
                then
                 do
                  let exp' :: Exp1
exp' = (Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp1
exp) [(String, [(Var, ())], Exp1)]
outerCaseList)
                  Exp1
exp'' <- Exp1 -> PassM Exp1
replaceWithCall Exp1
exp'
                  (String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dataCon, [(Var, ())]
vars,  Exp1
exp'')
                else
                 do
                  Var
newSymbol <-  Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"outerCall")
                  let exp' :: Exp1
exp' =
                       Exp1 -> Var -> Var -> Ty1 -> [Exp1] -> Exp1
addOuterTailCall Exp1
exp (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
outer_fun) (Var
newSymbol)
                          (([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd(FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
inlined_fun)) ((Var -> Exp1) -> [Var] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (\Var
v -> (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v)) ([Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
outer_fun)))

                  (String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dataCon, [(Var, ())]
vars, Exp1
exp')
            )
            [(String, [(Var, ())], Exp1)]
ls
        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newTraversedTreeArg) [(String, [(Var, ())], Exp1)]
ls')
      Exp1
x-> String -> PassM Exp1
forall a. HasCallStack => String -> a
error (Doc -> String
render (Exp1 -> Doc
forall e. Pretty e => e -> Doc
pprint Exp1
x))
 --     exp -> replaceWithCall (substE oldExp inlinedFunBody (l exp))

  let newArgs :: [Var]
newArgs =
        [Var
newTraversedTreeArg] [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
L.++ [Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
L.tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
inlined_fun) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
L.++
        [Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
L.tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
outer_fun)
  FunDef1 -> PassM FunDef1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return FunDef1
outer_fun {funArgs :: [Var]
funArgs = [Var]
newArgs, funTy :: ArrowTy (TyOf Exp1)
funTy = ([Ty1], Ty1)
ArrowTy (TyOf Exp1)
newType, funBody :: Exp1
funBody = Exp1
newBody}

{-
case (case c of D1-> K ,.. -> f)

case c of D1 ->
          D2 ->  f1 (f)
  The type of the new function is defined as the following :
   if
     innerType = TreeX-> Args1... -> RetType1
     outerType = RetType Args2... -> RetType2
  then
     inlinedType = TreeX -> Args1... ->  Args2... -> RetType2

-}
inline :: FunDef1 -> FunDef1 -> Int -> PassM FunDef1
inline :: FunDef1 -> FunDef1 -> Int -> PassM FunDef1
inline FunDef1
inlined_fun FunDef1
outer_fun Int
arg_pos = do
  Var
newTraversedTreeArg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"inputTree")
  let argTypes_outer :: [Ty1]
argTypes_outer = ([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
outer_fun)
      retType_outer :: Ty1
retType_outer = ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
outer_fun)
      argVar_outer :: Var
argVar_outer = [Var] -> Var
forall a. HasCallStack => [a] -> a
head ([Var] -> Var) -> [Var] -> Var
forall a b. (a -> b) -> a -> b
$ FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
outer_fun
      argTypes_inlined :: [Ty1]
argTypes_inlined = ([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
inlined_fun)
      argVar_inlined :: Var
argVar_inlined = [Var] -> Var
forall a. HasCallStack => [a] -> a
head ([Var] -> Var) -> [Var] -> Var
forall a b. (a -> b) -> a -> b
$ FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
inlined_fun
      retTypeInlined :: Ty1
retTypeInlined = ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
inlined_fun)
      traversedType :: Ty1
traversedType = [Ty1] -> Ty1
forall a. HasCallStack => [a] -> a
head [Ty1]
argTypes_inlined
      -- All arguments except the one that's traversed.
      sideArgsTypesInlined :: [Ty1]
sideArgsTypesInlined = [Ty1] -> [Ty1]
forall a. HasCallStack => [a] -> [a]
tail [Ty1]
argTypes_outer
      sidArgsTypesOuter :: [Ty1]
sidArgsTypesOuter = [Ty1] -> [Ty1]
forall a. HasCallStack => [a] -> [a]
tail [Ty1]
argTypes_inlined
      newType :: ([Ty1], Ty1)
newType =
        ( [Ty1
traversedType] [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
++ [Ty1]
sideArgsTypesInlined [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
++ [Ty1]
sidArgsTypesOuter
        , Ty1
retType_outer)
      inlinedFunBody :: Exp1
inlinedFunBody =
        let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
argVar_inlined
            newExp :: Exp1
newExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newTraversedTreeArg
         in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
inlined_fun)

  -- the traversed tree in the outer is replaced with either a call to the inner
  -- or the body of the inner
  let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
argVar_outer
  let replaceWithCall :: Exp1 -> PassM Exp1
replaceWithCall Exp1
exp = do
        Var
newVar <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"innerCall")
        let rhs :: Exp1
rhs =
                (Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE
                   (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
inlined_fun)
                   []
                   ((Var -> Exp1) -> [Var] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
inlined_fun)))
            body :: Exp1
body = Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newVar) Exp1
exp
        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
newVar, [], Ty1
retTypeInlined, Exp1
rhs) Exp1
body
  Exp1
newBody <-
    case (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
outer_fun) of
      CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls -> do
        [(String, [(Var, ())], Exp1)]
ls' <-
          ((String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)]
-> PassM [(String, [(Var, ())], 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) -> [a] -> m [b]
Prelude.mapM
            (\(String
dataCon, [(Var, ())]
vars, Exp1
exp) -> do
               Exp1
newInnerExp <- Exp1 -> PassM Exp1
replaceWithCall (Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
inlinedFunBody Exp1
exp)
               (String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dataCon, [(Var, ())]
vars, Exp1
newInnerExp))
            [(String, [(Var, ())], Exp1)]
ls
        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ (Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
inlinedFunBody Exp1
e1) [(String, [(Var, ())], Exp1)]
ls')
      Exp1
exp -> Exp1 -> PassM Exp1
replaceWithCall (Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
inlinedFunBody Exp1
exp)
  let newArgs :: [Var]
newArgs =
        [Var
newTraversedTreeArg] [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
L.++ [Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
L.tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
inlined_fun) [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
L.++
        [Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
L.tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
outer_fun)
  FunDef1 -> PassM FunDef1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return FunDef1
outer_fun {funArgs :: [Var]
funArgs = [Var]
newArgs, funTy :: ArrowTy (TyOf Exp1)
funTy = ([Ty1], Ty1)
ArrowTy (TyOf Exp1)
newType, funBody :: Exp1
funBody = Exp1
newBody}


-- This function simplify the case expression when the matched expression
-- is it self another case expression.
-- In the same way Wadler do it [nested case rule]
-- We only need to simplify the top level case
simplifyCases :: FunDef1 -> FunDef1
simplifyCases :: FunDef1 -> FunDef1
simplifyCases FunDef1
function = FunDef1
function {funBody :: Exp1
funBody = Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
(Expression (ext loc dec),
 SubstitutableExt (PreExp ext loc dec) (ext loc dec), Eq dec,
 Eq loc, Eq (ext loc dec), Show dec, Show loc, Out dec, Out loc) =>
PreExp ext loc dec -> PreExp ext loc dec
go (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
function)}
  where
    go :: PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
ex =
      case PreExp ext loc dec
ex of
        CaseE e1 :: PreExp ext loc dec
e1@((CaseE PreExp ext loc dec
e2 [(String, [(Var, loc)], PreExp ext loc dec)]
ls2)) [(String, [(Var, loc)], PreExp ext loc dec)]
ls1 -> PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e2 (((String, [(Var, loc)], PreExp ext loc dec)
 -> (String, [(Var, loc)], PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [(String, [(Var, loc)], PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f [(String, [(Var, loc)], PreExp ext loc dec)]
ls2)) --`debug` (show "original input was \n" L.++ (show (l (CaseE e2 (L.map f ls2)))))
          where f :: (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f (String, [(Var, loc)], PreExp ext loc dec)
oldItem = PreExp ext loc dec
-> (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
forall a b c. Upd3 a b c => a -> b -> c
upd3 (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE ((String, [(Var, loc)], PreExp ext loc dec) -> PreExp ext loc dec
forall a b. Sel3 a b => a -> b
sel3 (String, [(Var, loc)], PreExp ext loc dec)
oldItem) [(String, [(Var, loc)], PreExp ext loc dec)]
ls1) (String, [(Var, loc)], PreExp ext loc dec)
oldItem
        CaseE e1 :: PreExp ext loc dec
e1@((DataConE loc
loc String
k [PreExp ext loc dec]
constructorVars)) [(String, [(Var, loc)], PreExp ext loc dec)]
caseList ->
          let newBody :: Maybe (String, [(Var, loc)], PreExp ext loc dec)
newBody = ((String, [(Var, loc)], PreExp ext loc dec) -> Bool)
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> Maybe (String, [(Var, loc)], PreExp ext loc dec)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\(String, [(Var, loc)], PreExp ext loc dec)
item -> (String, [(Var, loc)], PreExp ext loc dec) -> String
forall a b. Sel1 a b => a -> b
sel1 (String, [(Var, loc)], PreExp ext loc dec)
item String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k) [(String, [(Var, loc)], PreExp ext loc dec)]
caseList
           in case Maybe (String, [(Var, loc)], PreExp ext loc dec)
newBody of
                Maybe (String, [(Var, loc)], PreExp ext loc dec)
Nothing -> String -> PreExp ext loc dec
forall a. HasCallStack => String -> a
error String
"unmatched constructor!"
                Just (String
k, [(Var, loc)]
caseVars, PreExp ext loc dec
caseExp) ->
                  PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec -> PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall a b. (a -> b) -> a -> b
$[PreExp ext loc dec]
-> [(Var, loc)] -> PreExp ext loc dec -> PreExp ext loc dec
forall {e :: * -> * -> *} {l} {d} {b}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
[PreExp e l d] -> [(Var, b)] -> PreExp e l d -> PreExp e l d
case_subst [PreExp ext loc dec]
constructorVars [(Var, loc)]
caseVars PreExp ext loc dec
caseExp
                  where case_subst :: [PreExp e l d] -> [(Var, b)] -> PreExp e l d -> PreExp e l d
case_subst (PreExp e l d
x1:[PreExp e l d]
l1) ((Var, b)
x2:[(Var, b)]
l2) PreExp e l d
exp =
                          Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
Var -> PreExp e l d -> PreExp e l d -> PreExp e l d
subst ((Var, b) -> Var
forall a b. (a, b) -> a
fst (Var, b)
x2) PreExp e l d
x1 ([PreExp e l d] -> [(Var, b)] -> PreExp e l d -> PreExp e l d
case_subst [PreExp e l d]
l1 [(Var, b)]
l2 PreExp e l d
exp)
                        case_subst [] [] PreExp e l d
exp = PreExp e l d
exp
        CaseE (IfE PreExp ext loc dec
e1 PreExp ext loc dec
e2 PreExp ext loc dec
e3) [(String, [(Var, loc)], PreExp ext loc dec)]
ls ->
          PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec -> PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall a b. (a -> b) -> a -> b
$ PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE PreExp ext loc dec
e1 (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e2 [(String, [(Var, loc)], PreExp ext loc dec)]
ls) (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e3 [(String, [(Var, loc)], PreExp ext loc dec)]
ls)
        CaseE e1 :: PreExp ext loc dec
e1@((LetE (Var, [loc], dec, PreExp ext loc dec)
bind PreExp ext loc dec
body)) [(String, [(Var, loc)], PreExp ext loc dec)]
ls1 ->
          let body' :: PreExp ext loc dec
body' = PreExp ext loc dec -> PreExp ext loc dec
go (PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
body [(String, [(Var, loc)], PreExp ext loc dec)]
ls1)
           in (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [loc], dec, PreExp ext loc dec)
bind PreExp ext loc dec
body'
        CaseE PreExp ext loc dec
e1 [(String, [(Var, loc)], PreExp ext loc dec)]
ls1 -> PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e1 (((String, [(Var, loc)], PreExp ext loc dec)
 -> (String, [(Var, loc)], PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [(String, [(Var, loc)], PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f [(String, [(Var, loc)], PreExp ext loc dec)]
ls1)
          where f :: (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f (String, [(Var, loc)], PreExp ext loc dec)
item = PreExp ext loc dec
-> (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
forall a b c. Upd3 a b c => a -> b -> c
upd3 (PreExp ext loc dec -> PreExp ext loc dec
go ((String, [(Var, loc)], PreExp ext loc dec) -> PreExp ext loc dec
forall a b. Sel3 a b => a -> b
sel3 (String, [(Var, loc)], PreExp ext loc dec)
item)) (String, [(Var, loc)], PreExp ext loc dec)
item
        LetE (Var
v, [loc]
loc, dec
t, PreExp ext loc dec
rhs) PreExp ext loc dec
bod -> (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [loc]
loc, dec
t, PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
rhs) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
bod)
        AppE Var
v [loc]
loc [PreExp ext loc dec]
expList -> Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [loc]
loc ((PreExp ext loc dec -> PreExp ext loc dec)
-> [PreExp ext loc dec] -> [PreExp ext loc dec]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp ext loc dec -> PreExp ext loc dec
go [PreExp ext loc dec]
expList)
        IfE PreExp ext loc dec
e1 PreExp ext loc dec
e2 PreExp ext loc dec
e3 -> PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e1) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e2) (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e3)
        TimeIt PreExp ext loc dec
e dec
d Bool
b -> PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp ext loc dec -> PreExp ext loc dec
go PreExp ext loc dec
e) dec
d Bool
b
        PreExp ext loc dec
ex -> PreExp ext loc dec
ex


foldFusedCallsF :: (Var, Var, Int, Var) -> FunDef1 -> FunDef1
foldFusedCallsF :: (Var, Var, Int, Var) -> FunDef1 -> FunDef1
foldFusedCallsF (Var, Var, Int, Var)
rule FunDef1
function =
  let funBody' :: Exp1
funBody' =
       case (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
function) of
          CaseE Exp1
x [(String, [(Var, ())], Exp1)]
ls ->
             let ls' :: [(String, [(Var, ())], Exp1)]
ls' = ((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
a, [(Var, ())]
b, Exp1
exp) ->(String
a, [(Var, ())]
b, (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls (Var, Var, Int, Var)
rule Exp1
exp )) [(String, [(Var, ())], Exp1)]
ls in
              Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
x [(String, [(Var, ())], Exp1)]
ls'
  in FunDef1
function {funBody :: Exp1
funBody = Exp1
funBody' }


foldFusedCalls_Entry :: (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls_Entry :: (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls_Entry rule :: (Var, Var, Int, Var)
rule@(Var
outerName, Var
innerName, Int
argPos, Var
newName) Exp1
body =
   case Exp1
body of
          CaseE Exp1
x [(String, [(Var, ())], Exp1)]
ls ->
             let ls' :: [(String, [(Var, ())], Exp1)]
ls' = ((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
a, [(Var, ())]
b, Exp1
exp) ->(String
a, [(Var, ())]
b, (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls (Var, Var, Int, Var)
rule Exp1
exp )) [(String, [(Var, ())], Exp1)]
ls in
              Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
x [(String, [(Var, ())], Exp1)]
ls'
          Exp1
otherwise -> (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls (Var, Var, Int, Var)
rule Exp1
body


inlineConstructorConsumers :: FunDefs1-> Exp1 -> PassM (Exp1)
inlineConstructorConsumers :: FunDefs1 -> Exp1 -> PassM Exp1
inlineConstructorConsumers FunDefs1
fdefs Exp1
exp =
   do
    let defTable :: DefTable
defTable = Exp1 -> DefTable
buildDefTable (Exp1
exp)
    let exp2 :: Exp1
exp2 = Exp1 -> Exp1
removeUnusedDefsExp (DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
exp)
    if(Exp1
exp2 Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp1
exp)
      then Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
exp2
      else
        do
         Exp1
exp2' <- VarEnv -> Exp1 -> PassM Exp1
freshExp1 VarEnv
forall k a. Map k a
M.empty Exp1
exp2
         FunDefs1 -> Exp1 -> PassM Exp1
inlineConstructorConsumers FunDefs1
fdefs  Exp1
exp2'
  where
    go :: DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
ex  =
       case Exp1
ex of
          original :: Exp1
original@(AppE Var
fName [()]
loc [Exp1]
parList) ->
                   case ([Exp1] -> Exp1
forall a. HasCallStack => [a] -> a
head [Exp1]
parList) of
                         VarE (Var Symbol
symInner) ->
                             case (Symbol -> DefTable -> Maybe Exp1
forall {k}. Ord k => k -> Map k DefTableEntry -> Maybe Exp1
getDefiningConstructor Symbol
symInner DefTable
defTable) of
                                Just (DataConE ()
loc String
dataCons [Exp1]
args)->
                                  let calleeBody :: Exp1
calleeBody = FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.!  Var
fName)
                                      calleeArgs :: [Var]
calleeArgs = FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.!  Var
fName)
                                      calleeBody' :: Exp1
calleeBody' = Exp1 -> [Var] -> [Exp1] -> Exp1
forall {e :: * -> * -> *} {l} {d}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
PreExp e l d -> [Var] -> [PreExp e l d] -> PreExp e l d
replaceArgs Exp1
calleeBody [Var]
calleeArgs [Exp1]
parList
                                      calleeBody'' :: Exp1
calleeBody'' =  let oldExp :: Exp1
oldExp = [Exp1] -> Exp1
forall a. HasCallStack => [a] -> a
head [Exp1]
parList
                                                          newExp :: Exp1
newExp =(() -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dataCons [Exp1]
args)
                                                      in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp   Exp1
calleeBody'

                                      calleeBody''' :: Exp1
calleeBody''' = Exp1 -> Exp1
simplifyCases2 Exp1
calleeBody''
                                  in ( Exp1
calleeBody''') --`debug1` ( "here we are" L.++show (DataConE loc dataCons args ))
                                Maybe Exp1
Nothing -> Exp1
original --`debug1` ( "norm exit1" L.++show (AppE fName loc parList))
                         Exp1
_ -> Exp1
original --`debug1` ( "norm exit2" L.++show (AppE fName loc parList))
          LetE (Var
v, [()]
loc, Ty1
t, Exp1
lhs) Exp1
bod ->
              let normal :: Exp1
normal = (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
loc, Ty1
t, Exp1
lhs) (DefTable -> Exp1 -> Exp1
go  DefTable
defTable Exp1
bod) in
               case Exp1
lhs of
                  original :: Exp1
original@(AppE Var
fName [()]
loc [Exp1]
parList) ->
                    case ([Exp1] -> Exp1
forall a. HasCallStack => [a] -> a
head [Exp1]
parList) of
                          VarE (Var Symbol
symInner) ->
                             case (Symbol -> DefTable -> Maybe Exp1
forall {k}. Ord k => k -> Map k DefTableEntry -> Maybe Exp1
getDefiningConstructor Symbol
symInner DefTable
defTable) of
                                Just (DataConE ()
loc String
dataCons [Exp1]
args)-> do
                                  let calleeBody :: Exp1
calleeBody = FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.!  Var
fName)
                                      calleeArgs :: [Var]
calleeArgs = FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.!  Var
fName)
                                      calleeBody' :: Exp1
calleeBody' = Exp1 -> [Var] -> [Exp1] -> Exp1
forall {e :: * -> * -> *} {l} {d}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
PreExp e l d -> [Var] -> [PreExp e l d] -> PreExp e l d
replaceArgs Exp1
calleeBody [Var]
calleeArgs [Exp1]
parList
                                      calleeBody'' :: Exp1
calleeBody'' =  let oldExp :: Exp1
oldExp = [Exp1] -> Exp1
forall a. HasCallStack => [a] -> a
head [Exp1]
parList
                                                          newExp :: Exp1
newExp =(() -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dataCons [Exp1]
args)
                                                      in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp   Exp1
calleeBody' --`debug1` ( "2here we are" L.++show ((DataConE loc dataCons args)))

                                      calleeBody''' :: Exp1
calleeBody''' =   (Exp1 -> Exp1
simplifyCases2 Exp1
calleeBody'')
                                      leafExp :: Exp1
leafExp = Exp1 -> Exp1
getLeafExpr Exp1
calleeBody'''
                                        --       `debug1`("A"L.++ (show calleeBody'''))
                                      newTail :: Exp1
newTail = (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [], Ty1
t, Exp1
leafExp) (DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
bod)
                                       --        `debug1`("A"L.++ (show      leafExp))
                                  DefTable -> Exp1 -> Exp1
go DefTable
defTable  (Exp1 -> Exp1 -> Exp1
replaceLeafWithExp Exp1
calleeBody'''  Exp1
newTail)
                                      --debug1`("A"L.++ (show   newTail))

                                Maybe Exp1
Nothing -> Exp1
normal-- `debug1` ( "2norm exit1" L.++show (AppE fName loc   parList))
                          Exp1
_ -> Exp1
normal-- `debug1` ( "2norm exit2" L.++show (AppE fName loc parList))
                  Exp1
_ ->Exp1
normal
          IfE Exp1
e1 Exp1
e2 Exp1
e3 -> Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
e1) (DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
e2) (DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
e3)
          CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls1 -> Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e1 (((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1)
f [(String, [(Var, ())], Exp1)]
ls1)
            where f :: (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1)
f (String
dataCon, [(Var, ())]
x, Exp1
exp) = (String
dataCon, [(Var, ())]
x, DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
exp)
          TimeIt Exp1
e Ty1
d Bool
b -> Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (DefTable -> Exp1 -> Exp1
go DefTable
defTable Exp1
e) Ty1
d Bool
b
          DataConE ()
loc String
dataCons [Exp1]
ls -> () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dataCons ((Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (DefTable -> Exp1 -> Exp1
go DefTable
defTable) [Exp1]
ls)
          Exp1
_ ->   Exp1
ex

    getDefiningConstructor :: k -> Map k DefTableEntry -> Maybe Exp1
getDefiningConstructor k
x Map k DefTableEntry
defTable =
      case k -> Map k DefTableEntry -> Maybe DefTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
x Map k DefTableEntry
defTable of
        Maybe DefTableEntry
Nothing -> Maybe Exp1
forall a. Maybe a
Nothing-- `debug1` ("not found" L.++ (show x))
        Just DefTableEntry
entry ->
          case DefTableEntry -> Exp1
def DefTableEntry
entry of
            cons :: Exp1
cons@(DataConE{})-> Exp1 -> Maybe Exp1
forall a. a -> Maybe a
Just Exp1
cons
            Exp1
_ -> Maybe Exp1
forall a. Maybe a
Nothing --`debug1` ("defined not as constr" L.++ (show x))

    replaceArgs :: PreExp e l d -> [Var] -> [PreExp e l d] -> PreExp e l d
replaceArgs PreExp e l d
exp (Var
h1:[Var]
tailarg) (PreExp e l d
h2:[PreExp e l d]
tailPar) =
              let oldExp :: PreExp e l d
oldExp = Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
h1
                  newExp :: PreExp e l d
newExp = PreExp e l d
h2
                  exp' :: PreExp e l d
exp'=  PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp e l d
oldExp PreExp e l d
newExp PreExp e l d
exp
              in PreExp e l d -> [Var] -> [PreExp e l d] -> PreExp e l d
replaceArgs PreExp e l d
exp' [Var]
tailarg [PreExp e l d]
tailPar
    replaceArgs PreExp e l d
exp [] [] = PreExp e l d
exp
    -- getArgs x defTable =
    --   case M.lookup x defTable of
    --     Nothing -> error "error in foldFusedCalls"
    --     Just entry ->
    --       case def entry of
    --         AppE _ _ args -> args
    --         _ -> error ("ops" L.++ show (def entry))

foldFusedCalls :: (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls :: (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls rule :: (Var, Var, Int, Var)
rule@(Var
outerName, Var
innerName, Int
argPos, Var
newName) Exp1
body =
  let defTable :: DefTable
defTable = Exp1 -> DefTable
buildDefTable (Exp1
body)
      go :: Exp1 -> Exp1
go Exp1
ex =
        case Exp1
ex of
          AppE Var
fName [()]
loc [Exp1]
argList ->
            let notFolded :: Exp1
notFolded = Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fName [()]
loc [Exp1]
argList
             in if Var
fName Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
outerName
                  then case ([Exp1] -> Exp1
forall a. HasCallStack => [a] -> a
head [Exp1]
argList) of
                         VarE (Var Symbol
symInner) ->
                           if Var
innerName Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol -> DefTable -> Var
forall {k}. Ord k => k -> Map k DefTableEntry -> Var
getDefiningFunction Symbol
symInner DefTable
defTable
                             then let innerArgs :: [Exp1]
innerArgs = Symbol -> DefTable -> [Exp1]
forall {k}. Ord k => k -> Map k DefTableEntry -> [Exp1]
getArgs Symbol
symInner DefTable
defTable
                                      outerArgs :: [Exp1]
outerArgs = [Exp1]
argList
                                      newCallArgs :: [Exp1]
newCallArgs =
                                        ([Exp1]
innerArgs [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++ [Exp1] -> [Exp1]
forall a. HasCallStack => [a] -> [a]
tail [Exp1]
argList)
                                   in Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
newName [()]
loc [Exp1]
newCallArgs
                             else Exp1
notFolded
                         Exp1
_ -> Exp1
notFolded
                  else Exp1
notFolded
          LetE (Var
v, [()]
loc, Ty1
t, Exp1
lhs) Exp1
bod -> (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [()]
loc, Ty1
t, Exp1 -> Exp1
go Exp1
lhs) (Exp1 -> Exp1
go Exp1
bod)
          IfE Exp1
e1 Exp1
e2 Exp1
e3 -> Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (Exp1 -> Exp1
go Exp1
e1) (Exp1 -> Exp1
go Exp1
e2) (Exp1 -> Exp1
go Exp1
e3)
          CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls1 -> Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e1 (((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1)
f [(String, [(Var, ())], Exp1)]
ls1)
            where f :: (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1)
f (String
dataCon, [(Var, ())]
x, Exp1
exp) = (String
dataCon, [(Var, ())]
x, Exp1 -> Exp1
go Exp1
exp)
          TimeIt Exp1
e Ty1
d Bool
b -> Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (Exp1 -> Exp1
go Exp1
e) Ty1
d Bool
b
          DataConE ()
loc String
dataCons [Exp1]
ls -> () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dataCons ((Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Exp1
go [Exp1]
ls)
          Exp1
_ -> Exp1
ex
   in Exp1 -> Exp1
removeUnusedDefsExp (Exp1 -> Exp1
go Exp1
body)
  where
    getDefiningFunction :: k -> Map k DefTableEntry -> Var
getDefiningFunction k
x Map k DefTableEntry
defTable =
      case k -> Map k DefTableEntry -> Maybe DefTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
x Map k DefTableEntry
defTable of
        Maybe DefTableEntry
Nothing -> String -> Var
toVar String
"dummy"
        Just DefTableEntry
entry ->
          case DefTableEntry -> Exp1
def DefTableEntry
entry of
            AppE Var
v [()]
_ [Exp1]
_ -> Var
v
            Exp1
_ -> String -> Var
toVar String
"dummy"
    getArgs :: k -> Map k DefTableEntry -> [Exp1]
getArgs k
x Map k DefTableEntry
defTable =
      case k -> Map k DefTableEntry -> Maybe DefTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
x Map k DefTableEntry
defTable of
        Maybe DefTableEntry
Nothing -> String -> [Exp1]
forall a. HasCallStack => String -> a
error String
"error in foldFusedCalls"
        Just DefTableEntry
entry ->
          case DefTableEntry -> Exp1
def DefTableEntry
entry of
            AppE Var
_ [()]
_ [Exp1]
args -> [Exp1]
args
            Exp1
_ -> String -> [Exp1]
forall a. HasCallStack => String -> a
error (String
"ops" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Exp1 -> String
forall a. Show a => a -> String
show (DefTableEntry -> Exp1
def DefTableEntry
entry))

-- outputPositions specify for each call i at what index is the corresponding
-- output in the returned tuple
foldTupledFunctions ::   Exp1 -> FunDef1 -> [Exp1] ->
 V.Vector Int->   M.Map (Int, Int) (Int, Int)  -> PassM (Exp1)
foldTupledFunctions :: Exp1
-> FunDef1
-> [Exp1]
-> Vector Int
-> Map (Int, Int) (Int, Int)
-> PassM Exp1
foldTupledFunctions Exp1
bodyM FunDef1
newFun [Exp1]
oldCalls  Vector Int
outputPositions Map (Int, Int) (Int, Int)
syncedArgs  =
  do
     Var
newVar <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"tupled_output")
     Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
bodyM Var
newVar Bool
True
  where
    go :: Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
ex Var
newVar Bool
first =
      case Exp1
ex of
        LetE (Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs) Exp1
body ->
            case Exp1 -> [Exp1] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex (Exp1
rhs) [Exp1]
oldCalls of
              Maybe Int
Nothing ->
                do
                  Exp1
rhs' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
rhs Var
newVar Bool
first
                  (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs') (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
body Var
newVar Bool
first
              Just Int
i ->
                  if Bool
first -- not valid af
                    then
                      do
                        Exp1
body' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
body Var
newVar Bool
False
                        let args :: [Exp1]
args = ([Exp1] -> Int -> Exp1 -> [Exp1])
-> [Exp1] -> Vector Exp1 -> [Exp1]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl [Exp1] -> Int -> Exp1 -> [Exp1]
f []  ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
oldCalls)
                             where
                              f :: [Exp1] -> Int -> Exp1 -> [Exp1]
f [Exp1]
ls1 Int
fIdx Exp1
exp = [Exp1]
ls1 [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++ (Int -> Exp1 -> [Exp1]
extractArgs Int
fIdx) Exp1
exp

                              extractArgs :: Int -> Exp1 -> [Exp1]
extractArgs Int
fIdx (AppE Var
_ [()]
_  (Exp1
h:[Exp1]
tail)) =
                                 Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList ((Int -> Exp1 -> Bool) -> Vector Exp1 -> Vector Exp1
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter -- argIdx+1 because head is dropped (idx 0)
                                  (\Int
argIdx Exp1
arg -> Bool -> Bool
not ( (Int, Int) -> Map (Int, Int) (Int, Int) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Int
fIdx, Int
argIdxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Map (Int, Int) (Int, Int)
syncedArgs))
                                     ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
tail))

                        let args' :: [Exp1]
args' = Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> PreExp ext loc dec
getFirstArg Exp1
rhsExp1 -> [Exp1] -> [Exp1]
forall a. a -> [a] -> [a]
:[Exp1]
args
                             where
                              getFirstArg :: PreExp ext loc dec -> PreExp ext loc dec
getFirstArg ((AppE Var
_ [loc]
_ (PreExp ext loc dec
h:[PreExp ext loc dec]
_)))= PreExp ext loc dec
h --`debug` ("oldCalls" L.++ (show oldCalls) L.++
                                 --(render( pprint bodyM)))

                        let rhs' :: Exp1
rhs' =  Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
newFun) [] [Exp1]
args'
                            --   `debug` ("new call" L.++ (show (AppE (funName newFun) [] args')))
                        let bindType :: Ty1
bindType = ArrowTy Ty1 -> Ty1
forall ty. FunctionTy ty => ArrowTy ty -> ty
outTy (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
newFun)
                        let rhs'' :: Exp1
rhs'' =  case Ty1
t of
                              ProdTy [Ty1]
ls -> ( [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE (
                                Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList ( (Int -> Ty1 -> Exp1) -> Vector Ty1 -> Vector Exp1
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
index Ty1
_ ->
                                  let idx :: Int
idx =(Vector Int
outputPositions Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i) Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
index
                                  in  Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
idx (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newVar) )
                                      ([Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList [Ty1]
ls)  ))  )
                              Ty1
otherwise ->
                                  let idx :: Int
idx = Vector Int
outputPositions Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i

                                  in Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
idx (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newVar)-- not complete buggy (i +eps)
                        let body'' :: Exp1
body'' =    (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs'') Exp1
body'
                            body3 :: Exp1
body3  =  (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
newVar, [], Ty1
bindType, Exp1
rhs') Exp1
body''
                            body4 :: Exp1
body4 =   [Exp1] -> Exp1 -> Exp1
collectArgsConstruction [Exp1]
args Exp1
body3
                        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
body4

                    else
                      do
                        Exp1
body' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
body Var
newVar Bool
first--`debug` ("\nhere\n")
                        let rhs' :: Exp1
rhs' =  case Ty1
t of
                              ProdTy [Ty1]
ls ->  ( [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE (
                                Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList ( (Int -> Ty1 -> Exp1) -> Vector Ty1 -> Vector Exp1
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
index Ty1
_ ->
                                  let idx :: Int
idx =  (Vector Int
outputPositions Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i )Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
index

                                  in  Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
idx (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newVar) )
                                      ([Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList [Ty1]
ls)  )))

                              Ty1
_ ->
                                  let idx :: Int
idx =  Vector Int
outputPositions Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
V.! Int
i

                                  in  Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
idx (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
newVar) -- not complete buggy (i +eps)
                        Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return((Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs') Exp1
body')

        AppE Var
name [()]
loc [Exp1]
argList         ->
           do
             [Exp1]
argList' <- (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [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) -> [a] -> m [b]
Prelude.mapM  (\Exp1
x -> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
x Var
newVar Bool
first) [Exp1]
argList
             Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$  Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
name [()]
loc [Exp1]
argList'
        PrimAppE Prim Ty1
x [Exp1]
ls            ->
            Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty1
x ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [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) -> [a] -> m [b]
Prelude.mapM (\Exp1
x -> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
x Var
newVar Bool
first) [Exp1]
ls

        LetE (Var
v,[()]
loc,Ty1
t,Exp1
rhs) Exp1
bod   -> do
            Exp1
body' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
bod Var
newVar Bool
first
            Exp1
rhs' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
rhs Var
newVar Bool
first
            Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[()]
loc,Ty1
t, Exp1
rhs') Exp1
body'
        IfE Exp1
e1 Exp1
e2 Exp1
e3             -> do
          Exp1
e1' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
e1 Var
newVar Bool
first
          Exp1
e2' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
e2 Var
newVar Bool
first
          Exp1 -> Exp1 -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE Exp1
e1' Exp1
e2' (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
e3 Var
newVar Bool
first

        MkProdE [Exp1]
ls               ->
          [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [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) -> [a] -> m [b]
Prelude.mapM (\Exp1
x -> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
x Var
newVar Bool
first)   [Exp1]
ls
        ProjE Int
index Exp1
exp          ->
          Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
index (Exp1 -> Exp1) -> PassM Exp1 -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
exp Var
newVar Bool
first
        CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls1 ->  do
        --  e1' <- go e1  newVar first
          Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e1 ([(String, [(Var, ())], Exp1)] -> Exp1)
-> PassM [(String, [(Var, ())], Exp1)] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)]
-> PassM [(String, [(Var, ())], 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) -> [a] -> m [b]
Prelude.mapM (\(String
dataCon,[(Var, ())]
x,Exp1
exp)->
            do
              Exp1
exp' <- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
exp Var
newVar Bool
True
              (String, [(Var, ())], Exp1) -> PassM (String, [(Var, ())], Exp1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
dataCon, [(Var, ())]
x, Exp1
exp')
              ) [(String, [(Var, ())], Exp1)]
ls1

        DataConE ()
loc String
datacons [Exp1]
ls ->
          () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
datacons ([Exp1] -> Exp1) -> PassM [Exp1] -> PassM Exp1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp1 -> PassM Exp1) -> [Exp1] -> PassM [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) -> [a] -> m [b]
Prelude.mapM (\Exp1
x -> Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
x Var
newVar Bool
first) [Exp1]
ls
        TimeIt Exp1
e Ty1
d Bool
b             -> do
          Exp1
e'<- Exp1 -> Var -> Bool -> PassM Exp1
go Exp1
e Var
newVar Bool
first
          Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1 -> PassM Exp1) -> Exp1 -> PassM Exp1
forall a b. (a -> b) -> a -> b
$ Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt Exp1
e'  Ty1
d Bool
b
        Exp1
_                ->
          Exp1 -> PassM Exp1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp1
ex

    defTable :: DefTable
defTable = Exp1 -> DefTable
buildDefTable (Exp1
bodyM)
    collectRec :: Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp Exp1
exp  =
      case Exp1
exp of
        VarE v :: Var
v@(Var Symbol
symbol) ->
              case Symbol -> DefTable -> Maybe DefTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Symbol
symbol DefTable
defTable of
                Maybe DefTableEntry
Nothing ->  Exp1
leafExp
                Just (DefTableEntry Exp1
definingExp [FunctionUses]
_ Int
_ Ty1
t)->
                  Exp1 -> Exp1 -> Exp1
collectRec ( (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v ,[], Ty1
t, Exp1
definingExp) Exp1
leafExp) Exp1
definingExp
        AppE Var
fName [()]
_ [Exp1]
args -> (Exp1 -> Exp1 -> Exp1) -> Exp1 -> [Exp1] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp [Exp1]
args
        MkProdE [Exp1]
expList ->  (Exp1 -> Exp1 -> Exp1) -> Exp1 -> [Exp1] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp [Exp1]
expList
        PrimAppE Prim Ty1
_ [Exp1]
args -> (Exp1 -> Exp1 -> Exp1) -> Exp1 -> [Exp1] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp [Exp1]
args
        IfE Exp1
cond Exp1
thenBody Exp1
elseBody      ->
           (Exp1 -> Exp1 -> Exp1) -> Exp1 -> [Exp1] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp  [Exp1
cond,  Exp1
thenBody, Exp1
elseBody ]
        DataConE ()
_ String
_ [Exp1]
expList -> (Exp1 -> Exp1 -> Exp1) -> Exp1 -> [Exp1] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp [Exp1]
expList
        ProjE Int
index Exp1
exp -> Exp1 -> Exp1 -> Exp1
collectRec Exp1
leafExp Exp1
exp
        LitE Int
_ -> Exp1
leafExp
        -- LetE (Var s,loc,t,rhs) bod ->
        --    L.foldl collectRec leafExp  [rhs,  bod]
        Exp1
x       -> String -> Exp1
forall a. HasCallStack => String -> a
error ( String
"please handle me explicitly" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
x))

    collectArgsConstruction :: [Exp1] -> Exp1 -> Exp1
collectArgsConstruction [Exp1]
args  Exp1
exp =  (Exp1 -> Exp1 -> Exp1) -> Exp1 -> [Exp1] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Exp1 -> Exp1 -> Exp1
collectRec Exp1
exp [Exp1]
args
removeUnusedDefs :: FunDef1 -> FunDef1
removeUnusedDefs :: FunDef1 -> FunDef1
removeUnusedDefs FunDef1
f = FunDef1
f{funBody :: Exp1
funBody = Exp1 -> Exp1
removeUnusedDefsExp (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
f)}

removeUnusedDefsExp :: Exp1 ->  Exp1
removeUnusedDefsExp :: Exp1 -> Exp1
removeUnusedDefsExp Exp1
exp =
  let defTable :: DefTable
defTable = Exp1 -> DefTable
buildDefTable (Exp1
exp)
  in Exp1 -> DefTable -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go Exp1
exp DefTable
defTable
    where
      go :: PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go  PreExp ext loc dec
ex DefTable
dTable = case PreExp ext loc dec
ex of
        LetE (Var Symbol
s,[loc]
loc,dec
t,PreExp ext loc dec
rhs) PreExp ext loc dec
bod   ->
         case Symbol -> DefTable -> Maybe DefTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Symbol
s DefTable
dTable of
            Maybe DefTableEntry
Nothing ->  (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
s,[loc]
loc,dec
t, PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
rhs DefTable
dTable) (PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
bod DefTable
dTable)
            Just ( DefTableEntry Exp1
_ [FunctionUses]
_ Int
0 Ty1
t) -> PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
bod DefTable
dTable
            Just DefTableEntry
_  ->  (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
s,[loc]
loc,dec
t, PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
rhs DefTable
dTable) (PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
bod DefTable
dTable)
        IfE PreExp ext loc dec
e1 PreExp ext loc dec
e2 PreExp ext loc dec
e3             ->
          PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
IfE (PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
e1 DefTable
dTable) ( PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
e2 DefTable
dTable) ( PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
e3 DefTable
dTable)
        CaseE PreExp ext loc dec
e1 [(String, [(Var, loc)], PreExp ext loc dec)]
ls1             ->   PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc dec
e1 (((String, [(Var, loc)], PreExp ext loc dec)
 -> (String, [(Var, loc)], PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [(String, [(Var, loc)], PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f [(String, [(Var, loc)], PreExp ext loc dec)]
ls1)
          where
            f :: (String, [(Var, loc)], PreExp ext loc dec)
-> (String, [(Var, loc)], PreExp ext loc dec)
f (String
dataCon,[(Var, loc)]
x,PreExp ext loc dec
exp) = (String
dataCon, [(Var, loc)]
x, PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
exp DefTable
dTable)
        AppE Var
v [loc]
loc [PreExp ext loc dec]
argList       ->
          Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [loc]
loc ((PreExp ext loc dec -> PreExp ext loc dec)
-> [PreExp ext loc dec] -> [PreExp ext loc dec]
forall a b. (a -> b) -> [a] -> [b]
L.map (PreExp ext loc dec -> DefTable -> PreExp ext loc dec
`go` DefTable
dTable) [PreExp ext loc dec]
argList )
        TimeIt PreExp ext loc dec
exp dec
a Bool
b           ->   PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (PreExp ext loc dec -> DefTable -> PreExp ext loc dec
go PreExp ext loc dec
exp DefTable
dTable) dec
a Bool
b
        PreExp ext loc dec
_ ->  PreExp ext loc dec
ex

tupleListOfFunctions :: DDefs Ty1 -> [FunDef1] -> Var ->
   M.Map (Int, Int) (Int, Int) -> PassM FunDef1
tupleListOfFunctions :: DDefs Ty1
-> [FunDef1] -> Var -> Map (Int, Int) (Int, Int) -> PassM FunDef1
tupleListOfFunctions  DDefs Ty1
ddefs [FunDef1]
funcList Var
newName Map (Int, Int) (Int, Int)
syncedArgs = do
  [FunDef1]
funcBodies <- (FunDef1 -> PassM FunDef1) -> [FunDef1] -> PassM [FunDef1]
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]
Prelude.mapM FunDef1 -> PassM FunDef1
freshFunction [FunDef1]
funcList
  let funcBodiesV :: Vector FunDef1
funcBodiesV = [FunDef1] -> Vector FunDef1
forall a. [a] -> Vector a
V.fromList [FunDef1]
funcBodies
      retTypes :: Vector Ty1
retTypes    = (FunDef1 -> Ty1) -> Vector FunDef1 -> Vector Ty1
forall a b. (a -> b) -> Vector a -> Vector b
V.map (([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (([Ty1], Ty1) -> Ty1)
-> (FunDef1 -> ([Ty1], Ty1)) -> FunDef1 -> Ty1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunDef1 -> ([Ty1], Ty1)
FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy) Vector FunDef1
funcBodiesV
      newRetType :: Ty1
newRetType  = [Ty1] -> Ty1
forall loc. [UrTy loc] -> UrTy loc
ProdTy (([Ty1] -> Ty1 -> [Ty1]) -> [Ty1] -> Vector Ty1 -> [Ty1]
forall a b. (a -> b -> a) -> a -> Vector b -> a
V.foldl
        (\[Ty1]
ls Ty1
ty ->
          case Ty1
ty of
            ProdTy [Ty1]
ls2 -> [Ty1]
ls [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++ [Ty1]
ls2
            Ty1
otherwise -> [Ty1]
ls [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++ [Ty1
ty]
         ) [] Vector Ty1
retTypes )

      -- we can change this now
      newFuncInputType :: [Ty1]
newFuncInputType = ([Ty1] -> Int -> FunDef1 -> [Ty1])
-> [Ty1] -> Vector FunDef1 -> [Ty1]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl [Ty1] -> Int -> FunDef1 -> [Ty1]
f [] Vector FunDef1
funcBodiesV
        where
          f :: [Ty1] -> Int -> FunDef1 -> [Ty1]
f [Ty1]
ls Int
fIdx FunDef1
fdef =
            case ([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
fdef) of
              (Ty1
h:[Ty1]
tail)->
                let concreteArgs :: [Ty1]
concreteArgs = ([Ty1] -> Int -> Ty1 -> [Ty1]) -> [Ty1] -> Vector Ty1 -> [Ty1]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl [Ty1] -> Int -> Ty1 -> [Ty1]
f [] ([Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList [Ty1]
tail)
                     where
                      f :: [Ty1] -> Int -> Ty1 -> [Ty1]
f [Ty1]
res Int
argIdx Ty1
arg =
                        -- add one to argIdx becasue head is deleted
                        if (Int, Int) -> Map (Int, Int) (Int, Int) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Int
fIdx, Int
argIdxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 ) Map (Int, Int) (Int, Int)
syncedArgs
                          then [Ty1]
res
                          else [Ty1]
res [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++ [Ty1
arg]

                in if Int
fIdx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                    then
                      [Ty1]
ls [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++ [Ty1
h] [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++ [Ty1]
concreteArgs
                    else
                      [Ty1]
ls [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++ [Ty1]
concreteArgs

  let traversedType :: Ty1
traversedType = [Ty1] -> Ty1
forall a. HasCallStack => [a] -> a
L.head [Ty1]
newFuncInputType

  Var
traversedTreeArg <- Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym (String -> Var
toVar String
"input")
  let newArgs :: [Var]
newArgs = Var
traversedTreeArgVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:
        ([Var] -> Int -> FunDef1 -> [Var])
-> [Var] -> Vector FunDef1 -> [Var]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
         (\[Var]
ls Int
fIdx FunDef1
f ->
            [Var]
ls [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
L.++
                (Vector Var -> [Var]
forall a. Vector a -> [a]
V.toList
                   ((Int -> Var -> Bool) -> Vector Var -> Vector Var
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter
                     (\Int
argIdx Var
_-> Bool -> Bool
not ((Int, Int) -> Map (Int, Int) (Int, Int) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Int
fIdx, Int
argIdxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Map (Int, Int) (Int, Int)
syncedArgs))
                     ([Var] -> Vector Var
forall a. [a] -> Vector a
V.fromList ([Var] -> [Var]
forall a. HasCallStack => [a] -> [a]
L.tail (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
f))))
                )
          ) [] Vector FunDef1
funcBodiesV

  let argsLocsToVarMap :: Map (Int, Int) Var
argsLocsToVarMap =
        (Map (Int, Int) Var -> Int -> FunDef1 -> Map (Int, Int) Var)
-> Map (Int, Int) Var -> Vector FunDef1 -> Map (Int, Int) Var
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
         (\Map (Int, Int) Var
mp Int
fIdx FunDef1
func ->
            (Map (Int, Int) Var -> Int -> Var -> Map (Int, Int) Var)
-> Map (Int, Int) Var -> Vector Var -> Map (Int, Int) Var
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
              (\Map (Int, Int) Var
mpinner Int
argIdx Var
argVar-> (Int, Int) -> Var -> Map (Int, Int) Var -> Map (Int, Int) Var
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
fIdx, Int
argIdx) Var
argVar Map (Int, Int) Var
mpinner)
               Map (Int, Int) Var
mp ([Var] -> Vector Var
forall a. [a] -> Vector a
V.fromList (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
func))
          ) Map (Int, Int) Var
forall k a. Map k a
M.empty Vector FunDef1
funcBodiesV

  -- replace the traversed tree variable with the new common one
  let functionsBodies' :: [Exp1]
functionsBodies' =  Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList ((Int -> FunDef1 -> Exp1) -> Vector FunDef1 -> Vector Exp1
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap Int -> FunDef1 -> Exp1
getBody Vector FunDef1
funcBodiesV)
       where
          getBody :: Int -> FunDef1 -> Exp1
getBody Int
i FunDef1
func =
            let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE ([Var] -> Var
forall a. HasCallStack => [a] -> a
L.head (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
func ))
                newExp :: Exp1
newExp = (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
traversedTreeArg)
            in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE  Exp1
oldExp Exp1
newExp (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
func)

  -- output of this is a map from dataCons -> [exp'] which are the portions
  -- from each functions that map to the constructor
  let step2 :: Map String [Exp1]
step2 = (Map String [Exp1] -> Exp1 -> Map String [Exp1])
-> Map String [Exp1] -> [Exp1] -> Map String [Exp1]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Map String [Exp1] -> Exp1 -> Map String [Exp1]
forall {e :: * -> * -> *} {l} {d}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
Map String [PreExp e l d]
-> PreExp e l d -> Map String [PreExp e l d]
mapAndSplit Map String [Exp1]
forall k a. Map k a
M.empty [Exp1]
functionsBodies'
        where
          mapAndSplit :: Map String [PreExp e l d]
-> PreExp e l d -> Map String [PreExp e l d]
mapAndSplit Map String [PreExp e l d]
mp (CaseE PreExp e l d
e [(String, [(Var, l)], PreExp e l d)]
lsCase)  = (Map String [PreExp e l d]
 -> (String, [(Var, l)], PreExp e l d) -> Map String [PreExp e l d])
-> Map String [PreExp e l d]
-> [(String, [(Var, l)], PreExp e l d)]
-> Map String [PreExp e l d]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Map String [PreExp e l d]
-> (String, [(Var, l)], PreExp e l d) -> Map String [PreExp e l d]
forall {e :: * -> * -> *} {l} {d} {b}.
(Expression (e l d), SubstitutableExt (PreExp e l d) (e l d), Eq d,
 Eq l, Eq (e l d), Show d, Show l, Out d, Out l) =>
Map String [PreExp e l d]
-> (String, [(Var, b)], PreExp e l d) -> Map String [PreExp e l d]
f Map String [PreExp e l d]
mp [(String, [(Var, l)], PreExp e l d)]
lsCase
            where f :: Map String [PreExp e l d]
-> (String, [(Var, b)], PreExp e l d) -> Map String [PreExp e l d]
f Map String [PreExp e l d]
mp (String
dataCons, [(Var, b)]
vars, PreExp e l d
exp)  =
                    let exp' :: PreExp e l d
exp' = PreExp e l d -> PreExp e l d
subsVars PreExp e l d
exp
                    in case String -> Map String [PreExp e l d] -> Maybe [PreExp e l d]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
dataCons Map String [PreExp e l d]
mp of
                         Maybe [PreExp e l d]
Nothing -> String
-> [PreExp e l d]
-> Map String [PreExp e l d]
-> Map String [PreExp e l d]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
dataCons [PreExp e l d
exp'] Map String [PreExp e l d]
mp
                         Just [PreExp e l d]
x -> String
-> [PreExp e l d]
-> Map String [PreExp e l d]
-> Map String [PreExp e l d]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
dataCons ([PreExp e l d]
x [PreExp e l d] -> [PreExp e l d] -> [PreExp e l d]
forall a. [a] -> [a] -> [a]
L.++ [PreExp e l d
exp']) Map String [PreExp e l d]
mp
                    where
                       subsVars :: PreExp e l d -> PreExp e l d
subsVars PreExp e l d
ex = (Int -> (Var, b) -> PreExp e l d -> PreExp e l d)
-> PreExp e l d -> Vector (Var, b) -> PreExp e l d
forall a b. (Int -> a -> b -> b) -> b -> Vector a -> b
V.ifoldr Int -> (Var, b) -> PreExp e l d -> PreExp e l d
subsVar PreExp e l d
ex ([(Var, b)] -> Vector (Var, b)
forall a. [a] -> Vector a
V.fromList [(Var, b)]
vars)
                       subsVar :: Int -> (Var, b) -> PreExp e l d -> PreExp e l d
subsVar Int
index (Var, b)
v PreExp e l d
ex   =
                          let oldExp :: PreExp e l d
oldExp = Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE ((Var, b) -> Var
forall a b. (a, b) -> a
fst (Var, b)
v)
                              newExp :: PreExp e l d
newExp = (Var -> PreExp e l d
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (String -> Var
toVar ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
L.map Char -> Char
toLower
                                 (String
dataCons String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Int -> String
forall a. Show a => a -> String
show Int
index))))
                          in PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE  PreExp e l d
oldExp PreExp e l d
newExp PreExp e l d
ex


  let traversedTreeDDef :: DDef Ty1
traversedTreeDDef =
        DDefs Ty1 -> String -> DDef Ty1
forall a. Out a => DDefs a -> String -> DDef a
lookupDDef DDefs Ty1
ddefs (case Ty1
traversedType of (PackedTy String
tName ()
_) -> String
tName)

  -- this is the returned tuple (out1_1, out1_2, out2_1 ..etc) those variables
  -- stores the result
  let tailExpr :: Exp1
tailExpr = [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ( ([Exp1] -> Int -> Ty1 -> [Exp1]) -> [Exp1] -> Vector Ty1 -> [Exp1]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
       (\[Exp1]
ls Int
index Ty1
ty  ->
           case Ty1
ty of
             ProdTy [Ty1]
ls2 ->
              let newElements :: [Exp1]
newElements =Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList(
                   (Int -> Ty1 -> Exp1) -> Vector Ty1 -> Vector Exp1
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
subscript Ty1
_ -> Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE  (Int -> Int -> Var
forall {a} {a}. (Show a, Show a) => a -> a -> Var
createOutVar Int
index Int
subscript))
                      ([Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList [Ty1]
ls2))
              in ([Exp1]
ls [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++ [Exp1]
newElements)

             Ty1
_ ->
                let newElement :: Exp1
newElement =  Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE  (Int -> Integer -> Var
forall {a} {a}. (Show a, Show a) => a -> a -> Var
createOutVar Int
index Integer
0 )
                in [Exp1]
ls [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++ [Exp1
newElement]

       ) [] Vector Ty1
retTypes)

  let topLevelExpr :: Exp1
topLevelExpr = Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
traversedTreeArg) []

  let extendedCase :: Exp1
extendedCase = ((String, [(Bool, Ty1)]) -> Exp1 -> Exp1)
-> Exp1 -> [(String, [(Bool, Ty1)])] -> Exp1
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (String, [(Bool, Ty1)]) -> Exp1 -> Exp1
addConstructorBody Exp1
topLevelExpr
        (DDef Ty1 -> [(String, [(Bool, Ty1)])]
forall a. DDef a -> [(String, [(Bool, a)])]
dataCons DDef Ty1
traversedTreeDDef)
        where
          addConstructorBody :: (String, [(Bool, Ty1)]) -> Exp1 -> Exp1
addConstructorBody (String
dataCons, [(Bool, Ty1)]
varls) (CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
caseList) =

            -- a list of the names of the constructor variables
            --  e.g [leaf0, leaf1]  or [inner0, inner1, inner2, inner3]
            let newVarsList :: [(Var, ())]
newVarsList = Vector (Var, ()) -> [(Var, ())]
forall a. Vector a -> [a]
V.toList( (Int -> (Bool, Ty1) -> (Var, ()))
-> Vector (Bool, Ty1) -> Vector (Var, ())
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
index (Bool, Ty1)
_ -> ( String -> Var
toVar ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
L.map
                  Char -> Char
toLower (String
dataCons String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Int -> String
forall a. Show a => a -> String
show Int
index)) ,() ) )([(Bool, Ty1)] -> Vector (Bool, Ty1)
forall a. [a] -> Vector a
V.fromList [(Bool, Ty1)]
varls))

                bodiesOfConst :: Vector Exp1
bodiesOfConst =[Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList ([Exp1] -> [Exp1]
forall a. [a] -> [a]
L.reverse (Map String [Exp1]
step2 Map String [Exp1] -> String -> [Exp1]
forall k a. Ord k => Map k a -> k -> a
M.! String
dataCons))
                combinedBodies :: Exp1
combinedBodies  =  (Exp1 -> Int -> Exp1 -> Exp1) -> Exp1 -> Vector Exp1 -> Exp1
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl Exp1 -> Int -> Exp1 -> Exp1
f Exp1
tailExpr Vector Exp1
bodiesOfConst
                 where
                  f :: Exp1 -> Int -> Exp1 -> Exp1
f Exp1
tailExp Int
index Exp1
exp  =

                    let pos :: Int
pos = Vector FunDef1 -> Int
forall a. Vector a -> Int
V.length Vector FunDef1
funcBodiesV Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
index  Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
                        newVar :: Int -> Var
newVar   = Int -> Int -> Var
forall {a} {a}. (Show a, Show a) => a -> a -> Var
createOutVar Int
pos
                        newVarType :: Ty1
newVarType = ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy  (Vector FunDef1
funcBodiesV Vector FunDef1 -> Int -> FunDef1
forall a. Vector a -> Int -> a
V.!Int
pos))
                    in Exp1 -> (Int -> Var) -> Ty1 -> Exp1 -> Exp1
replaceLeafWithBind Exp1
exp Int -> Var
newVar Ty1
newVarType Exp1
tailExp
            in Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e1 ((String
dataCons, [(Var, ())]
newVarsList, Exp1
combinedBodies)(String, [(Var, ())], Exp1)
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a. a -> [a] -> [a]
:[(String, [(Var, ())], Exp1)]
caseList)
  -- replace uses of eliminated synced Input args
  let finalBody :: Exp1
finalBody =
       (Exp1 -> (Int, Int) -> (Int, Int) -> Exp1)
-> Exp1 -> Map (Int, Int) (Int, Int) -> Exp1
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey
        (\Exp1
exp (Int, Int)
k (Int, Int)
v->
           let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Map (Int, Int) Var
argsLocsToVarMap Map (Int, Int) Var -> (Int, Int) -> Var
forall k a. Ord k => Map k a -> k -> a
M.! (Int, Int)
k)
               newExp :: Exp1
newExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Map (Int, Int) Var
argsLocsToVarMap Map (Int, Int) Var -> (Int, Int) -> Var
forall k a. Ord k => Map k a -> k -> a
M.! (Int, Int)
v)
           in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE  Exp1
oldExp Exp1
newExp Exp1
exp
        ) Exp1
extendedCase Map (Int, Int) (Int, Int)
syncedArgs

  FunDef1 -> PassM FunDef1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> [Var] -> ArrowTy (TyOf Exp1) -> Exp1 -> FunMeta -> FunDef1
forall ex.
Var -> [Var] -> ArrowTy (TyOf ex) -> ex -> FunMeta -> FunDef ex
FunDef Var
newName [Var]
newArgs ([Ty1]
newFuncInputType,Ty1
newRetType) Exp1
finalBody (FunRec -> FunInline -> Bool -> FunMeta
FunMeta FunRec
NotRec FunInline
NoInline Bool
False))
 where
  createOutVar :: a -> a -> Var
createOutVar a
index a
subscript=
          String -> Var
toVar (String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ a -> String
forall a. Show a => a -> String
show a
index String -> String -> String
forall a. [a] -> [a] -> [a]
L.++String
"out" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ a -> String
forall a. Show a => a -> String
show a
subscript)


renameFunction :: FunDef1 -> Var -> FunDef1
renameFunction :: FunDef1 -> Var -> FunDef1
renameFunction FunDef1
function Var
newName =
   FunDef1
function{funName :: Var
funName=Var
newName, funBody :: Exp1
funBody = Exp1 -> Exp1
go (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
function)}
    where
     go :: Exp1 -> Exp1
go Exp1
ex =
      let oldName :: Var
oldName = FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
function in
      case Exp1
ex of
          AppE Var
name [()]
loc [Exp1]
argList          ->
            Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE (if Var
nameVar -> Var -> Bool
forall a. Eq a => a -> a -> Bool
==Var
oldName then Var
newName else Var
name) [()]
loc [Exp1]
argList
          PrimAppE Prim Ty1
x [Exp1]
ls            ->   Prim Ty1 -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Prim dec -> [PreExp ext loc dec] -> PreExp ext loc dec
PrimAppE Prim Ty1
x ((Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Exp1
f [Exp1]
ls)
            where f :: Exp1 -> Exp1
f Exp1
item = Exp1 -> Exp1
go Exp1
item
          LetE (Var
v,[()]
loc,Ty1
t,Exp1
rhs) Exp1
bod   ->   (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v,[()]
loc,Ty1
t, Exp1 -> Exp1
go Exp1
rhs) (Exp1 -> Exp1
go Exp1
bod)
          MkProdE [Exp1]
ls               ->   [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE ((Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Exp1
go [Exp1]
ls)
          ProjE Int
index Exp1
exp          ->   Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
index (Exp1 -> Exp1
go Exp1
exp)
          CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls1             ->   Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE (Exp1 -> Exp1
go Exp1
e1)  (((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1)
f [(String, [(Var, ())], Exp1)]
ls1)
            where f :: (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1)
f (String
dataCon,[(Var, ())]
x,Exp1
exp) = (String
dataCon, [(Var, ())]
x, Exp1 -> Exp1
go Exp1
exp)
          DataConE ()
loc String
dataCons [Exp1]
ls ->
            () -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dataCons ((Exp1 -> Exp1) -> [Exp1] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Exp1
go [Exp1]
ls)
          TimeIt Exp1
e Ty1
d Bool
b             ->   Exp1 -> Ty1 -> Bool -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec -> dec -> Bool -> PreExp ext loc dec
TimeIt (Exp1 -> Exp1
go Exp1
e) Ty1
d Bool
b
          Exp1
_                ->   Exp1
ex



{- We want to search for
the following:
  f1 (x1, v1,v2 ...vn)
  f2 (x1, k1,k2 ...kn)
 such that
body (f1) = case (x1) of {}
body (f2) = case (x1) of {}
and k1..kn do not dependent on the results of f1

the return  format is the following [(x1, [f1, f2])]
-}

-- should be a preorder and not a post order OMG!!!
buildTupleCandidatesTable::   FunDefs1 -> Exp1 -> [Var] -> M.Map Var [Exp1]
buildTupleCandidatesTable :: FunDefs1 -> Exp1 -> [Var] -> Map Var [Exp1]
buildTupleCandidatesTable FunDefs1
fDefs Exp1
exp [Var]
argsVars =
   ([(Var, Exp1)] -> [Exp1])
-> Map Var [(Var, Exp1)] -> Map Var [Exp1]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\[(Var, Exp1)]
ls -> ((Var, Exp1) -> Exp1) -> [(Var, Exp1)] -> [Exp1]
forall a b. (a -> b) -> [a] -> [b]
L.map (Var, Exp1) -> Exp1
forall a b. (a, b) -> b
snd [(Var, Exp1)]
ls) (Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
exp Map Var [(Var, Exp1)]
forall k a. Map k a
M.empty)
 where
  go :: Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
ex Map Var [(Var, Exp1)]
tb = case Exp1
ex of
      AppE{}                   -> Map Var [(Var, Exp1)]
tb
      PrimAppE Prim Ty1
_ [Exp1]
_             -> Map Var [(Var, Exp1)]
tb
      LetE (Var
boundedVar,[()]
_,Ty1
_,Exp1
rhs) Exp1
body    ->
        let tb' :: Map Var [(Var, Exp1)]
tb'=
             case Exp1
rhs of
                callExp :: Exp1
callExp@(AppE Var
fName [()]
_ argList :: [Exp1]
argList@((VarE Var
inputTree):[Exp1]
tail)) ->
                  let otherCalls :: [(Var, Exp1)]
otherCalls = if Var -> Map Var [(Var, Exp1)] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Var
inputTree  Map Var [(Var, Exp1)]
tb
                                    then (Map Var [(Var, Exp1)]
tb  Map Var [(Var, Exp1)] -> Var -> [(Var, Exp1)]
forall k a. Ord k => Map k a -> k -> a
M.! Var
inputTree)
                                    else [] in
                  if (FunDef1 -> Bool
forall {ext :: * -> * -> *} {loc} {dec}.
FunDef (PreExp ext loc dec) -> Bool
isTupleable (FunDefs1
fDefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fName)) Bool -> Bool -> Bool
&&
                        ([Exp1] -> [(Var, Exp1)] -> Bool
haveIndependentArgsNew [Exp1]
tail [(Var, Exp1)]
otherCalls)
                    then
                      let addCall :: Maybe [(Var, Exp1)] -> Maybe [(Var, Exp1)]
addCall Maybe [(Var, Exp1)]
Nothing   = [(Var, Exp1)] -> Maybe [(Var, Exp1)]
forall a. a -> Maybe a
Just [(Var
boundedVar, Exp1
callExp)]
                          addCall (Just [(Var, Exp1)]
ls) = [(Var, Exp1)] -> Maybe [(Var, Exp1)]
forall a. a -> Maybe a
Just ([(Var, Exp1)] -> Maybe [(Var, Exp1)])
-> [(Var, Exp1)] -> Maybe [(Var, Exp1)]
forall a b. (a -> b) -> a -> b
$ [(Var, Exp1)] -> [(Var, Exp1)]
forall a. Eq a => [a] -> [a]
L.nub  ([(Var, Exp1)] -> [(Var, Exp1)]) -> [(Var, Exp1)] -> [(Var, Exp1)]
forall a b. (a -> b) -> a -> b
$(Var
boundedVar, Exp1
callExp)(Var, Exp1) -> [(Var, Exp1)] -> [(Var, Exp1)]
forall a. a -> [a] -> [a]
:[(Var, Exp1)]
ls
                      in (Maybe [(Var, Exp1)] -> Maybe [(Var, Exp1)])
-> Var -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe [(Var, Exp1)] -> Maybe [(Var, Exp1)]
addCall Var
inputTree  Map Var [(Var, Exp1)]
tb
                    else  Map Var [(Var, Exp1)]
tb
                Exp1
_ -> Map Var [(Var, Exp1)]
tb
        in  Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
body Map Var [(Var, Exp1)]
tb'

      IfE Exp1
e1 Exp1
e2 Exp1
e3             -> let t1 :: Map Var [(Var, Exp1)]
t1 = Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
e1 Map Var [(Var, Exp1)]
tb
                                      t2 :: Map Var [(Var, Exp1)]
t2 = Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
e2 Map Var [(Var, Exp1)]
t1
                                  in Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
e3 Map Var [(Var, Exp1)]
t2
      MkProdE [Exp1]
ls               -> Map Var [(Var, Exp1)]
tb
      ProjE Int
index Exp1
exp          -> Map Var [(Var, Exp1)]
tb
      CaseE Exp1
e1 [(String, [(Var, ())], Exp1)]
ls1             -> String -> Map Var [(Var, Exp1)]
forall a. HasCallStack => String -> a
error (String
"not expected in here ")
      DataConE ()
loc String
datacons [Exp1]
ls ->
         (Map Var [(Var, Exp1)] -> Exp1 -> Map Var [(Var, Exp1)])
-> Map Var [(Var, Exp1)] -> [Exp1] -> Map Var [(Var, Exp1)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Map Var [(Var, Exp1)] -> Exp1 -> Map Var [(Var, Exp1)]
f Map Var [(Var, Exp1)]
tb [Exp1]
ls where f :: Map Var [(Var, Exp1)] -> Exp1 -> Map Var [(Var, Exp1)]
f Map Var [(Var, Exp1)]
table Exp1
exp = Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
exp Map Var [(Var, Exp1)]
table
      TimeIt Exp1
exp Ty1
_ Bool
_           -> Exp1 -> Map Var [(Var, Exp1)] -> Map Var [(Var, Exp1)]
go Exp1
exp Map Var [(Var, Exp1)]
tb
      Exp1
_                -> Map Var [(Var, Exp1)]
tb
   where
    defTable :: DefTable
defTable = Exp1 -> DefTable
buildDefTable (Exp1
exp)

    isTupleable :: FunDef (PreExp ext loc dec) -> Bool
isTupleable FunDef (PreExp ext loc dec)
f = case (FunDef (PreExp ext loc dec) -> PreExp ext loc dec
forall ex. FunDef ex -> ex
funBody FunDef (PreExp ext loc dec)
f) of
      ---add a check that there is no nested case (maybe)
        CaseE PreExp ext loc dec
e [(String, [(Var, loc)], PreExp ext loc dec)]
_ -> case PreExp ext loc dec
e of
            VarE Var
v -> Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== [Var] -> Var
forall a. HasCallStack => [a] -> a
L.head (FunDef (PreExp ext loc dec) -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef (PreExp ext loc dec)
f)
            PreExp ext loc dec
_ -> Bool
False
        PreExp ext loc dec
_ -> Bool
False

    isTrivial :: FunDef (PreExp ext loc dec) -> Bool
isTrivial FunDef (PreExp ext loc dec)
f =
      if Bool -> Bool
not (FunDef (PreExp ext loc dec) -> Bool
forall {ext :: * -> * -> *} {loc} {dec}.
FunDef (PreExp ext loc dec) -> Bool
isTupleable FunDef (PreExp ext loc dec)
f )
        then Bool
True
        else
          case (FunDef (PreExp ext loc dec) -> PreExp ext loc dec
forall ex. FunDef ex -> ex
funBody FunDef (PreExp ext loc dec)
f) of
            CaseE PreExp ext loc dec
e [(String, [(Var, loc)], PreExp ext loc dec)]
ls ->
              (Bool -> (String, [(Var, loc)], PreExp ext loc dec) -> Bool)
-> Bool -> [(String, [(Var, loc)], PreExp ext loc dec)] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
res (String
_ ,[(Var, loc)]
_ ,PreExp ext loc dec
exp) -> Bool
res Bool -> Bool -> Bool
&& (PreExp ext loc dec -> Bool
forall {ext :: * -> * -> *} {loc} {dec}. PreExp ext loc dec -> Bool
go PreExp ext loc dec
exp )) Bool
True [(String, [(Var, loc)], PreExp ext loc dec)]
ls
               where
                go :: PreExp ext loc dec -> Bool
go PreExp ext loc dec
exp =
                  case PreExp ext loc dec
exp of
                    LetE (Var
boundedVar,[loc]
_,dec
_,PreExp ext loc dec
rhs) PreExp ext loc dec
body  ->
                      case PreExp ext loc dec
rhs of
                           AppE{} -> Bool
False
                           PreExp ext loc dec
otherwise -> PreExp ext loc dec -> Bool
go PreExp ext loc dec
body
                    AppE{} -> Bool
False
                    PreExp ext loc dec
otherwise -> Bool
True




    -- we want to make sure that args are independent on "other calls"
    haveIndependentArgsNew :: [Exp1] -> [(Var, Exp1)] -> Bool
haveIndependentArgsNew [Exp1]
args [(Var, Exp1)]
otherCalls =
      let varsToAvoid :: Set Var
varsToAvoid = [Var] -> Set Var
forall a. Ord a => [a] -> Set a
S.fromList (((Var, Exp1) -> Var) -> [(Var, Exp1)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
L.map (Var, Exp1) -> Var
forall a b. (a, b) -> a
fst [(Var, Exp1)]
otherCalls)
          dependentVars :: Set Var
dependentVars = [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Exp1 -> Set Var) -> [Exp1] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Set Var
collectDependentVarsExp  [Exp1]
args)
      in Set Var -> Bool
forall a. Set a -> Bool
S.null (Set Var -> Set Var -> Set Var
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set Var
varsToAvoid Set Var
dependentVars)

    collectDependentVarsExp :: Exp1 -> Set Var
collectDependentVarsExp Exp1
exp =
     case Exp1
exp of
       VarE v :: Var
v@(Var Symbol
symbol) ->
            case Symbol -> DefTable -> Maybe DefTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Symbol
symbol DefTable
defTable of
              Maybe DefTableEntry
Nothing -> Set Var
forall a. Set a
S.empty
              Just (DefTableEntry Exp1
definingExp [FunctionUses]
_ Int
_ Ty1
_) ->
                  Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
v  (Exp1 -> Set Var
collectDependentVarsExp Exp1
definingExp)

       AppE Var
fName [()]
_ [Exp1]
args -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Exp1 -> Set Var) -> [Exp1] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Set Var
collectDependentVarsExp [Exp1]
args )
       MkProdE [Exp1]
expList -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Exp1 -> Set Var) -> [Exp1] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Set Var
collectDependentVarsExp [Exp1]
expList)
       PrimAppE Prim Ty1
_ [Exp1]
args->  [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Exp1 -> Set Var) -> [Exp1] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Set Var
collectDependentVarsExp [Exp1]
args )

       IfE Exp1
cond Exp1
thenBody Exp1
elseBody      ->
         [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions
           [Exp1 -> Set Var
collectDependentVarsExp Exp1
cond, Exp1 -> Set Var
collectDependentVarsExp Exp1
thenBody,
              Exp1 -> Set Var
collectDependentVarsExp Exp1
elseBody ]
       DataConE ()
_ String
_ [Exp1]
expList -> [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Exp1 -> Set Var) -> [Exp1] -> [Set Var]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Set Var
collectDependentVarsExp [Exp1]
expList)
       ProjE Int
index Exp1
exp -> Exp1 -> Set Var
collectDependentVarsExp Exp1
exp
       LitE Int
_ -> Set Var
forall a. Set a
S.empty
       LetE (Var Symbol
s,[()]
loc,Ty1
t,Exp1
rhs) Exp1
body ->
         [Set Var] -> Set Var
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Exp1 -> Set Var
collectDependentVarsExp Exp1
rhs,
           Exp1 -> Set Var
collectDependentVarsExp Exp1
body]
       Exp1
x       -> String -> Set Var
forall a. HasCallStack => String -> a
error ( String
"please handle me explicitly" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
x))

cleanExp ::  Exp1 -> Exp1
cleanExp :: Exp1 -> Exp1
cleanExp Exp1
exp = Exp1 -> Exp1
removeCommonExpressions (Exp1 -> Exp1
removeUnusedDefsExp Exp1
exp)


tuple_entry :: DDefs Ty1 -> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1,  FunDefs1)
tuple_entry :: DDefs Ty1
-> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1)
tuple_entry DDefs Ty1
ddefs FunDefs1
fdefs Exp1
oldExp_ [Var]
argsVars Int
depth = do
  case  Exp1
oldExp_ of
    CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls  ->
      do
        [((String, [(Var, ())], Exp1), FunDefs1)]
res <- ((String, [(Var, ())], Exp1)
 -> PassM ((String, [(Var, ())], Exp1), FunDefs1))
-> [(String, [(Var, ())], Exp1)]
-> PassM [((String, [(Var, ())], Exp1), FunDefs1)]
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]
Prelude.mapM
                (\(String
x, [(Var, ())]
y, Exp1
ex) ->
                  do
                    (Exp1
ex', FunDefs1
defs) <- DDefs Ty1
-> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1)
tuple DDefs Ty1
ddefs FunDefs1
fdefs Exp1
ex [Var]
argsVars Int
depth
                    ((String, [(Var, ())], Exp1), FunDefs1)
-> PassM ((String, [(Var, ())], Exp1), FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String
x, [(Var, ())]
y , Exp1
ex'),FunDefs1
defs))
                [(String, [(Var, ())], Exp1)]
ls
        let ls' :: [(String, [(Var, ())], Exp1)]
ls' = (((String, [(Var, ())], Exp1), FunDefs1)
 -> (String, [(Var, ())], Exp1))
-> [((String, [(Var, ())], Exp1), FunDefs1)]
-> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((String, [(Var, ())], Exp1), FunDefs1)
-> (String, [(Var, ())], Exp1)
forall a b. (a, b) -> a
fst [((String, [(Var, ())], Exp1), FunDefs1)]
res
        let fdefs' :: FunDefs1
fdefs' = [FunDefs1] -> FunDefs1
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ((((String, [(Var, ())], Exp1), FunDefs1) -> FunDefs1)
-> [((String, [(Var, ())], Exp1), FunDefs1)] -> [FunDefs1]
forall a b. (a -> b) -> [a] -> [b]
L.map ((String, [(Var, ())], Exp1), FunDefs1) -> FunDefs1
forall a b. (a, b) -> b
snd [((String, [(Var, ())], Exp1), FunDefs1)]
res)
        (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls') , FunDefs1
fdefs')
    Exp1
otherwise -> String -> PassM (Exp1, FunDefs1)
forall a. HasCallStack => String -> a
error( Doc -> String
render (Exp1 -> Doc
forall e. Pretty e => e -> Doc
pprint Exp1
oldExp_ ))


-- argsVars represents the arguments of the function that contains oldExp
tuple :: DDefs Ty1 -> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1,  FunDefs1)
tuple :: DDefs Ty1
-> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1)
tuple DDefs Ty1
ddefs FunDefs1
fdefs Exp1
oldExp_ [Var]
argsVars Int
depth= do
 if Int
depthInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
oldExp_, FunDefs1
fdefs)
 else
  do
--lets pic one at a time only !!
    let oldExp :: Exp1
oldExp = Exp1 -> Exp1
cleanExp Exp1
oldExp_
  -- candidates1 : a list of [(fName, CallExpressions)] functions that traverses
  -- same input
    let candidates1 :: [(Var, [Exp1])]
candidates1 = ((Var, [Exp1]) -> Bool) -> [(Var, [Exp1])] -> [(Var, [Exp1])]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Var, [Exp1]) -> Bool
forall {t :: * -> *} {a} {a}. Foldable t => (a, t a) -> Bool
f (Map Var [Exp1] -> [(Var, [Exp1])]
forall k a. Map k a -> [(k, a)]
M.toList (FunDefs1 -> Exp1 -> [Var] -> Map Var [Exp1]
buildTupleCandidatesTable
           FunDefs1
fdefs  Exp1
oldExp [Var]
argsVars) )
         --    `debug` ("looking for candidates for " L.++ render (pprint oldExp))
         where f :: (a, t a) -> Bool
f (a
_, t a
ls) = t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length t a
lsInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1


  -- candidates2: a list  [(tupleName, calls, syncedArgsLocs)]
  -- syncedArgsLocs = [((1,2),(3,4)),..] this means args 4 in f3 is the same as
  -- arg 2 in f1
    let candidates2 :: [(Var, [Exp1], Map (Int, Int) (Int, Int))]
candidates2 = ((Var, [Exp1]) -> (Var, [Exp1], Map (Int, Int) (Int, Int)))
-> [(Var, [Exp1])] -> [(Var, [Exp1], Map (Int, Int) (Int, Int))]
forall a b. (a -> b) -> [a] -> [b]
L.map  ( \(Var
traversedVar, [Exp1]
ls) ->
            let sortedCalls :: [Exp1]
sortedCalls = (Exp1 -> (Var, Exp1)) -> [Exp1] -> [Exp1]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn Exp1 -> (Var, Exp1)
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> (Var, PreExp ext loc dec)
f [Exp1]
ls
                   where f :: PreExp ext loc dec -> (Var, PreExp ext loc dec)
f exp :: PreExp ext loc dec
exp@(AppE Var
fName [loc]
_ [PreExp ext loc dec]
_) = (Var
fName, PreExp ext loc dec
exp)
                syncArgsLocs :: Map (Int, Int) (Int, Int)
syncArgsLocs = [Exp1] -> Map (Int, Int) (Int, Int)
forall {loc} {dec} {ext :: * -> * -> *}.
(Ord loc, Ord dec, Ord (ext loc dec)) =>
[PreExp ext loc dec] -> Map (Int, Int) (Int, Int)
computeSyncedArgs [Exp1]
sortedCalls --`debug` ("done1")

            in ([Exp1] -> [((Int, Int), (Int, Int))] -> Var
forall {a} {a} {a} {a} {t :: * -> *} {t :: * -> *}
       {ext :: * -> * -> *} {loc} {dec}.
(Show a, Show a, Show a, Show a, Foldable t, Foldable t) =>
t (PreExp ext loc dec) -> t ((a, a), (a, a)) -> Var
constructName [Exp1]
sortedCalls (Map (Int, Int) (Int, Int) -> [((Int, Int), (Int, Int))]
forall k a. Map k a -> [(k, a)]
M.toList Map (Int, Int) (Int, Int)
syncArgsLocs), [Exp1]
sortedCalls,
                 Map (Int, Int) (Int, Int)
syncArgsLocs)--`debug` ("done2")
               --`debug` ("orgArgs:" L.++ (render (pprint sortedCalls)) L.++ "\nargs" L.++ (show syncArgsLocs))
                ) [(Var, [Exp1])]
candidates1
       --  `debug` ("filter candidates for " L.++ render (pprint oldExp))
    --(newExp, fdefs') <-  Control.Monad.foldM go (oldExp, fdefs)  candidates2
    if [(Var, [Exp1], Map (Int, Int) (Int, Int))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [(Var, [Exp1], Map (Int, Int) (Int, Int))]
candidates2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then
        do
           (Exp1
newExp, FunDefs1
fdefs') <- (Exp1, FunDefs1)
-> (Var, [Exp1], Map (Int, Int) (Int, Int))
-> PassM (Exp1, FunDefs1)
go (Exp1
oldExp, FunDefs1
fdefs) ([(Var, [Exp1], Map (Int, Int) (Int, Int))]
-> (Var, [Exp1], Map (Int, Int) (Int, Int))
forall a. HasCallStack => [a] -> a
L.head [(Var, [Exp1], Map (Int, Int) (Int, Int))]
candidates2)
           let newExp' :: Exp1
newExp' = Exp1 -> Exp1
removeUnusedDefsExp (Exp1 -> Exp1
simplifyProjections Exp1
newExp )
           (Exp1
newExp'', FunDefs1
fdefs'') <- DDefs Ty1
-> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1)
tuple DDefs Ty1
ddefs FunDefs1
fdefs'  Exp1
newExp' [Var]
argsVars Int
depth
           (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
newExp'', FunDefs1
fdefs'') PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String -> String
forall a. Show a => a -> String
show String
"done one  candidate")
      else
         (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
oldExp, FunDefs1
fdefs) PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String -> String
forall a. Show a => a -> String
show String
"no candidates")
   where
    go :: (Exp1, FunDefs1)
-> (Var, [Exp1], Map (Int, Int) (Int, Int))
-> PassM (Exp1, FunDefs1)
go (Exp1
exp, FunDefs1
fdefs) (Var
tupledFName, [Exp1]
callExpressions, Map (Int, Int) (Int, Int)
syncArgsLocs) =
      case Var -> FunDefs1 -> Maybe FunDef1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
tupledFName FunDefs1
fdefs of
        Just FunDef1
fdef -> do
            Exp1
exp' <-Exp1
-> FunDef1
-> [Exp1]
-> Vector Int
-> Map (Int, Int) (Int, Int)
-> PassM Exp1
foldTupledFunctions Exp1
exp FunDef1
fdef [Exp1]
callExpressions
                 (FunDefs1 -> [Exp1] -> Vector Int
getOutputStartPositions FunDefs1
fdefs [Exp1]
callExpressions) Map (Int, Int) (Int, Int)
syncArgsLocs

            let exp'' :: Exp1
exp'' =  Exp1 -> Exp1
simplifyProjections Exp1
exp'
            (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
exp', FunDefs1
fdefs) PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String
"fold1" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Doc -> String
render (Exp1 -> Doc
forall e. Pretty e => e -> Doc
pprint Exp1
exp''))

        Maybe FunDef1
Nothing -> do
            let functionsToTuple :: [FunDef1]
functionsToTuple = (Exp1 -> FunDef1) -> [Exp1] -> [FunDef1]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> FunDef1
getCalledFunDef  [Exp1]
callExpressions
                  where
                    getCalledFunDef :: Exp1 -> FunDef1
getCalledFunDef Exp1
callExpr = case Exp1
callExpr of
                        (AppE Var
fName [()]
_ [Exp1]
_) -> case Var -> FunDefs1 -> Maybe FunDef1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
fName FunDefs1
fdefs of
                             Just FunDef1
fdef -> FunDef1
fdef

            FunDef1
tupledFunction_ <-
              DDefs Ty1
-> [FunDef1] -> Var -> Map (Int, Int) (Int, Int) -> PassM FunDef1
tupleListOfFunctions
                 DDefs Ty1
ddefs [FunDef1]
functionsToTuple Var
tupledFName Map (Int, Int) (Int, Int)
syncArgsLocs
                  PassM FunDef1 -> String -> PassM FunDef1
forall {c}. c -> String -> c
`debug` (String
"funcs to tuple" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ ([FunDef1] -> String
forall a. Show a => a -> String
show [FunDef1]
functionsToTuple))
            FunDef1
tupledFunction <- FunDef1 -> PassM FunDef1
freshFunction FunDef1
tupledFunction_

            let tupledFunction' :: FunDef1
tupledFunction' =
                  FunDef1
tupledFunction {funBody :: Exp1
funBody = Exp1 -> Exp1
cleanExp (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
tupledFunction)}
                   FunDef1 -> String -> FunDef1
forall {c}. c -> String -> c
`debug` (String
"tupled f is :" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Doc -> String
render(FunDef1 -> Doc
forall e. Pretty e => e -> Doc
pprint FunDef1
tupledFunction_)))

            let fdefs' :: FunDefs1
fdefs' = Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
tupledFName  FunDef1
tupledFunction'  FunDefs1
fdefs
            let traversedArg :: [Var]
traversedArg =  FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
tupledFunction'

            (Exp1
recTupledBody, FunDefs1
newDefs) <-
               DDefs Ty1
-> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1)
tuple_entry DDefs Ty1
ddefs FunDefs1
fdefs' (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
tupledFunction')  [Var]
traversedArg  (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                 PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String
"\n done tupling :" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Var -> String
forall a. Show a => a -> String
show Var
tupledFName)
                    String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Doc -> String
render (FunDef1 -> Doc
forall e. Pretty e => e -> Doc
pprint  FunDef1
tupledFunction')  )
                   )

            let tupledFunction'' :: FunDef1
tupledFunction'' = FunDef1
tupledFunction'{funBody :: Exp1
funBody=Exp1
recTupledBody}

            let tupledFunction''' :: FunDef1
tupledFunction''' =
                  FunDef1
tupledFunction''{funBody :: Exp1
funBody= Exp1 -> Exp1
removeUnusedDefsExp
                    (Exp1 -> Exp1
simplifyProjections (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
tupledFunction''))}

            let fdefs'' :: FunDefs1
fdefs'' = Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
tupledFName  FunDef1
tupledFunction'''  FunDefs1
newDefs

            Exp1
exp' <-
              Exp1
-> FunDef1
-> [Exp1]
-> Vector Int
-> Map (Int, Int) (Int, Int)
-> PassM Exp1
foldTupledFunctions Exp1
exp  FunDef1
tupledFunction''' [Exp1]
callExpressions
                   (FunDefs1 -> [Exp1] -> Vector Int
getOutputStartPositions FunDefs1
fdefs''
                   [Exp1]
callExpressions ) Map (Int, Int) (Int, Int)
syncArgsLocs
                     PassM Exp1 -> String -> PassM Exp1
forall {c}. c -> String -> c
`debug` (String
"fold2 before folding" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Doc -> String
render (Exp1 -> Doc
forall e. Pretty e => e -> Doc
pprint Exp1
exp))

            let exp'' :: Exp1
exp'' = Exp1 -> Exp1
simplifyProjections Exp1
exp'
            (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
exp', FunDefs1
fdefs'')  PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String
"fold2" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Doc -> String
render (Exp1 -> Doc
forall e. Pretty e => e -> Doc
pprint Exp1
exp'))

    constructName :: t (PreExp ext loc dec) -> t ((a, a), (a, a)) -> Var
constructName t (PreExp ext loc dec)
ls t ((a, a), (a, a))
syncArgsLocs =
      let syncedArgsText :: String
syncedArgsText = (((a, a), (a, a)) -> String -> String)
-> String -> t ((a, a), (a, a)) -> String
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr ((a, a), (a, a)) -> String -> String
forall {a} {a} {a} {a}.
(Show a, Show a, Show a, Show a) =>
((a, a), (a, a)) -> String -> String
f String
"" t ((a, a), (a, a))
syncArgsLocs
           where
            f :: ((a, a), (a, a)) -> String -> String
f ((a
f1, a
id1), (a
f2, a
id2)) String
txt =
              String
txt String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (a -> String
forall a. Show a => a -> String
show a
f1) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (a -> String
forall a. Show a => a -> String
show a
id1) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_from_" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++
              String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++
              a -> String
forall a. Show a => a -> String
show (a
f2) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++
              String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++
              (a -> String
forall a. Show a => a -> String
show a
id2) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++
              String
"_n_"
      in String -> Var
toVar
          (String
"_TUP_" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (String -> PreExp ext loc dec -> String)
-> String -> t (PreExp ext loc dec) -> String
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl String -> PreExp ext loc dec -> String
forall {ext :: * -> * -> *} {loc} {dec}.
String -> PreExp ext loc dec -> String
appendName String
"" t (PreExp ext loc dec)
ls String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
syncedArgsText String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_TUP_")

    appendName :: String -> PreExp ext loc dec -> String
appendName String
str (AppE Var
fName [loc]
_ [PreExp ext loc dec]
_) =
       String
str String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_t_" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Var -> String
fromVar Var
fName

    computeSyncedArgs :: [PreExp ext loc dec] -> Map (Int, Int) (Int, Int)
computeSyncedArgs [PreExp ext loc dec]
callExpressions =
     --list of vectors of args [V1, V2 ...]
      let argsLists :: [Vector (PreExp ext loc dec)]
argsLists = (PreExp ext loc dec -> Vector (PreExp ext loc dec))
-> [PreExp ext loc dec] -> [Vector (PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map PreExp ext loc dec -> Vector (PreExp ext loc dec)
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> Vector (PreExp ext loc dec)
f [PreExp ext loc dec]
callExpressions
            where
              f :: PreExp ext loc dec -> Vector (PreExp ext loc dec)
f (AppE Var
_ [loc]
_ (PreExp ext loc dec
h:[PreExp ext loc dec]
tail)) = [PreExp ext loc dec] -> Vector (PreExp ext loc dec)
forall a. [a] -> Vector a
V.fromList [PreExp ext loc dec]
tail

          -- single list of (func-pos, arg-pos, argExp) all args in one list
          allArgsList :: [(Int, Int, PreExp ext loc dec)]
allArgsList = (Int
 -> Vector (PreExp ext loc dec)
 -> [(Int, Int, PreExp ext loc dec)]
 -> [(Int, Int, PreExp ext loc dec)])
-> [(Int, Int, PreExp ext loc dec)]
-> Vector (Vector (PreExp ext loc dec))
-> [(Int, Int, PreExp ext loc dec)]
forall a b. (Int -> a -> b -> b) -> b -> Vector a -> b
V.ifoldr Int
-> Vector (PreExp ext loc dec)
-> [(Int, Int, PreExp ext loc dec)]
-> [(Int, Int, PreExp ext loc dec)]
forall {a} {c}. a -> Vector c -> [(a, Int, c)] -> [(a, Int, c)]
f [] ([Vector (PreExp ext loc dec)]
-> Vector (Vector (PreExp ext loc dec))
forall a. [a] -> Vector a
V.fromList [Vector (PreExp ext loc dec)]
argsLists)
            where
              f :: a -> Vector c -> [(a, Int, c)] -> [(a, Int, c)]
f a
idxFunc Vector c
argsV [(a, Int, c)]
res =
               [(a, Int, c)]
res [(a, Int, c)] -> [(a, Int, c)] -> [(a, Int, c)]
forall a. [a] -> [a] -> [a]
L.++ Vector (a, Int, c) -> [(a, Int, c)]
forall a. Vector a -> [a]
V.toList
                 ((Int -> c -> (a, Int, c)) -> Vector c -> Vector (a, Int, c)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap (\Int
idxVar c
var -> (a
idxFunc, Int
idxVar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, c
var)) Vector c
argsV)
          redundantPositions :: (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
redundantPositions = ((Int, Int, PreExp ext loc dec)
 -> (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
 -> (Map (PreExp ext loc dec) (Int, Int),
     Map (Int, Int) (Int, Int)))
-> (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
-> [(Int, Int, PreExp ext loc dec)]
-> (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (Int, Int, PreExp ext loc dec)
-> (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
-> (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
forall {k} {a} {b}.
(Ord k, Ord a, Ord b) =>
(a, b, k)
-> (Map k (a, b), Map (a, b) (a, b))
-> (Map k (a, b), Map (a, b) (a, b))
f (Map (PreExp ext loc dec) (Int, Int)
forall k a. Map k a
M.empty, Map (Int, Int) (Int, Int)
forall k a. Map k a
M.empty) [(Int, Int, PreExp ext loc dec)]
allArgsList
            where
             f :: (a, b, k)
-> (Map k (a, b), Map (a, b) (a, b))
-> (Map k (a, b), Map (a, b) (a, b))
f (a
funPos, b
argPos, k
argExp) (Map k (a, b)
firstAppear, Map (a, b) (a, b)
redundant) =
                 if k -> Map k (a, b) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member k
argExp Map k (a, b)
firstAppear
                  then
                  (Map k (a, b)
firstAppear,
                    (a, b) -> (a, b) -> Map (a, b) (a, b) -> Map (a, b) (a, b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (a
funPos, b
argPos) (Map k (a, b)
firstAppear Map k (a, b) -> k -> (a, b)
forall k a. Ord k => Map k a -> k -> a
M.! k
argExp) Map (a, b) (a, b)
redundant)
                  else
                    (k -> (a, b) -> Map k (a, b) -> Map k (a, b)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
argExp (a
funPos, b
argPos) Map k (a, b)
firstAppear ,Map (a, b) (a, b)
redundant)

       in (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
-> Map (Int, Int) (Int, Int)
forall a b. (a, b) -> b
snd (Map (PreExp ext loc dec) (Int, Int), Map (Int, Int) (Int, Int))
redundantPositions

fixCalls :: Exp1 -> FunDef1 -> FunDef1 -> M.Map Int Int  -> M.Map Int Int -> Var->Exp1
fixCalls :: Exp1
-> FunDef1 -> FunDef1 -> Map Int Int -> Map Int Int -> Var -> Exp1
fixCalls Exp1
exp FunDef1
fdefOld FunDef1
fdefNew Map Int Int
redirectMap Map Int Int
outputFromInput Var
newName = Exp1 -> Exp1
go Exp1
exp
    where
      go :: Exp1 -> Exp1
go Exp1
exp = case Exp1
exp of
        CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls ->
          let ls' :: [(String, [(Var, ())], Exp1)]
ls' = ((String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
x, [(Var, ())]
y, Exp1
ex)-> (String
x, [(Var, ())]
y, Exp1 -> Exp1
go Exp1
ex)) [(String, [(Var, ())], Exp1)]
ls
          in  Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls'
        LetE (Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs) Exp1
body->
          case Exp1
rhs of
            AppE Var
v [()]
ls [Exp1]
args ->
              if Var
v Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdefOld
                then
                  let t' :: Ty1
t' = ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
fdefNew) in
                  let rhs' :: Exp1
rhs' = Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
newName [()]
ls [Exp1]
args in
                  let
                    body' :: Exp1
body'=  (Exp1 -> (Int, Int) -> Exp1) -> Exp1 -> [(Int, Int)] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl
                        (\Exp1
ex (Int
i, Int
j )->
                              let oldExp :: Exp1
oldExp = Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Symbol -> Var
Var Symbol
y))
                                  newExp :: Exp1
newExp = [Exp1] -> Int -> Exp1
getExpAtIndex [Exp1]
args Int
j
                              in  Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp Exp1
ex  Exp1 -> String -> Exp1
forall {c}. c -> String -> c
`debug` (String
"replacing1" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
oldExp) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++String
"with" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ ( Exp1 -> String
forall a. Show a => a -> String
show Exp1
newExp)String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Map Int Int -> String
forall a. Show a => a -> String
show Map Int Int
outputFromInput ))
                        ) Exp1
body (Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int Int
outputFromInput)

                    body'' :: Exp1
body'' = (Exp1 -> (Int, Int) -> Exp1) -> Exp1 -> [(Int, Int)] -> Exp1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl
                        (\Exp1
ex (Int
i, Int
j )->
                         if Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
j
                             then Exp1
ex
                           else
                              let oldExp :: Exp1
oldExp = Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
i (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Symbol -> Var
Var Symbol
y))
                                  newExp :: Exp1
newExp = Int -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
Int -> PreExp ext loc dec -> PreExp ext loc dec
ProjE Int
j (Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (Symbol -> Var
Var Symbol
y))
                              in  Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp Exp1
ex Exp1 -> String -> Exp1
forall {c}. c -> String -> c
`debug` (String
"replacing2" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
oldExp) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++String
"with" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ ( Exp1 -> String
forall a. Show a => a -> String
show Exp1
newExp))
                        ) Exp1
body' (Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int Int
redirectMap)-- in

                  in (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
y, [()]
loc, Ty1
t',  Exp1
rhs') (Exp1 -> Exp1
go  Exp1
body'')
                else
                   (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs) (Exp1 -> Exp1
go Exp1
body)
            Exp1
_ ->
               (Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Symbol -> Var
Var Symbol
y, [()]
loc, Ty1
t, Exp1
rhs) (Exp1 -> Exp1
go Exp1
body)
        Exp1
otherwise -> Exp1
otherwise

getExpAtIndex ::  [Exp1] -> Int -> Exp1
getExpAtIndex :: [Exp1] -> Int -> Exp1
getExpAtIndex [Exp1]
ls Int
id = [Exp1]
ls [Exp1] -> Int -> Exp1
forall a. HasCallStack => [a] -> Int -> a
L.!! Int
id

getOutputStartPositions:: FunDefs1 -> [Exp1]  -> V.Vector Int
getOutputStartPositions :: FunDefs1 -> [Exp1] -> Vector Int
getOutputStartPositions FunDefs1
fdefs [Exp1]
callExpressions =
     let functionsArgsLengths :: [Int]
functionsArgsLengths = (Exp1 -> Int) -> [Exp1] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
L.map Exp1 -> Int
getCalledFunDef  [Exp1]
callExpressions in
     let ls :: [Int]
ls = ([Int] -> Int -> [Int]) -> [Int] -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\[Int]
ls Int
i -> [Int]
ls [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
L.++ [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. HasCallStack => [a] -> a
L.last [Int]
ls]  ) [Int
0]
          [Int]
functionsArgsLengths
     in  [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList [Int]
ls
   where
     getCalledFunDef :: Exp1 -> Int
getCalledFunDef Exp1
callExpr = case Exp1
callExpr of
          (AppE Var
fName [()]
_ [Exp1]
_) ->
            case Var -> FunDefs1 -> Maybe FunDef1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
fName FunDefs1
fdefs of
              Just FunDef1
fdef -> case ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
fdef) of
                ProdTy [Ty1]
ls -> [Ty1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Ty1]
ls
                Ty1
_ -> Int
1

-- the last input argument is a set of already fused functions in the form of
-- [(outer, inner, 0, fusedFunName)]
fuse :: DDefs Ty1 -> FunDefs1 -> Var -> Var -> [(Var, Var, Int, Var)]
     -> PassM (Bool, Var,  FunDefs1)
fuse :: DDefs Ty1
-> FunDefs1
-> Var
-> Var
-> [(Var, Var, Int, Var)]
-> PassM (Bool, Var, FunDefs1)
fuse DDefs Ty1
ddefs FunDefs1
fdefs  Var
innerVar  Var
outerVar [(Var, Var, Int, Var)]
prevFusedFuncs = do
    FunDef1
innerFunc <-  FunDef1 -> PassM FunDef1
freshFunction (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
innerVar)
    FunDef1
outerFunc <- FunDef1 -> PassM FunDef1
freshFunction (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
outerVar)

    Config
config <- PassM Config
forall (m :: * -> *). MonadReader Config m => m Config
getGibbonConfig
    Var
newName <- if Config -> Int
verbosity Config
config Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
            then  Var -> PassM Var
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Var
toVar (String
"_FUS_f_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var -> String
fromVar Var
outerVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_f_" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                    Var -> String
fromVar Var
innerVar String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_FUS_"))
            else Var -> PassM Var
forall (m :: * -> *). MonadState Int m => Var -> m Var
gensym Var
"_FUSE_"

    FunDef1
step1 <- FunDef1 -> FunDef1 -> PassM FunDef1
inline2 FunDef1
innerFunc FunDef1
outerFunc
      -- `debug`
      --   ("newName is :" L.++ (show newName)  L.++ "\ninner: " L.++ (render (pprint innerFunc)) L.++ "outer: " L.++ (render (pprint outerFunc)) )

    FunDef1
step2 <- FunDef1 -> PassM FunDef1
freshFunction (FunDef1 -> FunDef1
simplifyCases FunDef1
step1 ){funName :: Var
funName = Var
newName}
                -- `debug` ("newName is :" L.++ (show newName)   L.++ render (pprint step1))
    Exp1
newBody <-  FunDefs1 -> Exp1 -> PassM Exp1
inlineConstructorConsumers  FunDefs1
fdefs (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
step2 )
                    --  `debug` ("newName is :" L.++ (show newName)   L.++ render (pprint step2))
    let step2' :: FunDef1
step2' = FunDef1
step2{ funBody :: Exp1
funBody = Exp1
newBody }
                        --  `debug` ("newName is :" L.++ (show newName)   L.++ render (pprint   newBody))
    let step3 :: FunDef1
step3 = (Var, Var, Int, Var) -> FunDef1 -> FunDef1
foldFusedCallsF (Var
outerVar, Var
innerVar, -Int
1, Var
newName)    FunDef1
step2'
      --  `debug` ("newName is :" L.++ (show newName)   L.++ render (pprint   step2'))
    let step4 :: FunDef1
step4 = (FunDef1 -> (Var, Var, Int, Var) -> FunDef1)
-> FunDef1 -> [(Var, Var, Int, Var)] -> FunDef1
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (((Var, Var, Int, Var) -> FunDef1 -> FunDef1)
-> FunDef1 -> (Var, Var, Int, Var) -> FunDef1
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Var, Var, Int, Var) -> FunDef1 -> FunDef1
foldFusedCallsF ) FunDef1
step3 [(Var, Var, Int, Var)]
prevFusedFuncs
        -- `debug`   ("newName is :" L.++ (show newName)   L.++ render (pprint step3))
    let step5 :: FunDef1
step5 = FunDef1
step4 {funBody :: Exp1
funBody = Exp1 -> Exp1
removeUnusedDefsExp  (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
step4)}
                FunDef1 -> String -> FunDef1
forall {c}. c -> String -> c
`debug` (String
"newName is :" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Var -> String
forall a. Show a => a -> String
show Var
newName)   String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Doc -> String
render (FunDef1 -> Doc
forall e. Pretty e => e -> Doc
pprint FunDef1
step4))
    if( Var -> FunDefs1 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Var
newName FunDefs1
fdefs)
       then (Bool, Var, FunDefs1) -> PassM (Bool, Var, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Bool
True, Var
newName, FunDefs1
fdefs)-- `debug1` ("WE ARE FASTER")
       else (Bool, Var, FunDefs1) -> PassM (Bool, Var, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Var
newName, Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newName FunDef1
step5 FunDefs1
fdefs)

violateRestrictions :: FunDefs1 -> Var -> Var ->Int -> Bool
violateRestrictions :: FunDefs1 -> Var -> Var -> Int -> Bool
violateRestrictions FunDefs1
fdefs Var
inner Var
outer Int
depth=
  let (Int
n, Int
m) =  String -> (Int, Int)
countFUS ((Var -> String
fromVar Var
inner) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_FUS"  String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Var -> String
fromVar Var
outer))
    in -- should be configurable
  let p0 :: Bool
p0 = --False
       (Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1 Bool -> Bool -> Bool
|| Int
mInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
7 Bool -> Bool -> Bool
|| Int
depthInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
7)
      -- n>1 || depth>10
  -- (depth>6) &&


    --    `debug` ( "n is " L.++ (show n) L.++ "for" L.++ (show inner ) L.++ (show outer))
     in
  let innerDef :: FunDef1
innerDef =
        case Var -> FunDefs1 -> Maybe FunDef1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
inner FunDefs1
fdefs of
          (Just FunDef1
v) -> FunDef1
v
      outerDef :: FunDef1
outerDef =
        case Var -> FunDefs1 -> Maybe FunDef1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Var
outer FunDefs1
fdefs of
          (Just FunDef1
v) -> FunDef1
v
      p1 :: Bool
p1 =
        if ([Ty1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
innerDef)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
          then case [Ty1] -> Ty1
forall a. HasCallStack => [a] -> a
head (([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
innerDef)) of
                 (PackedTy String
_ ()
_) -> Bool
False
                 Ty1
x              -> Bool
True
          else Bool
True
      p2 :: Bool
p2 =
        if ([Ty1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
innerDef)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
          then case [Ty1] -> Ty1
forall a. HasCallStack => [a] -> a
head (([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
outerDef)) of
                 (PackedTy String
_ ()
_) -> Bool
False
                 Ty1
x              -> Bool
True
          else Bool
True
      p3 :: Bool
p3 =
        case ((FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
innerDef)) of
          CaseE Exp1
_ [(String, [(Var, ())], Exp1)]
ls ->
            Bool -> Bool
not
              (((String, [(Var, ())], Exp1) -> Bool -> Bool)
-> Bool -> [(String, [(Var, ())], Exp1)] -> Bool
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (\(String
_, [(Var, ())]
_, Exp1
exp) Bool
res -> Bool
res Bool -> Bool -> Bool
&& (Exp1 -> Bool
hasConstructorTail Exp1
exp)) Bool
True [(String, [(Var, ())], Exp1)]
ls)
          Exp1
_ -> Bool
True
      p4 :: Bool
p4 =
        case ((FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
outerDef)) of
          CaseE Exp1
_ [(String, [(Var, ())], Exp1)]
_ -> Bool
False
          Exp1
_         -> Bool
True
      p5 :: Bool
p5 =
        case ((FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
innerDef)) of
          CaseE Exp1
_ [(String, [(Var, ())], Exp1)]
_ -> Bool
False
          Exp1
_         -> Bool
True
   in (Bool
p0 Bool -> Bool -> Bool
|| Bool
p1 Bool -> Bool -> Bool
|| Bool
p2 Bool -> Bool -> Bool
|| Bool
p4 Bool -> Bool -> Bool
|| Bool
p5)

type FusedElement =
  (Var, -- outer fused function
   Var, -- Inner fused function
   Int, -- position at which inner is consumed
   Var -- the name of the fused function
  )

type TransformReturn =
  (Exp1, --transformed expression
   FunDefs1, -- updates functions stores
   [FusedElement] -- list of functions that are fused during the transformation
  )

data FusePassParams =  FusePassParams
 { FusePassParams -> Exp1
exp             :: Exp1, -- expression to transform
   FusePassParams -> [Var]
args            :: [Var], -- arguments of the function that the transformed
                            -- expression belongs to
   FusePassParams -> [(Var, Var, Int, Var)]
fusedFunctions :: [FusedElement], -- already fused functions
   FusePassParams -> [(Var, Var)]
skipList       :: [(Var, Var)], -- functions to skip for fusion purposes
   FusePassParams -> Int
depth          :: Int
  } deriving (Int -> FusePassParams -> String -> String
[FusePassParams] -> String -> String
FusePassParams -> String
(Int -> FusePassParams -> String -> String)
-> (FusePassParams -> String)
-> ([FusePassParams] -> String -> String)
-> Show FusePassParams
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FusePassParams -> String -> String
showsPrec :: Int -> FusePassParams -> String -> String
$cshow :: FusePassParams -> String
show :: FusePassParams -> String
$cshowList :: [FusePassParams] -> String -> String
showList :: [FusePassParams] -> String -> String
Show , (forall x. FusePassParams -> Rep FusePassParams x)
-> (forall x. Rep FusePassParams x -> FusePassParams)
-> Generic FusePassParams
forall x. Rep FusePassParams x -> FusePassParams
forall x. FusePassParams -> Rep FusePassParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FusePassParams -> Rep FusePassParams x
from :: forall x. FusePassParams -> Rep FusePassParams x
$cto :: forall x. Rep FusePassParams x -> FusePassParams
to :: forall x. Rep FusePassParams x -> FusePassParams
Generic)


tuple_pass :: DDefs Ty1 -> FunDefs1 -> PassM (FunDefs1)
tuple_pass :: DDefs Ty1 -> FunDefs1 -> PassM FunDefs1
tuple_pass DDefs Ty1
ddefs FunDefs1
fdefs =
    (FunDefs1 -> FunDef1 -> PassM FunDefs1)
-> FunDefs1 -> FunDefs1 -> PassM FunDefs1
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM FunDefs1 -> FunDef1 -> PassM FunDefs1
tupleFunction FunDefs1
fdefs FunDefs1
fdefs
  where
   tupleFunction :: FunDefs1 -> FunDef1 -> PassM FunDefs1
tupleFunction FunDefs1
defs' FunDef1
f  =
    do
      let fName :: Var
fName = FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
f
      if String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_FUS"  (Var -> String
fromVar Var
fName) Bool -> Bool -> Bool
||  String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_TUP"  (Var -> String
fromVar Var
fName)
        then do
          (Exp1
tupledBody, FunDefs1
tupleDefs) <- DDefs Ty1
-> FunDefs1 -> Exp1 -> [Var] -> Int -> PassM (Exp1, FunDefs1)
tuple_entry DDefs Ty1
ddefs FunDefs1
fdefs (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
f) (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
f) Int
0 PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String
"run tuple for" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Var -> String
forall a. Show a => a -> String
show (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
f)))
          let defs'' :: FunDefs1
defs'' = Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
fName FunDef1
f{funBody :: Exp1
funBody = Exp1
tupledBody} FunDefs1
defs'
          FunDefs1 -> PassM FunDefs1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (FunDefs1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union  FunDefs1
defs'' FunDefs1
tupleDefs)

        else
          FunDefs1 -> PassM FunDefs1
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return FunDefs1
defs'


fuse_pass ::  DDefs Ty1 -> FunDefs1 -> FusePassParams  -> PassM TransformReturn
fuse_pass :: DDefs Ty1 -> FunDefs1 -> FusePassParams -> PassM TransformReturn
fuse_pass DDefs Ty1
ddefs FunDefs1
funDefs (FusePassParams Exp1
exp [Var]
argsVars [(Var, Var, Int, Var)]
fusedFunctions [(Var, Var)]
skipList Int
depth) =
  if Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
10000-- then first fold before going back
   then  TransformReturn -> PassM TransformReturn
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
exp, FunDefs1
funDefs, [(Var, Var, Int, Var)]
fusedFunctions)
   else Exp1
-> [(Var, Var)]
-> FunDefs1
-> [(Var, Var, Int, Var)]
-> PassM TransformReturn
go (Exp1
exp) [(Var, Var)]
skipList FunDefs1
funDefs [(Var, Var, Int, Var)]
fusedFunctions
 where
  go :: Exp1
-> [(Var, Var)]
-> FunDefs1
-> [(Var, Var, Int, Var)]
-> PassM TransformReturn
go Exp1
body [(Var, Var)]
processed FunDefs1
fdefs [(Var, Var, Int, Var)]
prevFusedFuncs = do
    let defTable :: DefTable
defTable = Exp1 -> DefTable
buildDefTable Exp1
body
        potential :: Maybe ((Var, Var), Maybe Symbol)
potential = DefTable -> [(Var, Var)] -> Maybe ((Var, Var), Maybe Symbol)
findPotential DefTable
defTable [(Var, Var)]
processed
    case Maybe ((Var, Var), Maybe Symbol)
potential of
      Maybe ((Var, Var), Maybe Symbol)
Nothing -> do
        let final_clean :: Exp1
final_clean = Exp1 -> Exp1
removeUnusedDefsExp Exp1
body
        TransformReturn -> PassM TransformReturn
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Exp1
final_clean, FunDefs1
fdefs, [(Var, Var, Int, Var)]
prevFusedFuncs)

      Just ((Var
inner,Var
outer), Maybe Symbol
outerDefVarSymbol) ->
       do
        if FunDefs1 -> Var -> Var -> Int -> Bool
violateRestrictions FunDefs1
fdefs Var
inner Var
outer Int
depth
          then
               Exp1
-> [(Var, Var)]
-> FunDefs1
-> [(Var, Var, Int, Var)]
-> PassM TransformReturn
go  Exp1
body ((Var
inner,Var
outer)(Var, Var) -> [(Var, Var)] -> [(Var, Var)]
forall a. a -> [a] -> [a]
:[(Var, Var)]
processed) FunDefs1
fdefs [(Var, Var, Int, Var)]
prevFusedFuncs
             --   `debug1` ("cant fuse "L.++ (show (inner,outer)))
          else do
             -- fuse
            (Bool
validFused, Var
fNew, FunDefs1
fusedDefs) <-
               DDefs Ty1
-> FunDefs1
-> Var
-> Var
-> [(Var, Var, Int, Var)]
-> PassM (Bool, Var, FunDefs1)
fuse DDefs Ty1
ddefs FunDefs1
fdefs Var
inner Var
outer [(Var, Var, Int, Var)]
prevFusedFuncs

            let fusedFunction :: FunDef1
fusedFunction = FunDefs1
fusedDefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fNew
              --   `debug1` ("new fused function generated at depth " L.++ (show depth) L.++ (render (pprint (fusedDefs M.! fNew ))))

             --`debug` ("new fused:" L.++ (
               --  render (pprint ( fusedDefs M.! fNew  ))))
                newFusedEntry :: (Var, Var, Int, Var)
newFusedEntry = (Var
outer,Var
inner, -Int
1, Var
fNew)
                newFusedFunctions :: [(Var, Var, Int, Var)]
newFusedFunctions =  (Var, Var, Int, Var)
newFusedEntry (Var, Var, Int, Var)
-> [(Var, Var, Int, Var)] -> [(Var, Var, Int, Var)]
forall a. a -> [a] -> [a]
: [(Var, Var, Int, Var)]
prevFusedFuncs
                newProcessed :: [(Var, Var)]
newProcessed = (Var
inner,Var
outer)(Var, Var) -> [(Var, Var)] -> [(Var, Var)]
forall a. a -> [a] -> [a]
:[(Var, Var)]
processed

            (Exp1
retFuncBody, FunDefs1
retFunDefs, [(Var, Var, Int, Var)]
retFusedFunctions) <- DDefs Ty1 -> FunDefs1 -> FusePassParams -> PassM TransformReturn
fuse_pass  DDefs Ty1
ddefs
              FunDefs1
fusedDefs  (Exp1
-> [Var]
-> [(Var, Var, Int, Var)]
-> [(Var, Var)]
-> Int
-> FusePassParams
FusePassParams (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
fusedFunction)  (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
fusedFunction)
                [(Var, Var, Int, Var)]
newFusedFunctions [(Var, Var)]
newProcessed (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))

            --clean
            let newFusedFunctions2 :: [(Var, Var, Int, Var)]
newFusedFunctions2 = [(Var, Var, Int, Var)]
retFusedFunctions
              --   (newFusedEntry : prevFusedFuncs) L.++ retFusedFunctions
                cleanedFunction :: FunDef1
cleanedFunction =
                    FunDef1 -> FunDef1
removeUnusedDefs FunDef1
fusedFunction{funBody :: Exp1
funBody = Exp1
retFuncBody}
                fdefs_tmp2 :: FunDefs1
fdefs_tmp2       = FunDefs1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union FunDefs1
fusedDefs FunDefs1
retFunDefs
                fdefs_tmp3 :: FunDefs1
fdefs_tmp3       = Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert  Var
fNew FunDef1
cleanedFunction FunDefs1
fdefs_tmp2
                newDefs :: FunDefs1
newDefs =  (FunDefs1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union FunDefs1
fdefs FunDefs1
fdefs_tmp3)

            let foldedBody :: Exp1
foldedBody = (Var, Var, Int, Var) -> Exp1 -> Exp1
foldFusedCalls_Entry (Var
outer,Var
inner, -Int
1, Var
fNew) Exp1
body
            if Bool
validFused
              then
                let body' :: Exp1
body' = Exp1 -> Exp1
removeUnusedDefsExp Exp1
foldedBody
                in Exp1
-> [(Var, Var)]
-> FunDefs1
-> [(Var, Var, Int, Var)]
-> PassM TransformReturn
go (Exp1
body') [(Var, Var)]
newProcessed  FunDefs1
newDefs  [(Var, Var, Int, Var)]
newFusedFunctions2
              else
                 Exp1
-> [(Var, Var)]
-> FunDefs1
-> [(Var, Var, Int, Var)]
-> PassM TransformReturn
go Exp1
body  [(Var, Var)]
newProcessed FunDefs1
fdefs [(Var, Var, Int, Var)]
prevFusedFuncs

tupleAndOptimize :: DDefs Ty1 -> FunDefs1 ->Exp1 -> Bool->Int-> PassM (Exp1, FunDefs1)
tupleAndOptimize :: DDefs Ty1
-> FunDefs1 -> Exp1 -> Bool -> Int -> PassM (Exp1, FunDefs1)
tupleAndOptimize DDefs Ty1
ddefs FunDefs1
fdefs Exp1
mainExp Bool
firstTime  Int
depth =
  do
    FunDefs1
newDefs <- DDefs Ty1 -> FunDefs1 -> PassM FunDefs1
tuple_pass DDefs Ty1
ddefs FunDefs1
fdefs
    if Int
depthInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
||(Bool -> Bool
not Bool
firstTime Bool -> Bool -> Bool
&& (FunDefs1
newDefs FunDefs1 -> FunDefs1 -> Bool
forall a. Eq a => a -> a -> Bool
== FunDefs1
fdefs))
      then (Exp1, FunDefs1) -> PassM (Exp1, FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp1
mainExp, FunDefs1
newDefs)
      else  --return newDefs
        let (Exp1
mainExp', FunDefs1
fdefs') = (FunDefs1 -> Exp1 -> Bool -> Int -> (Exp1, FunDefs1)
redundancy_output_pass FunDefs1
newDefs Exp1
mainExp Bool
firstTime Int
0) in
        DDefs Ty1
-> FunDefs1 -> Exp1 -> Bool -> Int -> PassM (Exp1, FunDefs1)
tupleAndOptimize DDefs Ty1
ddefs FunDefs1
fdefs' Exp1
mainExp' Bool
False (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              PassM (Exp1, FunDefs1) -> String -> PassM (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` String
"run new tuple round"

fusion2 :: Prog1 -> PassM Prog1
fusion2 :: Prog1 -> PassM Prog1
fusion2 (L1.Prog DDefs (TyOf Exp1)
defs FunDefs1
funs Maybe (Exp1, TyOf Exp1)
main) = do
  (Maybe (Exp1, Ty1)
main', FunDefs1
funs') <-
    case Maybe (Exp1, TyOf Exp1)
main of
      Maybe (Exp1, TyOf Exp1)
Nothing -> (Maybe (Exp1, Ty1), FunDefs1)
-> PassM (Maybe (Exp1, Ty1), FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Exp1, Ty1)
forall a. Maybe a
Nothing, FunDefs1
funs)
      Just (Exp1
mainBody, TyOf Exp1
ty) -> do
        (Exp1
mainBody', FunDefs1
newDefs, [(Var, Var, Int, Var)]
fuseInfo) <-
          DDefs Ty1 -> FunDefs1 -> FusePassParams -> PassM TransformReturn
fuse_pass DDefs (TyOf Exp1)
DDefs Ty1
defs FunDefs1
funs (Exp1
-> [Var]
-> [(Var, Var, Int, Var)]
-> [(Var, Var)]
-> Int
-> FusePassParams
FusePassParams Exp1
mainBody [] [] [] Int
0)
        -- let newDefs' = M.map
        --        (\fdef -> if L.isPrefixOf "_FUS" (fromVar (funName fdef))
        --                   then    L.foldl (flip foldFusedCallsF ) fdef fuseInfo
        --                   else fdef
        --        ) newDefs
        (Exp1
mainBody'', FunDefs1
newDefs') <- DDefs Ty1
-> FunDefs1 -> Exp1 -> Bool -> Int -> PassM (Exp1, FunDefs1)
tupleAndOptimize DDefs (TyOf Exp1)
DDefs Ty1
defs (FunDefs1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union FunDefs1
funs FunDefs1
newDefs) Exp1
mainBody' Bool
True Int
0
        let newDefs'' :: FunDefs1
newDefs'' = (FunDef1 -> Bool) -> FunDefs1 -> FunDefs1
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter
              (\FunDef1
f ->
                  case ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
f) of
                      ProdTy [] -> Bool
False
                      Ty1
_ -> Bool
True
                  ) FunDefs1
newDefs'
        (Maybe (Exp1, Ty1), FunDefs1)
-> PassM (Maybe (Exp1, Ty1), FunDefs1)
forall a. a -> PassM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp1, Ty1) -> Maybe (Exp1, Ty1)
forall a. a -> Maybe a
Just (Exp1
mainBody'', TyOf Exp1
Ty1
ty),  FunDefs1
newDefs'')
        -- return (Just (mainBody', ty), newDefs)
  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) -> FunDefs1 -> Maybe (Exp1, TyOf Exp1) -> Prog1
forall ex.
DDefs (TyOf ex) -> FunDefs ex -> Maybe (ex, TyOf ex) -> Prog ex
L1.Prog DDefs (TyOf Exp1)
defs FunDefs1
funs' Maybe (Exp1, TyOf Exp1)
Maybe (Exp1, Ty1)
main'


-- Those  functions are used for the redundancy analysis
redundancy_output_pass :: FunDefs1 -> Exp1 ->Bool ->Int ->(Exp1 ,FunDefs1)
redundancy_output_pass :: FunDefs1 -> Exp1 -> Bool -> Int -> (Exp1, FunDefs1)
redundancy_output_pass FunDefs1
fdefs Exp1
mainExp Bool
firstTime Int
depth =
  let (FunDefs1
fdefs', Map Var (Map Int Int, Map Int Int, Var)
rules) = ((FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
 -> FunDef1 -> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var)))
-> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
-> FunDefs1
-> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl (FunDefs1
-> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
-> FunDef1
-> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
pass1F FunDefs1
fdefs) (FunDefs1
fdefs, Map Var (Map Int Int, Map Int Int, Var)
forall k a. Map k a
M.empty) FunDefs1
fdefs
      fdefs'' :: FunDefs1
fdefs'' = (FunDefs1 -> Var -> (Map Int Int, Map Int Int, Var) -> FunDefs1)
-> FunDefs1 -> Map Var (Map Int Int, Map Int Int, Var) -> FunDefs1
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey FunDefs1 -> Var -> (Map Int Int, Map Int Int, Var) -> FunDefs1
pass2F FunDefs1
fdefs' Map Var (Map Int Int, Map Int Int, Var)
rules
   in if  Int
depthInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
firstTime Bool -> Bool -> Bool
&& (FunDefs1
fdefs'' FunDefs1 -> FunDefs1 -> Bool
forall a. Eq a => a -> a -> Bool
== FunDefs1
fdefs))
        then (Exp1
mainExp, FunDefs1
fdefs'')
        else FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1)
redundancy_input_pass FunDefs1
fdefs'' Exp1
mainExp Int
depth
  where
    pass2F :: FunDefs1 -> Var -> (Map Int Int, Map Int Int, Var) -> FunDefs1
pass2F FunDefs1
fdefs Var
fName (Map Int Int
redirectMap, Map Int Int
outPutFromInput, Var
newName) =
      (FunDef1 -> FunDef1) -> FunDefs1 -> FunDefs1
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (FunDefs1
-> Var -> (Map Int Int, Map Int Int, Var) -> FunDef1 -> FunDef1
pass2Fsub FunDefs1
fdefs Var
fName (Map Int Int
redirectMap, Map Int Int
outPutFromInput, Var
newName)) FunDefs1
fdefs

    pass2Fsub :: FunDefs1
-> Var -> (Map Int Int, Map Int Int, Var) -> FunDef1 -> FunDef1
pass2Fsub FunDefs1
fdefs Var
fName (Map Int Int
redirectMap, Map Int Int
outPutFromInput, Var
newName) FunDef1
f =
      FunDef1
f
        { funBody :: Exp1
funBody =
            Exp1 -> Exp1
removeUnusedDefsExp
              (Exp1 -> Exp1
simplifyProjections
                 (Exp1 -> Exp1
removeCommonExpressions
                    (Exp1
-> FunDef1 -> FunDef1 -> Map Int Int -> Map Int Int -> Var -> Exp1
fixCalls
                       (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
f)
                       (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fName)
                       (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
newName)
                       Map Int Int
redirectMap
                       Map Int Int
outPutFromInput
                       Var
newName
                       )))
        }

    pass1F :: FunDefs1
-> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
-> FunDef1
-> (FunDefs1, Map Var (Map Int Int, Map Int Int, Var))
pass1F FunDefs1
orgFdefs (FunDefs1
fdefs, Map Var (Map Int Int, Map Int Int, Var)
rules) FunDef1
f =
      let fName :: Var
fName = FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
f
       in if String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_TUP" (Var -> String
fromVar Var
fName)
            then let  testedPositions :: Map (Var, Int, Int) Bool
testedPositions =
                            FunDefs1 -> Var -> Map (Var, Int, Int) Bool
testAllOutputPositions FunDefs1
orgFdefs Var
fName

                      newName :: Var
newName =  String -> Var
toVar (Var -> String
fromVar Var
fName String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"outputFixed") in
                      if Var -> FunDefs1 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Var
newName FunDefs1
fdefs
                        then
                         (FunDefs1
fdefs, Map Var (Map Int Int, Map Int Int, Var)
rules)

                        else

                          let  (FunDef1
fNew, Map Int Int
redirectMap, Map Int Int
outPutFromInput) =
                                 FunDef1
-> Map (Var, Int, Int) Bool -> (FunDef1, Map Int Int, Map Int Int)
removeRedundantOutput
                                 FunDef1
f
                                Map (Var, Int, Int) Bool
testedPositions --`debug` ("testing" L.++ (show fName))

                         in ( Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fNew) FunDef1
fNew FunDefs1
fdefs
                             ,Var
-> (Map Int Int, Map Int Int, Var)
-> Map Var (Map Int Int, Map Int Int, Var)
-> Map Var (Map Int Int, Map Int Int, Var)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
fName (Map Int Int
redirectMap, Map Int Int
outPutFromInput, FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fNew) Map Var (Map Int Int, Map Int Int, Var)
rules)
                      --  `debug` ((show fName) L.++ "new things" L.++  (show (getOutputsFromInput f)))
            else (FunDefs1
fdefs, Map Var (Map Int Int, Map Int Int, Var)
rules)


testAllOutputPositions:: FunDefs1 -> Var -> M.Map (Var,Int,Int) Bool
testAllOutputPositions :: FunDefs1 -> Var -> Map (Var, Int, Int) Bool
testAllOutputPositions  FunDefs1
fdefs Var
fName =
   let f :: FunDef1
f = FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fName
       n :: Int
n = case ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
f) of
             ProdTy [Ty1]
ls -> [Ty1] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Ty1]
ls
   in Int
-> Int
-> Int
-> Map (Var, Int, Int) Bool
-> Map (Var, Int, Int) Bool
loop1 Int
0 Int
0 Int
n Map (Var, Int, Int) Bool
forall k a. Map k a
M.empty
  where
    loop1 :: Int -> Int -> Int -> M.Map (Var, Int, Int) Bool -> M.Map (Var, Int, Int) Bool
    loop1 :: Int
-> Int
-> Int
-> Map (Var, Int, Int) Bool
-> Map (Var, Int, Int) Bool
loop1 Int
i Int
j Int
n Map (Var, Int, Int) Bool
testedPositions =
      if Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
n
        then
          Map (Var, Int, Int) Bool
testedPositions
        else
          if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
            then
              Int
-> Int
-> Int
-> Map (Var, Int, Int) Bool
-> Map (Var, Int, Int) Bool
loop1 Int
0 (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
n Map (Var, Int, Int) Bool
testedPositions
            else
               Int
-> Int
-> Int
-> Map (Var, Int, Int) Bool
-> Map (Var, Int, Int) Bool
loop1 (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
j Int
n ((Bool, Map (Var, Int, Int) Bool) -> Map (Var, Int, Int) Bool
forall a b. (a, b) -> b
snd( FunDefs1
-> (Var, Int, Int)
-> Map (Var, Int, Int) Bool
-> (Bool, Map (Var, Int, Int) Bool)
testTwoOutputPositions FunDefs1
fdefs (Var
fName, Int
i, Int
j) Map (Var, Int, Int) Bool
testedPositions))
               --  `debug` (show"start" L.++ show((fName, i, j) ))


-- For each pair of distinct output positions of a tuple: (0,1), (1,0),
-- testTwoOutputPositions checks whether a particular function returns
-- identical values at those positions.
testTwoOutputPositions :: FunDefs1 -> (Var, Int, Int) -> M.Map (Var,Int,Int) Bool
  -> (Bool,  M.Map (Var,Int,Int) Bool)
testTwoOutputPositions :: FunDefs1
-> (Var, Int, Int)
-> Map (Var, Int, Int) Bool
-> (Bool, Map (Var, Int, Int) Bool)
testTwoOutputPositions FunDefs1
fdefs (Var
fName, Int
i, Int
j) Map (Var, Int, Int) Bool
testedPositions =
  if Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
j then (Bool
True, Map (Var, Int, Int) Bool
testedPositions)
    else
      case (Var, Int, Int) -> Map (Var, Int, Int) Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
fName, Int
i, Int
j) Map (Var, Int, Int) Bool
testedPositions of
        Just Bool
res -> (Bool
res, Map (Var, Int, Int) Bool
testedPositions)
        Maybe Bool
Nothing ->
          case (Var, Int, Int) -> Map (Var, Int, Int) Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Var
fName, Int
j, Int
i) Map (Var, Int, Int) Bool
testedPositions of
            Just Bool
res -> (Bool
res, (Var, Int, Int)
-> Bool -> Map (Var, Int, Int) Bool -> Map (Var, Int, Int) Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
fName, Int
j, Int
i) Bool
res Map (Var, Int, Int) Bool
testedPositions)
            Maybe Bool
Nothing ->
              let (Bool
cond, Set (Var, Int, Int)
inductiveAssumption, Set (Var, Int, Int)
unresolvedConditions) =
                    Var
-> Int -> Int -> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
extractAssumptionAndConditions Var
fName Int
i Int
j
              in if Bool
cond
                  then
                    let (Bool
cond', Set (Var, Int, Int)
inductiveAssumption') =
                          Set (Var, Int, Int)
-> Set (Var, Int, Int) -> (Bool, Set (Var, Int, Int))
testTwoOutputPositionsRec Set (Var, Int, Int)
inductiveAssumption Set (Var, Int, Int)
unresolvedConditions
                    in if Bool
cond'
                       then
                        -- if there are not more conditions to resolve then we
                        --  are done and correct !
                          let testedPositions' :: Map (Var, Int, Int) Bool
testedPositions' = (Map (Var, Int, Int) Bool
 -> (Var, Int, Int) -> Map (Var, Int, Int) Bool)
-> Map (Var, Int, Int) Bool
-> Set (Var, Int, Int)
-> Map (Var, Int, Int) Bool
forall a b. (a -> b -> a) -> a -> Set b -> a
S.foldl
                                (\Map (Var, Int, Int) Bool
mp (Var
fName, Int
i, Int
j)  -> (Var, Int, Int)
-> Bool -> Map (Var, Int, Int) Bool -> Map (Var, Int, Int) Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
fName, Int
i, Int
j) Bool
True Map (Var, Int, Int) Bool
mp)
                                  Map (Var, Int, Int) Bool
testedPositions   Set (Var, Int, Int)
inductiveAssumption'
                          in (Bool
True, Map (Var, Int, Int) Bool
testedPositions')
                      else
                        (Bool
False, (Var, Int, Int)
-> Bool -> Map (Var, Int, Int) Bool -> Map (Var, Int, Int) Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
fName, Int
i, Int
j) Bool
False Map (Var, Int, Int) Bool
testedPositions)

                  else
                      (Bool
False, (Var, Int, Int)
-> Bool -> Map (Var, Int, Int) Bool -> Map (Var, Int, Int) Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Var
fName, Int
i, Int
j) Bool
False Map (Var, Int, Int) Bool
testedPositions)


 where
  testTwoOutputPositionsRec :: Set (Var, Int, Int)
-> Set (Var, Int, Int) -> (Bool, Set (Var, Int, Int))
testTwoOutputPositionsRec Set (Var, Int, Int)
inductiveAssumption Set (Var, Int, Int)
unresolvedConditions =
    -- for each unresolved condition
    -- 1-check if equivalent rules are satisfied
    -- 2-if not return false
    -- 3-if yes move it to inductive assumptions and add the appropriate new
    --  conditions if any
    -- 4-if at the end result is false we are done, otherwise if there is no
    -- unresolvedConditions then proof is done also, otherwise call perform the
    -- call recursively.
    let (Bool
res, Set (Var, Int, Int)
inductiveAssumption', Set (Var, Int, Int)
unresolvedConditions') =
          ((Bool, Set (Var, Int, Int), Set (Var, Int, Int))
 -> (Var, Int, Int)
 -> (Bool, Set (Var, Int, Int), Set (Var, Int, Int)))
-> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
-> Set (Var, Int, Int)
-> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
forall a b. (a -> b -> a) -> a -> Set b -> a
S.foldl (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
-> (Var, Int, Int)
-> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
foo (Bool
True, Set (Var, Int, Int)
inductiveAssumption, Set (Var, Int, Int)
forall a. Set a
S.empty) Set (Var, Int, Int)
unresolvedConditions
        unresolvedConditions'' :: Set (Var, Int, Int)
unresolvedConditions'' = ((Var, Int, Int) -> Bool)
-> Set (Var, Int, Int) -> Set (Var, Int, Int)
forall a. (a -> Bool) -> Set a -> Set a
S.filter  (\(Var
f, Int
i, Int
j)->
            (Var, Int, Int) -> Set (Var, Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember (Var
f, Int
i, Int
j) Set (Var, Int, Int)
inductiveAssumption' Bool -> Bool -> Bool
&&
              (Var, Int, Int) -> Set (Var, Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember (Var
f, Int
j, Int
i) Set (Var, Int, Int)
inductiveAssumption') Set (Var, Int, Int)
unresolvedConditions'

    in if Bool
res Bool -> Bool -> Bool
&& Set (Var, Int, Int) -> Bool
forall a. Set a -> Bool
S.null Set (Var, Int, Int)
unresolvedConditions''
         then (Bool
res, Set (Var, Int, Int)
inductiveAssumption')
         else
            if Bool
resBool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
==Bool
False
              then
               (Bool
False, Set (Var, Int, Int)
forall a. Set a
S.empty)
              else
                Set (Var, Int, Int)
-> Set (Var, Int, Int) -> (Bool, Set (Var, Int, Int))
testTwoOutputPositionsRec Set (Var, Int, Int)
inductiveAssumption'  Set (Var, Int, Int)
unresolvedConditions''

  foo :: (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int))
      -> (Var, Int, Int)
      -> (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int))
  foo :: (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
-> (Var, Int, Int)
-> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
foo (Bool
condInput, Set (Var, Int, Int)
assumptionsInput, Set (Var, Int, Int)
unresolvedInput) (Var
fName, Int
i, Int
j) =

    let (Bool
cond, Set (Var, Int, Int)
inductiveAssumption, Set (Var, Int, Int)
unresolvedConditions) =
              Var
-> Int -> Int -> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
extractAssumptionAndConditions Var
fName Int
i Int
j
    in (Bool
cond Bool -> Bool -> Bool
&& Bool
condInput, Set (Var, Int, Int) -> Set (Var, Int, Int) -> Set (Var, Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Var, Int, Int)
assumptionsInput Set (Var, Int, Int)
inductiveAssumption,
        Set (Var, Int, Int) -> Set (Var, Int, Int) -> Set (Var, Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Var, Int, Int)
unresolvedConditions Set (Var, Int, Int)
unresolvedInput )

  -- TODO.
  extractAssumptionAndConditions :: Var -> Int -> Int -> (Bool, S.Set (Var, Int, Int), S.Set (Var, Int, Int))
  extractAssumptionAndConditions :: Var
-> Int -> Int -> (Bool, Set (Var, Int, Int), Set (Var, Int, Int))
extractAssumptionAndConditions Var
fName Int
i Int
j  =
    let exp :: Exp1
exp = FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody (FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fName)
        inlinedContent :: Exp1
inlinedContent = Exp1 -> Exp1
inlineAllButAppE Exp1
exp --`debug` (show (fName) L.++ "inlined body\n"L.++ (render (pprint exp)))
    in case Exp1
inlinedContent of
          CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls ->
            let parametrizedExprsList :: [[(Exp1, [(Int, Var, Var)])]]
parametrizedExprsList = ((String, [(Var, ())], Exp1) -> [(Exp1, [(Int, Var, Var)])])
-> [(String, [(Var, ())], Exp1)] -> [[(Exp1, [(Int, Var, Var)])]]
forall a b. (a -> b) -> [a] -> [b]
L.map (String, [(Var, ())], Exp1) -> [(Exp1, [(Int, Var, Var)])]
parametrizeProdExprs [(String, [(Var, ())], Exp1)]
ls
                cond :: Bool
cond = (Bool -> [(Exp1, [(Int, Var, Var)])] -> Bool)
-> Bool -> [[(Exp1, [(Int, Var, Var)])]] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (Int -> Int -> Bool -> [(Exp1, [(Int, Var, Var)])] -> Bool
forall {a} {a} {a} {c}.
(Eq a, Eq a) =>
Int -> Int -> Bool -> [(a, [(a, a, c)])] -> Bool
checkExpressions Int
i Int
j) Bool
True [[(Exp1, [(Int, Var, Var)])]]
parametrizedExprsList
            in if Bool
cond
                then
                  let inductiveAssumption :: Set (Var, Int, Int)
inductiveAssumption  = (Var, Int, Int) -> Set (Var, Int, Int) -> Set (Var, Int, Int)
forall a. Ord a => a -> Set a -> Set a
S.insert (Var
fName, Int
i, Int
j) Set (Var, Int, Int)
forall a. Set a
S.empty
                      unresolvedConditions :: Set (Var, Int, Int)
unresolvedConditions = (Set (Var, Int, Int)
 -> [(Exp1, [(Int, Var, Var)])] -> Set (Var, Int, Int))
-> Set (Var, Int, Int)
-> [[(Exp1, [(Int, Var, Var)])]]
-> Set (Var, Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (Int
-> Int
-> Set (Var, Int, Int)
-> [(Exp1, [(Int, Var, Var)])]
-> Set (Var, Int, Int)
forall {c} {c} {a} {b}.
(Ord c, Ord c) =>
Int -> Int -> Set (c, c, c) -> [(a, [(c, b, c)])] -> Set (c, c, c)
collectConditions Int
i Int
j)
                        Set (Var, Int, Int)
forall a. Set a
S.empty [[(Exp1, [(Int, Var, Var)])]]
parametrizedExprsList

                      unresolvedConditions' :: Set (Var, Int, Int)
unresolvedConditions' = ((Var, Int, Int) -> Bool)
-> Set (Var, Int, Int) -> Set (Var, Int, Int)
forall a. (a -> Bool) -> Set a -> Set a
S.filter  (\(Var
f, Int
i, Int
j)->
                        (Var, Int, Int) -> Set (Var, Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember (Var
f, Int
i, Int
j) Set (Var, Int, Int)
inductiveAssumption Bool -> Bool -> Bool
&&
                          (Var, Int, Int) -> Set (Var, Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember (Var
f, Int
j, Int
i) Set (Var, Int, Int)
inductiveAssumption)
                            Set (Var, Int, Int)
unresolvedConditions
                  in  (Bool
True, Set (Var, Int, Int)
inductiveAssumption, Set (Var, Int, Int)
unresolvedConditions)
                else
                    (Bool
False, Set (Var, Int, Int)
forall a. Set a
S.empty, Set (Var, Int, Int)
forall a. Set a
S.empty)


  parametrizeProdExprs :: (DataCon, [(Var, ())], Exp1) -> [(Exp1, [(Int, Var, Var)])]
  parametrizeProdExprs :: (String, [(Var, ())], Exp1) -> [(Exp1, [(Int, Var, Var)])]
parametrizeProdExprs (String
_, [(Var, ())]
_, Exp1
subExp) =
      let vars :: Set Var
vars = Exp1 -> Set Var
collectVars Exp1
subExp
          leafProd :: Exp1
leafProd = Exp1 -> Exp1
getLeafProd Exp1
subExp
          varsToFuncs :: VarEnv
varsToFuncs =  Exp1 -> VarEnv
collectVarToFuncs  Exp1
subExp
      in case Exp1
leafProd of
        (MkProdE [Exp1]
ls) ->(Exp1 -> (Exp1, [(Int, Var, Var)]))
-> [Exp1] -> [(Exp1, [(Int, Var, Var)])]
forall a b. (a -> b) -> [a] -> [b]
L.map  (Set Var -> VarEnv -> Exp1 -> (Exp1, [(Int, Var, Var)])
parametrizeExp Set Var
vars VarEnv
varsToFuncs) [Exp1]
ls

  checkExpressions :: Int -> Int -> Bool -> [(a, [(a, a, c)])] -> Bool
checkExpressions Int
i Int
j Bool
b [(a, [(a, a, c)])]
prodListParametrized=
    let (a
expi, [(a, a, c)]
pars1) =  [(a, [(a, a, c)])]
prodListParametrized [(a, [(a, a, c)])] -> Int -> (a, [(a, a, c)])
forall a. HasCallStack => [a] -> Int -> a
L.!! Int
i
        (a
expj, [(a, a, c)]
pars2) = [(a, [(a, a, c)])]
prodListParametrized [(a, [(a, a, c)])] -> Int -> (a, [(a, a, c)])
forall a. HasCallStack => [a] -> Int -> a
L.!! Int
j
    in Bool
b Bool -> Bool -> Bool
&& a
expia -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
expj Bool -> Bool -> Bool
&& [(a, a, c)] -> [(a, a, c)] -> Bool
forall {a} {a} {c} {a} {c}.
Eq a =>
[(a, a, c)] -> [(a, a, c)] -> Bool
parsCheck [(a, a, c)]
pars1 [(a, a, c)]
pars2

  parsCheck :: [(a, a, c)] -> [(a, a, c)] -> Bool
parsCheck [] [] = Bool
True
  parsCheck ((a
_, a
v1, c
_):[(a, a, c)]
ls1)  ((a
_, a
v2, c
_):[(a, a, c)]
ls2) =
     a
v1a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
v2 Bool -> Bool -> Bool
&& [(a, a, c)] -> [(a, a, c)] -> Bool
parsCheck [(a, a, c)]
ls1 [(a, a, c)]
ls2

  collectConditions :: Int -> Int -> Set (c, c, c) -> [(a, [(c, b, c)])] -> Set (c, c, c)
collectConditions Int
i Int
j Set (c, c, c)
s [(a, [(c, b, c)])]
prodListParametrized =
    let (a
_, [(c, b, c)]
ls1) =  [(a, [(c, b, c)])]
prodListParametrized [(a, [(c, b, c)])] -> Int -> (a, [(c, b, c)])
forall a. HasCallStack => [a] -> Int -> a
L.!! Int
i
        (a
_, [(c, b, c)]
ls2) = [(a, [(c, b, c)])]
prodListParametrized [(a, [(c, b, c)])] -> Int -> (a, [(c, b, c)])
forall a. HasCallStack => [a] -> Int -> a
L.!! Int
j
        s' :: Set (c, c, c)
s' = [(c, b, c)] -> [(c, b, c)] -> Set (c, c, c)
forall {a} {c} {b} {b} {c}.
(Ord a, Ord c) =>
[(c, b, a)] -> [(c, b, c)] -> Set (a, c, c)
collectConditionsPars  [(c, b, c)]
ls1 [(c, b, c)]
ls2
    in Set (c, c, c) -> Set (c, c, c) -> Set (c, c, c)
forall a. Ord a => Set a -> Set a -> Set a
S.union Set (c, c, c)
s' Set (c, c, c)
s

  collectConditionsPars :: [(c, b, a)] -> [(c, b, c)] -> Set (a, c, c)
collectConditionsPars [] [] = Set (a, c, c)
forall a. Set a
S.empty
  collectConditionsPars ((c
idx1, b
v1, a
f):[(c, b, a)]
ls1)  ((c
idx2, b
v2, c
_):[(c, b, c)]
ls2) =
     let sNext :: Set (a, c, c)
sNext =  [(c, b, a)] -> [(c, b, c)] -> Set (a, c, c)
collectConditionsPars [(c, b, a)]
ls1 [(c, b, c)]
ls2
     in if c
idx1c -> c -> Bool
forall a. Eq a => a -> a -> Bool
==c
idx2
          then
            Set (a, c, c)
sNext
          else
            (a, c, c) -> Set (a, c, c) -> Set (a, c, c)
forall a. Ord a => a -> Set a -> Set a
S.insert (a
f, c
idx1, c
idx2) Set (a, c, c)
sNext


getLeafExpr :: Exp1 -> Exp1
getLeafExpr :: Exp1 -> Exp1
getLeafExpr = Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> PreExp ext loc dec
recur
 where
   recur :: PreExp ext loc dec -> PreExp ext loc dec
recur PreExp ext loc dec
ex =
     case PreExp ext loc dec
ex of
       LetE (Var, [loc], dec, PreExp ext loc dec)
_ PreExp ext loc dec
body -> PreExp ext loc dec -> PreExp ext loc dec
recur PreExp ext loc dec
body
       PreExp ext loc dec
x-> PreExp ext loc dec
x

-- fetch the tuple returned at the tail of subExp
getLeafProd :: Exp1 -> Exp1
getLeafProd :: Exp1 -> Exp1
getLeafProd = Exp1 -> Exp1
forall {loc} {dec} {ext :: * -> * -> *}.
(Show loc, Show dec, Show (ext loc dec)) =>
PreExp ext loc dec -> PreExp ext loc dec
recur
 where
   recur :: PreExp ext loc dec -> PreExp ext loc dec
recur PreExp ext loc dec
ex =
     case PreExp ext loc dec
ex of
       LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
_) PreExp ext loc dec
body -> PreExp ext loc dec -> PreExp ext loc dec
recur PreExp ext loc dec
body
       leaf :: PreExp ext loc dec
leaf@MkProdE{} -> PreExp ext loc dec
leaf
       PreExp ext loc dec
x-> String -> PreExp ext loc dec
forall a. HasCallStack => String -> a
error (PreExp ext loc dec -> String
forall a. Show a => a -> String
show PreExp ext loc dec
x)

hasConstructorTail :: Exp1 -> Bool
hasConstructorTail :: Exp1 -> Bool
hasConstructorTail = Exp1 -> Bool
forall {ext :: * -> * -> *} {loc} {dec}. PreExp ext loc dec -> Bool
rec
  where
    rec :: PreExp ext loc dec -> Bool
rec PreExp ext loc dec
ex =
      case PreExp ext loc dec
ex of
        LetE (Var, [loc], dec, PreExp ext loc dec)
_ PreExp ext loc dec
body -> PreExp ext loc dec -> Bool
rec PreExp ext loc dec
body
        DataConE loc
_ String
_ [PreExp ext loc dec]
_ -> Bool
True
        PreExp ext loc dec
x -> Bool
False

-- all variables which are used to bind function applications.
collectVars :: Exp1 -> S.Set Var
collectVars :: Exp1 -> Set Var
collectVars = Exp1 -> Set Var
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> Set Var
recur
 where
   recur :: PreExp ext loc dec -> Set Var
recur PreExp ext loc dec
ex = case PreExp ext loc dec
ex of
     LetE (Var
v, [loc]
ls, dec
t, AppE{}) PreExp ext loc dec
body ->
        Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.insert Var
v (PreExp ext loc dec -> Set Var
recur PreExp ext loc dec
body)
     MkProdE{} -> Set Var
forall a. Set a
S.empty

-- Map of variable binding to its function call
collectVarToFuncs :: Exp1 -> M.Map Var Var
collectVarToFuncs :: Exp1 -> VarEnv
collectVarToFuncs = Exp1 -> VarEnv
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> VarEnv
recur
 where
   recur :: PreExp ext loc dec -> VarEnv
recur PreExp ext loc dec
ex = case PreExp ext loc dec
ex of
     LetE (Var
v, [loc]
ls, dec
t,  (AppE Var
f [loc]
_ [PreExp ext loc dec]
_)) PreExp ext loc dec
body ->
       Var -> Var -> VarEnv -> VarEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
v  Var
f  (PreExp ext loc dec -> VarEnv
recur PreExp ext loc dec
body)
     MkProdE{} -> VarEnv
forall k a. Map k a
M.empty

-- Given a set of variables that represents results of function calls
-- and a mapping from those variables to the called function
-- and an expression => parameterize the expression around those
parametrizeExp ::  S.Set Var ->  M.Map Var Var -> Exp1 -> (Exp1, [(Int, Var, Var)])
parametrizeExp :: Set Var -> VarEnv -> Exp1 -> (Exp1, [(Int, Var, Var)])
parametrizeExp Set Var
vars VarEnv
mp Exp1
exp   =
 let (Exp1
retExp, [(Int, Var)]
ls) = Exp1 -> [(Int, Var)] -> (Exp1, [(Int, Var)])
recur Exp1
exp []
 in (Exp1
retExp, ((Int, Var) -> (Int, Var, Var))
-> [(Int, Var)] -> [(Int, Var, Var)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Int
i, Var
v)-> (Int
i, Var
v, VarEnv
mp VarEnv -> Var -> Var
forall k a. Ord k => Map k a -> k -> a
M.! Var
v )) [(Int, Var)]
ls )
  where
    recur :: Exp1 -> [(Int, Var)] -> (Exp1, [(Int, Var)])
recur Exp1
ex [(Int, Var)]
ls = case Exp1
ex of
      LetE{} -> String -> (Exp1, [(Int, Var)])
forall a. HasCallStack => String -> a
error (String
"let not expected in parametrizeExp" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (Exp1 -> String
forall a. Show a => a -> String
show Exp1
ex))
      -- TODO: this is work around (correct not complete)[should be also handled]
      x :: Exp1
x@(CaseE Exp1
caseE [(String, [(Var, ())], Exp1)]
caseLs) -> (Exp1
x, [(Int, Var)]
ls)
       -- error( "CaseE not expected in parametrizeExp" ++ (render (pprint ex )))
      AppE Var
v [()]
loc [Exp1]
args ->
        let ([Exp1]
args', [(Int, Var)]
pList) = (([Exp1], [(Int, Var)]) -> Exp1 -> ([Exp1], [(Int, Var)]))
-> ([Exp1], [(Int, Var)]) -> [Exp1] -> ([Exp1], [(Int, Var)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl ([Exp1], [(Int, Var)]) -> Exp1 -> ([Exp1], [(Int, Var)])
f ([], [(Int, Var)]
ls) [Exp1]
args
             where
               f :: ([Exp1], [(Int, Var)]) -> Exp1 -> ([Exp1], [(Int, Var)])
f ([Exp1]
expList, [(Int, Var)]
projList) Exp1
exp =
                  let (Exp1
exp' , [(Int, Var)]
ls') = Exp1 -> [(Int, Var)] -> (Exp1, [(Int, Var)])
recur Exp1
exp [(Int, Var)]
projList
                  in ([Exp1]
expList [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++ [Exp1
exp'], [(Int, Var)]
projList [(Int, Var)] -> [(Int, Var)] -> [(Int, Var)]
forall a. [a] -> [a] -> [a]
L.++ [(Int, Var)]
ls')
        in ((Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
v [()]
loc [Exp1]
args'), [(Int, Var)]
pList)

      DataConE ()
loc String
dataCons [Exp1]
expList->
        let ([Exp1]
expList', [(Int, Var)]
pList) = (([Exp1], [(Int, Var)]) -> Exp1 -> ([Exp1], [(Int, Var)]))
-> ([Exp1], [(Int, Var)]) -> [Exp1] -> ([Exp1], [(Int, Var)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl ([Exp1], [(Int, Var)]) -> Exp1 -> ([Exp1], [(Int, Var)])
f ([], [(Int, Var)]
ls) [Exp1]
expList
             where
               f :: ([Exp1], [(Int, Var)]) -> Exp1 -> ([Exp1], [(Int, Var)])
f ([Exp1]
expList, [(Int, Var)]
projList) Exp1
exp =
                 let (Exp1
exp' , [(Int, Var)]
ls') = Exp1 -> [(Int, Var)] -> (Exp1, [(Int, Var)])
recur Exp1
exp [(Int, Var)]
projList
                 in ([Exp1]
expList [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++ [Exp1
exp'], [(Int, Var)]
projList [(Int, Var)] -> [(Int, Var)] -> [(Int, Var)]
forall a. [a] -> [a] -> [a]
L.++ [(Int, Var)]
ls')
        in ((() -> String -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
loc -> String -> [PreExp ext loc dec] -> PreExp ext loc dec
DataConE ()
loc String
dataCons [Exp1]
expList'), [(Int, Var)]
pList)

      x :: Exp1
x@(ProjE Int
i ((VarE Var
v))) ->
          if Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Var
v Set Var
vars
              then
                let exp' :: Exp1
exp' = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (String -> Var
toVar (String
"par" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ Int -> String
forall a. Show a => a -> String
show ([(Int, Var)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [(Int, Var)]
ls)))
                    ls' :: [(Int, Var)]
ls' = [(Int, Var)]
ls [(Int, Var)] -> [(Int, Var)] -> [(Int, Var)]
forall a. [a] -> [a] -> [a]
L.++ [(Int
i, Var
v)]
                in (Exp1
exp', [(Int, Var)]
ls')
              else
                (Exp1
x, [(Int, Var)]
ls)
      Exp1
otherwise -> (Exp1
otherwise, [(Int, Var)]
ls)

-- this function inline all expressions except function application
-- that returns tuples
inlineAllButAppE :: Exp1 -> Exp1
inlineAllButAppE :: Exp1 -> Exp1
inlineAllButAppE = Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {loc}.
(Expression (ext loc (UrTy loc)),
 SubstitutableExt (PreExp ext loc (UrTy loc)) (ext loc (UrTy loc)),
 Eq loc, Eq loc, Eq (ext loc (UrTy loc)), Show loc, Show loc,
 Out loc, Out loc) =>
PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
rec
 where
  rec :: PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
rec PreExp ext loc (UrTy loc)
ex = case PreExp ext loc (UrTy loc)
ex of
    LetE (Var
v, [loc]
ls, UrTy loc
t, PreExp ext loc (UrTy loc)
bind) PreExp ext loc (UrTy loc)
body ->
     let oldExp :: PreExp ext loc (UrTy loc)
oldExp = Var -> PreExp ext loc (UrTy loc)
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE Var
v
         newExp :: PreExp ext loc (UrTy loc)
newExp = PreExp ext loc (UrTy loc)
bind
         body' :: PreExp ext loc (UrTy loc)
body' = PreExp ext loc (UrTy loc)
-> PreExp ext loc (UrTy loc)
-> PreExp ext loc (UrTy loc)
-> PreExp ext loc (UrTy loc)
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE PreExp ext loc (UrTy loc)
oldExp PreExp ext loc (UrTy loc)
newExp PreExp ext loc (UrTy loc)
body
     in case PreExp ext loc (UrTy loc)
bind of
          AppE{} -> case UrTy loc
t  of
               ProdTy{} ->  (Var, [loc], UrTy loc, PreExp ext loc (UrTy loc))
-> PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [loc]
ls, UrTy loc
t, PreExp ext loc (UrTy loc)
bind) (PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
rec PreExp ext loc (UrTy loc)
body)
               UrTy loc
_ ->  PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
rec PreExp ext loc (UrTy loc)
body'
          PreExp ext loc (UrTy loc)
_      ->  PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
rec PreExp ext loc (UrTy loc)
body'
    CaseE PreExp ext loc (UrTy loc)
e [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
ls    ->
      let ls' :: [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
ls' = ((String, [(Var, loc)], PreExp ext loc (UrTy loc))
 -> (String, [(Var, loc)], PreExp ext loc (UrTy loc)))
-> [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
-> [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
x, [(Var, loc)]
y, PreExp ext loc (UrTy loc)
exp) -> (String
x, [(Var, loc)]
y, PreExp ext loc (UrTy loc) -> PreExp ext loc (UrTy loc)
rec PreExp ext loc (UrTy loc)
exp)) [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
ls
      in  PreExp ext loc (UrTy loc)
-> [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
-> PreExp ext loc (UrTy loc)
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE PreExp ext loc (UrTy loc)
e [(String, [(Var, loc)], PreExp ext loc (UrTy loc))]
ls'
    PreExp ext loc (UrTy loc)
otherwise -> PreExp ext loc (UrTy loc)
otherwise

-- This function optimizes the tupled function by removing redundant output
-- parameters and their computation.
-- redundant positions are pr-computed and stored in testedPositions.
removeRedundantOutput :: FunDef1 -> M.Map (Var,Int,Int) Bool  -> (FunDef1, M.Map Int Int, M.Map Int Int)
removeRedundantOutput :: FunDef1
-> Map (Var, Int, Int) Bool -> (FunDef1, Map Int Int, Map Int Int)
removeRedundantOutput  FunDef1
fdef Map (Var, Int, Int) Bool
testedPositions =
    let outputsFromInputs :: Map Int Int
outputsFromInputs = FunDef1 -> Map Int Int
getOutputsFromInput FunDef1
fdef in
    let outputTuples :: Vector (Vector Exp1)
outputTuples = [Vector Exp1] -> Vector (Vector Exp1)
forall a. [a] -> Vector a
V.fromList  (Exp1 -> [Vector Exp1]
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> [Vector (PreExp ext loc dec)]
collectOutputs (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
fdef)) in
    let firstTuple :: Vector Exp1
firstTuple = Vector (Vector Exp1)
outputTuples Vector (Vector Exp1) -> Int -> Vector Exp1
forall a. Vector a -> Int -> a
V.! Int
0   in --return vector
    let loop :: Int -> Int -> [Int]
loop Int
i Int
j =
         if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Vector Exp1 -> Int
forall a. Vector a -> Int
V.length Vector Exp1
firstTuple)
          then []
          else
            let res :: Bool
res =
                 if((Var, Int, Int) -> Map (Var, Int, Int) Bool -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef, Int
i, Int
j) Map (Var, Int, Int) Bool
testedPositions)
                  then Map (Var, Int, Int) Bool
testedPositions  Map (Var, Int, Int) Bool -> (Var, Int, Int) -> Bool
forall k a. Ord k => Map k a -> k -> a
M.!  (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef, Int
i, Int
j)
                  else  Map (Var, Int, Int) Bool
testedPositions  Map (Var, Int, Int) Bool -> (Var, Int, Int) -> Bool
forall k a. Ord k => Map k a -> k -> a
M.!  (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef, Int
j, Int
i)
            in if Bool
res
              then [Int
j] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
L.++ (Int -> Int -> [Int]
loop Int
i (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
              else  Int -> Int -> [Int]
loop Int
i (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

        candidates :: [(Int, Int)]
candidates = ([(Int, Int)] -> Int -> Exp1 -> [(Int, Int)])
-> [(Int, Int)] -> Vector Exp1 -> [(Int, Int)]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
          (\[(Int, Int)]
ls Int
idx Exp1
_ ->
            let matches :: Vector Int
matches = [Int] -> Vector Int
forall a. [a] -> Vector a
V.fromList(Int -> Int -> [Int]
loop Int
idx (Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
                cands :: [(Int, Int)]
cands =  (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
L.map (Int
idx,) (Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList Vector Int
matches)  --`debug` (show matches)
            in ([(Int, Int)]
ls [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
L.++ [(Int, Int)]
cands)
          ) [] Vector Exp1
firstTuple

        ncols :: Int
ncols = Vector Exp1 -> Int
forall a. Vector a -> Int
V.length Vector Exp1
firstTuple
        nrows :: Int
nrows = Vector (Vector Exp1) -> Int
forall a. Vector a -> Int
V.length Vector (Vector Exp1)
outputTuples
        initialMap :: Map Int [Int]
initialMap = [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((Int -> (Int, [Int])) -> [Int] -> [(Int, [Int])]
forall a b. (a -> b) -> [a] -> [b]
L.map (, []) [Int
0..(Int
ncolsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)])
    --    tricky!
        finalMap :: Map Int [Int]
finalMap = (Map Int [Int] -> (Int, Int) -> Map Int [Int])
-> Map Int [Int] -> [(Int, Int)] -> Map Int [Int]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl
            (\Map Int [Int]
mp (Int
i, Int
j) ->
              let k :: Int
k = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl
                    (\Int
k Int
idx -> if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= -Int
1
                       then Int
k
                       else
                         case Int -> Map Int [Int] -> Maybe [Int]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idx Map Int [Int]
mp of
                           Maybe [Int]
Nothing -> Int
k
                           Just [Int]
ls ->
                             case Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
i [Int]
ls of
                                Maybe Int
Nothing -> Int
k
                                Maybe Int
otherwise -> Int
idx
                    ) (-Int
1) [Int
0..Int
i]
                  mp' :: Map Int [Int]
mp' = Int -> Map Int [Int] -> Map Int [Int]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Int
j Map Int [Int]
mp
              in if Int
kInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1
                  then Int -> [Int] -> Map Int [Int] -> Map Int [Int]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i ((Map Int [Int]
mp' Map Int [Int] -> Int -> [Int]
forall k a. Ord k => Map k a -> k -> a
M.! Int
i) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
L.++ [Int
j] ) Map Int [Int]
mp'
                  else Int -> [Int] -> Map Int [Int] -> Map Int [Int]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
k ((Map Int [Int]
mp' Map Int [Int] -> Int -> [Int]
forall k a. Ord k => Map k a -> k -> a
M.! Int
k) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
L.++ [Int
j] ) Map Int [Int]
mp'
            ) Map Int [Int]
initialMap [(Int, Int)]
candidates

        removedPositions_ :: [Int]
removedPositions_ = ([Int] -> Int -> [Int]) -> [Int] -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl
           (\[Int]
ls Int
i ->
            case Int -> Map Int [Int] -> Maybe [Int]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
i Map Int [Int]
finalMap of
              Maybe [Int]
Nothing -> [Int]
ls [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
L.++[Int
i]
              Maybe [Int]
otherwise -> [Int]
ls
          ) [] [Int
0..(Int
ncolsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]

        removedPositions :: [Int]
removedPositions =
           Set Int -> [Int]
forall a. Set a -> [a]
S.toList (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.union
               ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList [Int]
removedPositions_)
               ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
S.fromList (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Int
x,Int
y)->Int
x )  (Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int Int
outputsFromInputs) )))
        newFunType :: ([Ty1], Ty1)
newFunType =
          let oldOutTypesList :: Vector Ty1
oldOutTypesList = [Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList (
                case ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd(FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
fdef) of ProdTy [Ty1]
ls->[Ty1]
ls)
              newOutTypesList :: [Ty1]
newOutTypesList = ([Ty1] -> Int -> Ty1 -> [Ty1]) -> [Ty1] -> Vector Ty1 -> [Ty1]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
                (\[Ty1]
ls Int
idx Ty1
ty ->
                   case Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
idx [Int]
removedPositions of
                      Maybe Int
Nothing -> [Ty1]
ls [Ty1] -> [Ty1] -> [Ty1]
forall a. [a] -> [a] -> [a]
L.++[Ty1
ty]
                      Maybe Int
otherwise-> [Ty1]
ls
                ) [] Vector Ty1
oldOutTypesList
          in (([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst(FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
fdef), [Ty1] -> Ty1
forall loc. [UrTy loc] -> UrTy loc
ProdTy [Ty1]
newOutTypesList )

        newOutputTuples :: Vector Exp1
newOutputTuples = (Vector Exp1 -> Exp1) -> Vector (Vector Exp1) -> Vector Exp1
forall a b. (a -> b) -> Vector a -> Vector b
V.map Vector Exp1 -> Exp1
removeDropped Vector (Vector Exp1)
outputTuples
          where
            removeDropped :: Vector Exp1 -> Exp1
removeDropped Vector Exp1
ls = [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
[PreExp ext loc dec] -> PreExp ext loc dec
MkProdE (([Exp1] -> Int -> Exp1 -> [Exp1])
-> [Exp1] -> Vector Exp1 -> [Exp1]
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
               (\[Exp1]
ls Int
idx Exp1
exp ->
                  case Int -> [Int] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Int
idx [Int]
removedPositions of
                    Maybe Int
Nothing -> [Exp1]
ls [Exp1] -> [Exp1] -> [Exp1]
forall a. [a] -> [a] -> [a]
L.++[Exp1
exp]
                    Maybe Int
otherwise -> [Exp1]
ls
               ) [] Vector Exp1
ls)

        newFunBody :: Exp1
newFunBody = case (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
fdef) of
          CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls ->
              let ls' :: [(String, [(Var, ())], Exp1)]
ls' = Vector (String, [(Var, ())], Exp1) -> [(String, [(Var, ())], Exp1)]
forall a. Vector a -> [a]
V.toList ((Int -> (String, [(Var, ())], Exp1) -> (String, [(Var, ())], Exp1))
-> Vector (String, [(Var, ())], Exp1)
-> Vector (String, [(Var, ())], Exp1)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
V.imap
                   (\Int
idx (String
x, [(Var, ())]
y, Exp1
exp)->
                        let exp' :: Exp1
exp' = Exp1 -> Exp1 -> Exp1
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
replaceLeafExp Exp1
exp (Vector Exp1
newOutputTuples Vector Exp1 -> Int -> Exp1
forall a. Vector a -> Int -> a
V.! Int
idx)
                        in (String
x, [(Var, ())]
y, Exp1
exp')) ([(String, [(Var, ())], Exp1)] -> Vector (String, [(Var, ())], Exp1)
forall a. [a] -> Vector a
V.fromList [(String, [(Var, ())], Exp1)]
ls))
              in  Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls'
        fdef' :: FunDef1
fdef' = FunDef1
fdef{funBody :: Exp1
funBody = Exp1
newFunBody, funTy :: ArrowTy (TyOf Exp1)
funTy = ([Ty1], Ty1)
ArrowTy (TyOf Exp1)
newFunType}

        redirectMap :: Map Int Int
redirectMap = (Map Int Int -> Int -> (Int, [Int]) -> Map Int Int)
-> Map Int Int -> Vector (Int, [Int]) -> Map Int Int
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl
            (\Map Int Int
mp Int
idx (Int
i, [Int]
ls)->
                let mp' :: Map Int Int
mp'  = Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
i Int
idx Map Int Int
mp
                    mp'' :: Map Int Int
mp'' = (Map Int Int -> Int -> Map Int Int)
-> Map Int Int -> [Int] -> Map Int Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Map Int Int
m Int
j -> Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
j Int
idx Map Int Int
m) Map Int Int
mp' [Int]
ls
                in Map Int Int
mp''
            ) Map Int Int
forall k a. Map k a
M.empty ([(Int, [Int])] -> Vector (Int, [Int])
forall a. [a] -> Vector a
V.fromList (Map Int [Int] -> [(Int, [Int])]
forall k a. Map k a -> [(k, a)]
M.toList Map Int [Int]
finalMap))

        removedUnhandled :: [Int]
removedUnhandled = ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Int
a, Int
b)->Int
a) (Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int Int
outputsFromInputs)
        redirectMap' :: Map Int Int
redirectMap'  = (Map Int Int -> Int -> Map Int Int)
-> Map Int Int -> [Int] -> Map Int Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Map Int Int
mp Int
i->Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Int
i Map Int Int
mp) Map Int Int
redirectMap [Int]
removedUnhandled
        redirectMap'' :: Map Int Int
redirectMap''  = (Int -> Int) -> Map Int Int -> Map Int Int
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\Int
v -> Int
vInt -> Int -> Int
forall a. Num a => a -> a -> a
- (Int -> Int
countLess Int
v)) Map Int Int
redirectMap'
          where
            countLess :: Int -> Int
countLess Int
v = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Int
res Int
a-> if (Int
aInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
v) then Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
res else Int
res)
               Int
0 [Int]
removedUnhandled

        fdef'' :: FunDef1
fdef'' =
          FunDef1
fdef'{funName :: Var
funName =
             if (Exp1
newFunBody Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
== FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
fdef)
                     then FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef'
                     else String -> Var
toVar (Var -> String
fromVar (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef') String -> String -> String
forall a. [a] -> [a] -> [a]
L.++String
"outputFixed" )
              }
    in (FunDef1
fdef'',  Map Int Int
redirectMap'', Map Int Int
outputsFromInputs) --`debug` ("summer for " L.++ (show (funName fdef')) L.++ (show  outputsFromInputs ))

 where
  replaceLeafExp :: PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
replaceLeafExp PreExp ext loc dec
exp PreExp ext loc dec
replacement =
    case PreExp ext loc dec
exp of
      LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
bind) PreExp ext loc dec
body ->
          (Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
bind) (PreExp ext loc dec -> PreExp ext loc dec -> PreExp ext loc dec
replaceLeafExp PreExp ext loc dec
body PreExp ext loc dec
replacement)
      MkProdE [PreExp ext loc dec]
ls -> PreExp ext loc dec
replacement

  collectOutputs :: PreExp ext loc dec -> [Vector (PreExp ext loc dec)]
collectOutputs PreExp ext loc dec
exp = case PreExp ext loc dec
exp of
    CaseE PreExp ext loc dec
e [(String, [(Var, loc)], PreExp ext loc dec)]
ls ->
         ((String, [(Var, loc)], PreExp ext loc dec)
 -> Vector (PreExp ext loc dec))
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> [Vector (PreExp ext loc dec)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
x, [(Var, loc)]
y, PreExp ext loc dec
subBody) -> [PreExp ext loc dec] -> Vector (PreExp ext loc dec)
forall a. [a] -> Vector a
V.fromList(PreExp ext loc dec -> [PreExp ext loc dec]
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> [PreExp ext loc dec]
extractLeafTuple PreExp ext loc dec
subBody)) [(String, [(Var, loc)], PreExp ext loc dec)]
ls
     where
        extractLeafTuple :: PreExp ext loc dec -> [PreExp ext loc dec]
extractLeafTuple PreExp ext loc dec
exp =
           case PreExp ext loc dec
exp of
              LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
bind) PreExp ext loc dec
body -> PreExp ext loc dec -> [PreExp ext loc dec]
extractLeafTuple PreExp ext loc dec
body
              MkProdE [PreExp ext loc dec]
ls -> [PreExp ext loc dec]
ls
              PreExp ext loc dec
_ -> String -> [PreExp ext loc dec]
forall a. HasCallStack => String -> a
error String
"not expected expression"

    PreExp ext loc dec
_ -> String -> [Vector (PreExp ext loc dec)]
forall a. HasCallStack => String -> a
errorString
"should be case expression"

eliminateInputArgs :: FunDefs1 -> Var -> M.Map Int Int -> (Var, FunDefs1)
eliminateInputArgs :: FunDefs1 -> Var -> Map Int Int -> (Var, FunDefs1)
eliminateInputArgs FunDefs1
fdefs Var
fNameOld Map Int Int
syncedArgs =
  let newName :: Var
newName = String -> Var
toVar (((String -> Int -> Int -> String) -> String -> Map Int Int -> String
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey String -> Int -> Int -> String
forall {a} {a}. (Show a, Show a) => String -> a -> a -> String
buildName ((Var -> String
fromVar Var
fNameOld) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"elimpass_") Map Int Int
syncedArgs)String -> String -> String
forall a. [a] -> [a] -> [a]
L.++String
"_elimpass")
      fdefs' :: FunDefs1
fdefs' =
            if Var -> FunDefs1 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Var
newName FunDefs1
fdefs
              then FunDefs1
fdefs
              else
                   let oldFdef :: FunDef1
oldFdef = FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fNameOld
                       oldInputType :: [Ty1]
oldInputType = ([Ty1], Ty1) -> [Ty1]
forall a b. (a, b) -> a
fst (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
oldFdef)
                       oldArgs :: [Var]
oldArgs = FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
oldFdef
                       oldBody :: Exp1
oldBody = FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
oldFdef
                       newInputType :: [Ty1]
newInputType =
                         Vector Ty1 -> [Ty1]
forall a. Vector a -> [a]
V.toList
                           ((Int -> Ty1 -> Bool) -> Vector Ty1 -> Vector Ty1
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter
                              (\Int
idx Ty1
_ -> Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
idx Map Int Int
syncedArgs)
                              ([Ty1] -> Vector Ty1
forall a. [a] -> Vector a
V.fromList [Ty1]
oldInputType)
                           )
                       newArgs :: [Var]
newArgs =
                         Vector Var -> [Var]
forall a. Vector a -> [a]
V.toList
                           ((Int -> Var -> Bool) -> Vector Var -> Vector Var
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter
                              (\Int
idx Var
_ -> Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
idx Map Int Int
syncedArgs)
                               ([Var] -> Vector Var
forall a. [a] -> Vector a
V.fromList [Var]
oldArgs)
                           )
                       newBody :: Exp1
newBody =
                         (Exp1 -> Int -> Int -> Exp1) -> Exp1 -> Map Int Int -> Exp1
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey
                           (\Exp1
exp Int
k Int
v ->
                              if (Int
vInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1000)
                              then
                                let oldExp :: Exp1
oldExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (([Var] -> Vector Var
forall a. [a] -> Vector a
V.fromList [Var]
oldArgs) Vector Var -> Int -> Var
forall a. Vector a -> Int -> a
V.! Int
k)
                                    newExp :: Exp1
newExp = Var -> Exp1
forall (ext :: * -> * -> *) loc dec. Var -> PreExp ext loc dec
VarE (([Var] -> Vector Var
forall a. [a] -> Vector a
V.fromList [Var]
oldArgs) Vector Var -> Int -> Var
forall a. Vector a -> Int -> a
V.! Int
v)
                                 in Exp1 -> Exp1 -> Exp1 -> Exp1
forall (e :: * -> * -> *) l d.
HasSubstitutable e l d =>
PreExp e l d -> PreExp e l d -> PreExp e l d -> PreExp e l d
substE Exp1
oldExp Exp1
newExp Exp1
exp
                              else
                                Exp1
exp
                              )
                           (Exp1
oldBody)
                           Map Int Int
syncedArgs
                       newFdef :: FunDef1
newFdef =
                         FunDef1
oldFdef
                           { funBody :: Exp1
funBody = Exp1 -> Exp1
cleanExp Exp1
newBody
                           , funArgs :: [Var]
funArgs = [Var]
newArgs
                           , funTy :: ArrowTy (TyOf Exp1)
funTy = ([Ty1]
newInputType, ([Ty1], Ty1) -> Ty1
forall a b. (a, b) -> b
snd (FunDef1 -> ArrowTy (TyOf Exp1)
forall ex. FunDef ex -> ArrowTy (TyOf ex)
funTy FunDef1
oldFdef))
                           , funName :: Var
funName = Var
newName
                           }
                    in Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Var
newName FunDef1
newFdef FunDefs1
fdefs
  in (Var
newName, FunDefs1
fdefs')
 where
    buildName :: String -> a -> a -> String
buildName String
name a
i a
j =
      String
name String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_sync" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (a -> String
forall a. Show a => a -> String
show a
i) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"_fr_" String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (a -> String
forall a. Show a => a -> String
show a
j) String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ String
"sync_"

-- simplest version for single functions
getOutputsFromInput ::FunDef1 -> M.Map Int Int
getOutputsFromInput :: FunDef1 -> Map Int Int
getOutputsFromInput FunDef1
func  =
  let body :: Exp1
body = FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
func
      leafProducts :: [[Exp1]]
leafProducts = case Exp1
body of
            CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls ->
               ((String, [(Var, ())], Exp1) -> [Exp1])
-> [(String, [(Var, ())], Exp1)] -> [[Exp1]]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
_,[(Var, ())]
_,Exp1
exp) -> Exp1 -> [Exp1]
getLeafProdExpressions Exp1
exp) [(String, [(Var, ())], Exp1)]
ls
      inputVars :: [Var]
inputVars = FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
func
      candidatesList :: [Map Int Int]
candidatesList =

       ([Exp1] -> Map Int Int) -> [[Exp1]] -> [Map Int Int]
forall a b. (a -> b) -> [a] -> [b]
L.map(\[Exp1]
exprList->
          (Map Int Int -> Int -> Exp1 -> Map Int Int)
-> Map Int Int -> Vector Exp1 -> Map Int Int
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl Map Int Int -> Int -> Exp1 -> Map Int Int
f Map Int Int
forall k a. Map k a
M.empty ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
exprList)) [[Exp1]]
leafProducts
         where f :: Map Int Int -> Int -> Exp1 -> Map Int Int
f Map Int Int
out Int
idx Exp1
outExp =
                case Exp1
outExp of
                    VarE Var
v ->
                      case Var -> [Var] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
L.elemIndex Var
v [Var]
inputVars of
                        Maybe Int
Nothing -> Map Int Int
out
                        Just Int
argIdx -> Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
idx Int
argIdx Map Int Int
out
                    Exp1
otherwise -> Map Int Int
out
      candidatesListSets :: [Set (Int, Int)]
candidatesListSets = (Map Int Int -> Set (Int, Int))
-> [Map Int Int] -> [Set (Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\Map Int Int
mp-> [(Int, Int)] -> Set (Int, Int)
forall a. Ord a => [a] -> Set a
S.fromList (Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int Int
mp)) [Map Int Int]
candidatesList
      intersectionsSet :: Set (Int, Int)
intersectionsSet = (Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int))
-> Set (Int, Int) -> [Set (Int, Int)] -> Set (Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl Set (Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => Set a -> Set a -> Set a
S.intersection ([Set (Int, Int)] -> Set (Int, Int)
forall a. HasCallStack => [a] -> a
L.head [Set (Int, Int)]
candidatesListSets) [Set (Int, Int)]
candidatesListSets
      in [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (Set (Int, Int) -> [(Int, Int)]
forall a. Set a -> [a]
S.toList Set (Int, Int)
intersectionsSet)

getLeafProdExpressions :: Exp1 -> [Exp1]
getLeafProdExpressions :: Exp1 -> [Exp1]
getLeafProdExpressions = Exp1 -> [Exp1]
forall {ext :: * -> * -> *} {loc} {dec}.
PreExp ext loc dec -> [PreExp ext loc dec]
rec
 where
   rec :: PreExp ext loc dec -> [PreExp ext loc dec]
rec PreExp ext loc dec
ex =
     case PreExp ext loc dec
ex of
       LetE (Var
v, [loc]
ls, dec
t, AppE{}) PreExp ext loc dec
body -> PreExp ext loc dec -> [PreExp ext loc dec]
rec PreExp ext loc dec
body
       MkProdE [PreExp ext loc dec]
ls -> [PreExp ext loc dec]
ls
       PreExp ext loc dec
x-> []


removeRedundantInputExp :: FunDefs1 -> Exp1 -> Bool -> (FunDefs1,Exp1)
removeRedundantInputExp :: FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefs Exp1
exp  Bool
mode =
  case Exp1
exp of
    CaseE Exp1
e [(String, [(Var, ())], Exp1)]
ls ->
      let (FunDefs1
fdefs', Exp1
e') = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefs Exp1
e Bool
mode
          (FunDefs1
fdefs'', [(String, [(Var, ())], Exp1)]
ls') = ((FunDefs1, [(String, [(Var, ())], Exp1)])
 -> (String, [(Var, ())], Exp1)
 -> (FunDefs1, [(String, [(Var, ())], Exp1)]))
-> (FunDefs1, [(String, [(Var, ())], Exp1)])
-> [(String, [(Var, ())], Exp1)]
-> (FunDefs1, [(String, [(Var, ())], Exp1)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (FunDefs1, [(String, [(Var, ())], Exp1)])
-> (String, [(Var, ())], Exp1)
-> (FunDefs1, [(String, [(Var, ())], Exp1)])
f (FunDefs1
fdefs', []) [(String, [(Var, ())], Exp1)]
ls
            where
              f :: (FunDefs1, [(String, [(Var, ())], Exp1)])
-> (String, [(Var, ())], Exp1)
-> (FunDefs1, [(String, [(Var, ())], Exp1)])
f (FunDefs1
fdefsInner, [(String, [(Var, ())], Exp1)]
lsInner) (String
dataCon, [(Var, ())]
vars, Exp1
exp) =
                let (FunDefs1
fdefsInner', Exp1
exp') = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefsInner Exp1
exp Bool
mode
                 in (FunDefs1
fdefsInner', [(String, [(Var, ())], Exp1)]
lsInner [(String, [(Var, ())], Exp1)]
-> [(String, [(Var, ())], Exp1)] -> [(String, [(Var, ())], Exp1)]
forall a. [a] -> [a] -> [a]
L.++ [(String
dataCon, [(Var, ())]
vars, Exp1
exp')])
       in (FunDefs1
fdefs'', Exp1 -> [(String, [(Var, ())], Exp1)] -> Exp1
forall (ext :: * -> * -> *) loc dec.
PreExp ext loc dec
-> [(String, [(Var, loc)], PreExp ext loc dec)]
-> PreExp ext loc dec
CaseE Exp1
e' [(String, [(Var, ())], Exp1)]
ls')

    LetE rhs :: (Var, [()], Ty1, Exp1)
rhs@(Var
var, [()]
ls, Ty1
t, Exp1
bind) Exp1
body ->

      let (FunDefs1
fdefs', Exp1
body') = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefs Exp1
body Bool
mode
          boringCase :: (FunDefs1, Exp1)
boringCase =  (FunDefs1
fdefs', ((Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var, [()], Ty1, Exp1)
rhs  Exp1
body'))
      in (case Exp1
bind of
          x :: Exp1
x@( AppE Var
fName [()]
loc [Exp1]
args) ->
            if (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_TUP"  (Var -> String
fromVar Var
fName) Bool -> Bool -> Bool
||
                String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_FUS" (Var -> String
fromVar Var
fName) )
                then

                  let redundantPositions :: Map Int Int
redundantPositions =
                       if(Bool
mode)
                        then
                          (Map Exp1 Int, Map Int Int) -> Map Int Int
forall a b. (a, b) -> b
snd( ((Map Exp1 Int, Map Int Int)
 -> Int -> Exp1 -> (Map Exp1 Int, Map Int Int))
-> (Map Exp1 Int, Map Int Int)
-> Vector Exp1
-> (Map Exp1 Int, Map Int Int)
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl (Map Exp1 Int, Map Int Int)
-> Int -> Exp1 -> (Map Exp1 Int, Map Int Int)
forall {k} {a}.
(Ord k, Ord a) =>
(Map k a, Map a a) -> a -> k -> (Map k a, Map a a)
findRedundantPos (Map Exp1 Int
forall k a. Map k a
M.empty, Map Int Int
forall k a. Map k a
M.empty) ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
args))
                        else
                           (Map Int Int -> Int -> Exp1 -> Map Int Int)
-> Map Int Int -> Vector Exp1 -> Map Int Int
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl (Var -> Map Int Int -> Int -> Exp1 -> Map Int Int
findRedundantPos_UnusedArgs Var
fName) Map Int Int
forall k a. Map k a
M.empty ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
args)
                        --        redundantPositions3 = M.union redundantPositions2 redundantPositions `debug`
                        -- ("checking call to :" L.++ (show fName) L.++ "opppaaaa" L.++ show redundantPositions2)
                  in
                   if Map Int Int -> Bool
forall k a. Map k a -> Bool
M.null Map Int Int
redundantPositions
                    then
                      (FunDefs1, Exp1)
boringCase
                    else

                      let (Var
fNameNew, FunDefs1
fdefsNew) =
                            FunDefs1 -> Var -> Map Int Int -> (Var, FunDefs1)
eliminateInputArgs  FunDefs1
fdefs' Var
fName  Map Int Int
redundantPositions
                          newCall :: Exp1
newCall =
                            Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fNameNew [()]
loc
                              (Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList
                                ((Int -> Exp1 -> Bool) -> Vector Exp1 -> Vector Exp1
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter
                                  (\Int
idx Exp1
_ -> Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
idx  Map Int Int
redundantPositions )
                                     ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
args)))
                      in (FunDefs1
fdefsNew,((Var, [()], Ty1, Exp1) -> Exp1 -> Exp1
forall (ext :: * -> * -> *) loc dec.
(Var, [loc], dec, PreExp ext loc dec)
-> PreExp ext loc dec -> PreExp ext loc dec
LetE (Var
var, [()]
ls, Ty1
t, Exp1
newCall) Exp1
body' ))
                else
                  (FunDefs1, Exp1)
boringCase
          Exp1
otherwise -> (FunDefs1, Exp1)
boringCase)

    x :: Exp1
x@(AppE Var
fName [()]
loc [Exp1]
args) ->
            if (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_TUP"  (Var -> String
fromVar Var
fName) Bool -> Bool -> Bool
||
                String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"_FUS" (Var -> String
fromVar Var
fName) )
                then
                  let redundantPositions :: Map Int Int
redundantPositions =
                       if(Bool
mode)
                        then
                          (Map Exp1 Int, Map Int Int) -> Map Int Int
forall a b. (a, b) -> b
snd( ((Map Exp1 Int, Map Int Int)
 -> Int -> Exp1 -> (Map Exp1 Int, Map Int Int))
-> (Map Exp1 Int, Map Int Int)
-> Vector Exp1
-> (Map Exp1 Int, Map Int Int)
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl (Map Exp1 Int, Map Int Int)
-> Int -> Exp1 -> (Map Exp1 Int, Map Int Int)
forall {k} {a}.
(Ord k, Ord a) =>
(Map k a, Map a a) -> a -> k -> (Map k a, Map a a)
findRedundantPos (Map Exp1 Int
forall k a. Map k a
M.empty, Map Int Int
forall k a. Map k a
M.empty) ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
args))
                        else
                           (Map Int Int -> Int -> Exp1 -> Map Int Int)
-> Map Int Int -> Vector Exp1 -> Map Int Int
forall a b. (a -> Int -> b -> a) -> a -> Vector b -> a
V.ifoldl (Var -> Map Int Int -> Int -> Exp1 -> Map Int Int
findRedundantPos_UnusedArgs Var
fName) Map Int Int
forall k a. Map k a
M.empty ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
args)
                        --        redundantPositions3 = M.union redundantPositions2 redundantPositions `debug`
                        -- ("checking call to :" L.++ (show fName) L.++ "opppaaaa" L.++ show redundantPositions2)
                  in
                   if Map Int Int -> Bool
forall k a. Map k a -> Bool
M.null Map Int Int
redundantPositions
                    then
                      (FunDefs1
fdefs, Exp1
x)
                    else
                      let (Var
fNameNew, FunDefs1
fdefsNew) =
                            FunDefs1 -> Var -> Map Int Int -> (Var, FunDefs1)
eliminateInputArgs  FunDefs1
fdefs Var
fName  Map Int Int
redundantPositions
                          newCall :: Exp1
newCall =
                            Var -> [()] -> [Exp1] -> Exp1
forall (ext :: * -> * -> *) loc dec.
Var -> [loc] -> [PreExp ext loc dec] -> PreExp ext loc dec
AppE Var
fNameNew [()]
loc
                              (Vector Exp1 -> [Exp1]
forall a. Vector a -> [a]
V.toList
                                ((Int -> Exp1 -> Bool) -> Vector Exp1 -> Vector Exp1
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
V.ifilter
                                  (\Int
idx Exp1
_ -> Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember Int
idx  Map Int Int
redundantPositions )
                                     ([Exp1] -> Vector Exp1
forall a. [a] -> Vector a
V.fromList [Exp1]
args)))
                      in (FunDefs1
fdefsNew,Exp1
newCall)
                else
                   (FunDefs1
fdefs, Exp1
x)
    Exp1
otherwise ->  (FunDefs1
fdefs, Exp1
otherwise)
   where
        findRedundantPos :: (Map k a, Map a a) -> a -> k -> (Map k a, Map a a)
findRedundantPos (Map k a
firstAppear, Map a a
redundant) a
argIdx k
arg =
            if k -> Map k a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member k
arg Map k a
firstAppear
                then
                  (Map k a
firstAppear, a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
argIdx (Map k a
firstAppear Map k a -> k -> a
forall k a. Ord k => Map k a -> k -> a
M.! k
arg) Map a a
redundant)
                else
                  (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
arg a
argIdx Map k a
firstAppear, Map a a
redundant)

        findRedundantPos_UnusedArgs :: Var -> Map Int Int -> Int -> Exp1 -> Map Int Int
findRedundantPos_UnusedArgs Var
fName Map Int Int
mp Int
argIdx Exp1
arg =
           let callee :: FunDef1
callee = FunDefs1
fdefs FunDefs1 -> Var -> FunDef1
forall k a. Ord k => Map k a -> k -> a
M.! Var
fName in
           if (Exp1 -> Var -> Bool
forall {loc} {dec} {ext :: * -> * -> *}.
(Show loc, Show dec, Show (ext loc dec)) =>
PreExp ext loc dec -> Var -> Bool
isUsedArg (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
callee)  (([Var] -> Vector Var
forall a. [a] -> Vector a
V.fromList (FunDef1 -> [Var]
forall ex. FunDef ex -> [Var]
funArgs FunDef1
callee)) Vector Var -> Int -> Var
forall a. Vector a -> Int -> a
V.! Int
argIdx ))
              then Map Int Int
mp
              else Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
argIdx Int
100000 Map Int Int
mp

        isUsedArg :: PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
exp Var
var =
          case PreExp ext loc dec
exp of
            ProjE Int
i PreExp ext loc dec
e  ->
              PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
e Var
var

            VarE Var
v'    ->
              Var
v' Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
var

            CaseE PreExp ext loc dec
e [(String, [(Var, loc)], PreExp ext loc dec)]
ls ->
              let b1 :: Bool
b1 = PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
e Var
var
                  b2 :: Bool
b2 =
                    (Bool -> (String, [(Var, loc)], PreExp ext loc dec) -> Bool)
-> Bool -> [(String, [(Var, loc)], PreExp ext loc dec)] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
res (String
dataCon, [(Var, loc)]
vars, PreExp ext loc dec
ex)->
                                (Bool
res Bool -> Bool -> Bool
|| PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
ex Var
var ))
                            Bool
False [(String, [(Var, loc)], PreExp ext loc dec)]
ls
              in Bool
b1 Bool -> Bool -> Bool
|| Bool
b2


            AppE Var
fName [loc]
loc [PreExp ext loc dec]
args ->
                (Bool -> PreExp ext loc dec -> Bool)
-> Bool -> [PreExp ext loc dec] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
res PreExp ext loc dec
ex -> (Bool
res Bool -> Bool -> Bool
|| PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
ex Var
var )) Bool
False [PreExp ext loc dec]
args

            LetE (Var
v, [loc]
ls, dec
t, PreExp ext loc dec
bind) PreExp ext loc dec
body -> (PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
bind Var
var)Bool -> Bool -> Bool
|| (PreExp ext loc dec -> Var -> Bool
isUsedArg  PreExp ext loc dec
body Var
var)
            PrimAppE Prim dec
p [PreExp ext loc dec]
ls ->  (Bool -> PreExp ext loc dec -> Bool)
-> Bool -> [PreExp ext loc dec] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
res PreExp ext loc dec
ex -> (Bool
res Bool -> Bool -> Bool
|| PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
ex Var
var )) Bool
False [PreExp ext loc dec]
ls
            MkProdE [PreExp ext loc dec]
ls    ->  (Bool -> PreExp ext loc dec -> Bool)
-> Bool -> [PreExp ext loc dec] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
res PreExp ext loc dec
ex -> (Bool
res Bool -> Bool -> Bool
|| PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
ex Var
var )) Bool
False [PreExp ext loc dec]
ls
            DataConE loc
_ String
_ [PreExp ext loc dec]
ls-> (Bool -> PreExp ext loc dec -> Bool)
-> Bool -> [PreExp ext loc dec] -> Bool
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (\Bool
res PreExp ext loc dec
ex -> (Bool
res Bool -> Bool -> Bool
|| PreExp ext loc dec -> Var -> Bool
isUsedArg PreExp ext loc dec
ex Var
var )) Bool
False [PreExp ext loc dec]
ls

            PreExp ext loc dec
x       -> Bool
False Bool -> String -> Bool
forall {c}. c -> String -> c
`debug` (String
"not handled is "String -> String -> String
forall a. [a] -> [a] -> [a]
L.++ (PreExp ext loc dec -> String
forall a. Show a => a -> String
show PreExp ext loc dec
x))


removeRedundantInputsMainExp :: FunDefs1 -> Exp1 -> (FunDefs1, Exp1)
removeRedundantInputsMainExp :: FunDefs1 -> Exp1 -> (FunDefs1, Exp1)
removeRedundantInputsMainExp FunDefs1
fdefs Exp1
expInput =

  let (FunDefs1
fdefs', Exp1
exp) = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefs Exp1
expInput Bool
True
    --   `debug` ("Dowing1"L.++ (render (pprint expInput)))
      (FunDefs1
fdefs'', Exp1
exp') = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefs' Exp1
exp Bool
False

  in (FunDefs1
fdefs'', Exp1
exp')

removeRedundantInputFunc :: FunDefs1 -> FunDef1 -> FunDefs1
removeRedundantInputFunc :: FunDefs1 -> FunDef1 -> FunDefs1
removeRedundantInputFunc FunDefs1
fdefs FunDef1
fdef =
  let (FunDefs1
fdefs', Exp1
exp) = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp FunDefs1
fdefs (FunDef1 -> Exp1
forall ex. FunDef ex -> ex
funBody FunDef1
fdef) Bool
True
      --  `debug` ("Dowing1"L.++ (show (funName fdef)))
      fdef' :: FunDef1
fdef' = FunDef1
fdef {funBody :: Exp1
funBody = Exp1
exp}
      (FunDefs1
fdefs'', Exp1
exp') = FunDefs1 -> Exp1 -> Bool -> (FunDefs1, Exp1)
removeRedundantInputExp (Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef) FunDef1
fdef' FunDefs1
fdefs')
                          Exp1
exp Bool
False
      fdef'' :: FunDef1
fdef'' = FunDef1
fdef' {funBody :: Exp1
funBody = Exp1
exp'}-- `debug` ("Dowing2 "L.++ (render (pprint (fdef' {funBody = exp'}))))

  in (Var -> FunDef1 -> FunDefs1 -> FunDefs1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FunDef1 -> Var
forall ex. FunDef ex -> Var
funName FunDef1
fdef) FunDef1
fdef'' FunDefs1
fdefs'')

redundancy_input_pass_rec :: FunDefs1 -> Exp1->Int-> (Exp1, FunDefs1)
redundancy_input_pass_rec :: FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1)
redundancy_input_pass_rec FunDefs1
fdefs  Exp1
mainExp Int
depth=
  let fdefs' :: FunDefs1
fdefs' =
        (FunDefs1 -> FunDef1 -> FunDefs1)
-> FunDefs1 -> FunDefs1 -> FunDefs1
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl
          (\FunDefs1
fDefsInner FunDef1
fdef -> FunDefs1 -> FunDef1 -> FunDefs1
removeRedundantInputFunc FunDefs1
fDefsInner FunDef1
fdef)
          FunDefs1
fdefs
          FunDefs1
fdefs
  in let (FunDefs1
fdefs'', Exp1
mainExp') = FunDefs1 -> Exp1 -> (FunDefs1, Exp1)
removeRedundantInputsMainExp FunDefs1
fdefs' Exp1
mainExp
  in if (FunDefs1
fdefs'' FunDefs1 -> FunDefs1 -> Bool
forall a. Eq a => a -> a -> Bool
== FunDefs1
fdefs Bool -> Bool -> Bool
&& Exp1
mainExp'Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp1
mainExp) Bool -> Bool -> Bool
|| Int
depthInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5
        then ( Exp1
mainExp', FunDefs1
fdefs'')(Exp1, FunDefs1) -> String -> (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String
"no repeeat")
        else FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1)
redundancy_input_pass_rec FunDefs1
fdefs'' Exp1
mainExp' (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Exp1, FunDefs1) -> String -> (Exp1, FunDefs1)
forall {c}. c -> String -> c
`debug` (String
"repeeat")

redundancy_input_pass :: FunDefs1 -> Exp1-> Int-> (Exp1, FunDefs1)
redundancy_input_pass :: FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1)
redundancy_input_pass FunDefs1
fdefs  Exp1
mainExp Int
depth=
  let (Exp1
mainExp' , FunDefs1
fdefs'') = FunDefs1 -> Exp1 -> Int -> (Exp1, FunDefs1)
redundancy_input_pass_rec FunDefs1
fdefs Exp1
mainExp Int
0
  in if (FunDefs1
fdefs'' FunDefs1 -> FunDefs1 -> Bool
forall a. Eq a => a -> a -> Bool
== FunDefs1
fdefs Bool -> Bool -> Bool
&& Exp1
mainExp'Exp1 -> Exp1 -> Bool
forall a. Eq a => a -> a -> Bool
== Exp1
mainExp)
        then (Exp1
mainExp', FunDefs1
fdefs'')
        else FunDefs1 -> Exp1 -> Bool -> Int -> (Exp1, FunDefs1)
redundancy_output_pass FunDefs1
fdefs'' Exp1
mainExp' Bool
False (Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)