{-# LANGUAGE OverloadedStrings #-}
module Language.GLSL.Optimizer.Liveness where

import qualified Data.IntSet            as S
import qualified Data.Text.Lazy.Builder as LTB
import           Language.GLSL.AST


newtype Liveness = Liveness { Liveness -> IntSet
unLiveness :: S.IntSet }

empty :: Liveness
empty :: Liveness
empty = IntSet -> Liveness
Liveness IntSet
S.empty

instance Annot Liveness where
  parseAnnot :: Parser Liveness
parseAnnot = Liveness -> Parser Liveness
forall (f :: * -> *) a. Applicative f => a -> f a
pure Liveness
empty
  ppAnnot :: Liveness -> Maybe Builder
ppAnnot = Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder)
-> (Liveness -> Builder) -> Liveness -> Maybe Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
LTB.fromString (String -> Builder) -> (Liveness -> String) -> Liveness -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> String
forall a. Show a => a -> String
show ([Key] -> String) -> (Liveness -> [Key]) -> Liveness -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Key]
S.toList (IntSet -> [Key]) -> (Liveness -> IntSet) -> Liveness -> [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liveness -> IntSet
unLiveness


computeLiveness :: GLSL a -> GLSL Liveness
computeLiveness :: GLSL a -> GLSL Liveness
computeLiveness (GLSL Version
v [TopDecl a]
d) = Version -> [TopDecl Liveness] -> GLSL Liveness
forall a. Version -> [TopDecl a] -> GLSL a
GLSL Version
v ((TopDecl a -> TopDecl Liveness)
-> [TopDecl a] -> [TopDecl Liveness]
forall a b. (a -> b) -> [a] -> [b]
map TopDecl a -> TopDecl Liveness
forall a. TopDecl a -> TopDecl Liveness
clTopDecl [TopDecl a]
d)

clTopDecl :: TopDecl a -> TopDecl Liveness
clTopDecl :: TopDecl a -> TopDecl Liveness
clTopDecl (LayoutDecl LayoutSpec
s GlobalDecl
d) = LayoutSpec -> GlobalDecl -> TopDecl Liveness
forall a. LayoutSpec -> GlobalDecl -> TopDecl a
LayoutDecl LayoutSpec
s GlobalDecl
d
clTopDecl (GlobalDecl GlobalDecl
d) = GlobalDecl -> TopDecl Liveness
forall a. GlobalDecl -> TopDecl a
GlobalDecl GlobalDecl
d
clTopDecl (ProcDecl ProcName
name [ParamDecl]
params [StmtAnnot a]
ss) =
  ProcName -> [ParamDecl] -> [StmtAnnot Liveness] -> TopDecl Liveness
forall a. ProcName -> [ParamDecl] -> [StmtAnnot a] -> TopDecl a
ProcDecl ProcName
name [ParamDecl]
params ([StmtAnnot Liveness] -> TopDecl Liveness)
-> ([StmtAnnot a] -> [StmtAnnot Liveness])
-> [StmtAnnot a]
-> TopDecl Liveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StmtAnnot Liveness], Liveness) -> [StmtAnnot Liveness]
forall a b. (a, b) -> a
fst (([StmtAnnot Liveness], Liveness) -> [StmtAnnot Liveness])
-> ([StmtAnnot a] -> ([StmtAnnot Liveness], Liveness))
-> [StmtAnnot a]
-> [StmtAnnot Liveness]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
forall a.
Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
clStmtAnnots Liveness
empty ([StmtAnnot a] -> TopDecl Liveness)
-> [StmtAnnot a] -> TopDecl Liveness
forall a b. (a -> b) -> a -> b
$ [StmtAnnot a]
ss

clStmtAnnots :: Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
clStmtAnnots :: Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
clStmtAnnots Liveness
ls = (StmtAnnot a
 -> ([StmtAnnot Liveness], Liveness)
 -> ([StmtAnnot Liveness], Liveness))
-> ([StmtAnnot Liveness], Liveness)
-> [StmtAnnot a]
-> ([StmtAnnot Liveness], Liveness)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StmtAnnot a
-> ([StmtAnnot Liveness], Liveness)
-> ([StmtAnnot Liveness], Liveness)
forall a.
StmtAnnot a
-> ([StmtAnnot Liveness], Liveness)
-> ([StmtAnnot Liveness], Liveness)
clStmtAnnot ([], Liveness
ls)

clStmtAnnot
  :: StmtAnnot a
  -> ([StmtAnnot Liveness], Liveness)
  -> ([StmtAnnot Liveness], Liveness)
clStmtAnnot :: StmtAnnot a
-> ([StmtAnnot Liveness], Liveness)
-> ([StmtAnnot Liveness], Liveness)
clStmtAnnot (SA a
_ Stmt a
s) ([StmtAnnot Liveness]
ss, Liveness
ls) =
  let (Stmt Liveness
s', Liveness
ls') = Stmt a -> Liveness -> (Stmt Liveness, Liveness)
forall a. Stmt a -> Liveness -> (Stmt Liveness, Liveness)
clStmt Stmt a
s Liveness
ls in
  (Liveness -> Stmt Liveness -> StmtAnnot Liveness
forall a. a -> Stmt a -> StmtAnnot a
SA Liveness
ls' Stmt Liveness
s'StmtAnnot Liveness -> [StmtAnnot Liveness] -> [StmtAnnot Liveness]
forall a. a -> [a] -> [a]
:[StmtAnnot Liveness]
ss, Liveness
ls')

clStmt :: Stmt a -> Liveness -> (Stmt Liveness, Liveness)
clStmt :: Stmt a -> Liveness -> (Stmt Liveness, Liveness)
clStmt (AssignStmt Name
n Expr
e) Liveness
ls =
  (Name -> Expr -> Stmt Liveness
forall a. Name -> Expr -> Stmt a
AssignStmt Name
n Expr
e, Expr -> Liveness -> Liveness
clExpr Expr
e Liveness
ls)
clStmt (DeclStmt d :: LocalDecl
d@(LDecl Type
_ (NameId Key
n) Maybe Expr
e)) Liveness
ls =
  (LocalDecl -> Stmt Liveness
forall a. LocalDecl -> Stmt a
DeclStmt LocalDecl
d, Key -> Liveness -> Liveness
delete Key
n (Liveness -> Liveness)
-> (Liveness -> Liveness) -> Liveness -> Liveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Liveness -> Liveness)
-> (Expr -> Liveness -> Liveness)
-> Maybe Expr
-> Liveness
-> Liveness
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Liveness -> Liveness
forall a. a -> a
id Expr -> Liveness -> Liveness
clExpr Maybe Expr
e (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Liveness
ls)
clStmt (EmitStmt Emit
e) Liveness
ls =
  (Emit -> Stmt Liveness
forall a. Emit -> Stmt a
EmitStmt Emit
e, Emit -> Liveness -> Liveness
clEmit Emit
e Liveness
ls)
clStmt (IfStmt (NameId Key
c) [StmtAnnot a]
t [StmtAnnot a]
e) Liveness
ls =
  let ([StmtAnnot Liveness]
t', Liveness
lsT) = Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
forall a.
Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
clStmtAnnots Liveness
ls [StmtAnnot a]
t
      ([StmtAnnot Liveness]
e', Liveness
lsE) = Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
forall a.
Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)
clStmtAnnots Liveness
ls [StmtAnnot a]
e
  in
  (NameId
-> [StmtAnnot Liveness] -> [StmtAnnot Liveness] -> Stmt Liveness
forall a. NameId -> [StmtAnnot a] -> [StmtAnnot a] -> Stmt a
IfStmt (Key -> NameId
NameId Key
c) [StmtAnnot Liveness]
t' [StmtAnnot Liveness]
e', Key -> Liveness -> Liveness
insert Key
c (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Liveness
lsT Liveness -> Liveness -> Liveness
`union` Liveness
lsE)


clEmit :: Emit -> Liveness -> Liveness
clEmit :: Emit -> Liveness -> Liveness
clEmit Emit
EmitFragDepth    = Liveness -> Liveness
forall a. a -> a
id
clEmit (EmitPosition Expr
e) = Expr -> Liveness -> Liveness
clExpr Expr
e

clExpr :: Expr -> Liveness -> Liveness
clExpr :: Expr -> Liveness -> Liveness
clExpr (UnaryExpr UnaryOp
_ ExprAtom
e) Liveness
ls      = ExprAtom -> Liveness -> Liveness
clExprAtom ExprAtom
e Liveness
ls
clExpr (BinaryExpr ExprAtom
l BinaryOp
_ ExprAtom
r) Liveness
ls   = ExprAtom -> Liveness -> Liveness
clExprAtom ExprAtom
l (Liveness -> Liveness)
-> (Liveness -> Liveness) -> Liveness -> Liveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExprAtom -> Liveness -> Liveness
clExprAtom ExprAtom
r (Liveness -> Liveness) -> Liveness -> Liveness
forall a b. (a -> b) -> a -> b
$ Liveness
ls
clExpr (FunCallExpr FunName
_ [ExprAtom]
args) Liveness
ls = (ExprAtom -> Liveness -> Liveness)
-> Liveness -> [ExprAtom] -> Liveness
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ExprAtom -> Liveness -> Liveness
clExprAtom Liveness
ls [ExprAtom]
args
clExpr (TextureExpr ExprAtom
t ExprAtom
x ExprAtom
y) Liveness
ls  = (ExprAtom -> Liveness -> Liveness)
-> Liveness -> [ExprAtom] -> Liveness
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ExprAtom -> Liveness -> Liveness
clExprAtom Liveness
ls [ExprAtom
t, ExprAtom
x, ExprAtom
y]
clExpr (AtomExpr ExprAtom
e) Liveness
ls         = ExprAtom -> Liveness -> Liveness
clExprAtom ExprAtom
e Liveness
ls

clExprAtom :: ExprAtom -> Liveness -> Liveness
clExprAtom :: ExprAtom -> Liveness -> Liveness
clExprAtom (IdentifierExpr NameExpr
n) Liveness
ls         = NameExpr -> Liveness -> Liveness
clNameExpr NameExpr
n Liveness
ls
clExprAtom (SwizzleExpr (NameId Key
n) Swizzle
_) Liveness
ls = Key -> Liveness -> Liveness
insert Key
n Liveness
ls
clExprAtom ExprAtom
_ Liveness
ls                          = Liveness
ls

clNameExpr :: NameExpr -> Liveness -> Liveness
clNameExpr :: NameExpr -> Liveness -> Liveness
clNameExpr (NameExpr (Name Namespace
NsT (NameId Key
n))) Liveness
ls = Key -> Liveness -> Liveness
insert Key
n Liveness
ls
clNameExpr NameExpr
_ Liveness
ls                                = Liveness
ls

insert :: Int -> Liveness -> Liveness
insert :: Key -> Liveness -> Liveness
insert Key
n = IntSet -> Liveness
Liveness (IntSet -> Liveness)
-> (Liveness -> IntSet) -> Liveness -> Liveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> IntSet -> IntSet
S.insert Key
n (IntSet -> IntSet) -> (Liveness -> IntSet) -> Liveness -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liveness -> IntSet
unLiveness

delete :: Int -> Liveness -> Liveness
delete :: Key -> Liveness -> Liveness
delete Key
n = IntSet -> Liveness
Liveness (IntSet -> Liveness)
-> (Liveness -> IntSet) -> Liveness -> Liveness
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> IntSet -> IntSet
S.delete Key
n (IntSet -> IntSet) -> (Liveness -> IntSet) -> Liveness -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Liveness -> IntSet
unLiveness

union :: Liveness -> Liveness -> Liveness
union :: Liveness -> Liveness -> Liveness
union Liveness
a Liveness
b = IntSet -> Liveness
Liveness (IntSet -> Liveness) -> IntSet -> Liveness
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
S.union (Liveness -> IntSet
unLiveness Liveness
a) (Liveness -> IntSet
unLiveness Liveness
b)