module Morley.Michelson.Optimizer.Utils
( pattern (:#)
, orRule
, orSimpleRule
, fixpoint
, applyOnce
, whileApplies
, linearizeAndReapply
) where
import Morley.Michelson.Optimizer.Internal.Ruleset (Rule(..))
import Morley.Michelson.Typed.Instr hiding ((:#))
pattern (:#) :: Instr inp b -> Instr b out -> Instr inp out
pattern l $m:# :: forall {r} {inp :: [T]} {out :: [T]}.
Instr inp out
-> (forall {b :: [T]}. Instr inp b -> Instr b out -> r)
-> ((# #) -> r)
-> r
$b:# :: forall (inp :: [T]) (out :: [T]) (b :: [T]).
Instr inp b -> Instr b out -> Instr inp out
:# r <- (\case { x :: Instr inp out
x@Seq{} -> Instr inp out
x; Instr inp out
x -> Instr inp out -> Instr out out -> Instr inp out
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
Seq Instr inp out
x Instr out out
forall (inp :: [T]). Instr inp inp
Nop } -> Seq l r)
where Instr inp b
l :# Instr b out
Nop = Instr inp out
Instr inp b
l
Instr inp b
Nop :# Instr b out
r = Instr inp out
Instr b out
r
Instr inp b
l :# Instr b out
r = Instr inp b -> Instr b out -> Instr inp out
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
Seq Instr inp b
l Instr b out
r
infixr 8 :#
orRule :: (Rule -> Rule) -> (Rule -> Rule) -> (Rule -> Rule)
orRule :: (Rule -> Rule) -> (Rule -> Rule) -> Rule -> Rule
orRule Rule -> Rule
l Rule -> Rule
r Rule
topl = (forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule
Rule ((forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule)
-> (forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule
forall a b. (a -> b) -> a -> b
$ \Instr inp out
instr ->
(Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule (Rule -> Rule
l Rule
topl) (Instr inp out -> Maybe (Instr inp out))
-> Instr inp out -> Maybe (Instr inp out)
forall a b. (a -> b) -> a -> b
$ Instr inp out
instr) Maybe (Instr inp out)
-> Maybe (Instr inp out) -> Maybe (Instr inp out)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule (Rule -> Rule
r Rule
topl) (Instr inp out -> Maybe (Instr inp out))
-> Instr inp out -> Maybe (Instr inp out)
forall a b. (a -> b) -> a -> b
$ Instr inp out
instr)
orSimpleRule :: (Rule -> Rule) -> Rule -> (Rule -> Rule)
orSimpleRule :: (Rule -> Rule) -> Rule -> Rule -> Rule
orSimpleRule Rule -> Rule
l Rule
r Rule
topl = (forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule
Rule ((forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule)
-> (forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule
forall a b. (a -> b) -> a -> b
$ \Instr inp out
instr ->
(Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule (Rule -> Rule
l Rule
topl) (Instr inp out -> Maybe (Instr inp out))
-> Instr inp out -> Maybe (Instr inp out)
forall a b. (a -> b) -> a -> b
$ Instr inp out
instr) Maybe (Instr inp out)
-> Maybe (Instr inp out) -> Maybe (Instr inp out)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule Rule
r (Instr inp out -> Maybe (Instr inp out))
-> Instr inp out -> Maybe (Instr inp out)
forall a b. (a -> b) -> a -> b
$ Instr inp out
instr)
fixpoint :: (Rule -> Rule) -> Rule
fixpoint :: (Rule -> Rule) -> Rule
fixpoint Rule -> Rule
r = Rule
go
where
go :: Rule
go :: Rule
go = Rule -> Rule
whileApplies (Rule -> Rule
r Rule
go)
applyOnce :: Rule -> Instr inp out -> (Any Bool, Instr inp out)
applyOnce :: forall (inp :: [T]) (out :: [T]).
Rule -> Instr inp out -> (Any Bool, Instr inp out)
applyOnce Rule
r Instr inp out
i = (Any Bool, Instr inp out)
-> (Instr inp out -> (Any Bool, Instr inp out))
-> Maybe (Instr inp out)
-> (Any Bool, Instr inp out)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Instr inp out -> (Any Bool, Instr inp out)
forall a. a -> (Any Bool, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Instr inp out
i) (Bool -> Any Bool
forall a. a -> Any a
Any Bool
True,) (Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule Rule
r (Instr inp out -> Maybe (Instr inp out))
-> Instr inp out -> Maybe (Instr inp out)
forall a b. (a -> b) -> a -> b
$ Instr inp out
i)
whileApplies :: Rule -> Rule
whileApplies :: Rule -> Rule
whileApplies Rule
r = (forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule
Rule ((forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule)
-> (forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out))
-> Rule
forall a b. (a -> b) -> a -> b
$ Instr inp out -> Maybe (Instr inp out)
forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
go (Instr inp out -> Maybe (Instr inp out))
-> (Instr inp out -> Maybe (Instr inp out))
-> Instr inp out
-> Maybe (Instr inp out)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule Rule
r
where
go :: Instr inp out -> Maybe (Instr inp out)
go :: forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
go Instr inp out
i = Maybe (Instr inp out)
-> (Instr inp out -> Maybe (Instr inp out))
-> Maybe (Instr inp out)
-> Maybe (Instr inp out)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Instr inp out -> Maybe (Instr inp out)
forall a. a -> Maybe a
Just Instr inp out
i) Instr inp out -> Maybe (Instr inp out)
forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
go (Rule
-> forall (inp :: [T]) (out :: [T]).
Instr inp out -> Maybe (Instr inp out)
unRule Rule
r Instr inp out
i)
linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out
linearizeAndReapply :: forall (inp :: [T]) (out :: [T]).
Rule -> Instr inp out -> Instr inp out
linearizeAndReapply Rule
restart = (Any Bool, Instr inp out) -> Instr inp out
forall a b. (a, b) -> b
snd ((Any Bool, Instr inp out) -> Instr inp out)
-> (Instr inp out -> (Any Bool, Instr inp out))
-> Instr inp out
-> Instr inp out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Seq (Seq Instr inp b
a Instr b b
b) Instr b out
c ->
Rule -> Instr inp out -> (Any Bool, Instr inp out)
forall (inp :: [T]) (out :: [T]).
Rule -> Instr inp out -> (Any Bool, Instr inp out)
applyOnce Rule
restart (Instr inp out -> (Any Bool, Instr inp out))
-> Instr inp out -> (Any Bool, Instr inp out)
forall a b. (a -> b) -> a -> b
$ Instr inp b -> Instr b out -> Instr inp out
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
Seq Instr inp b
a (Rule -> Instr b out -> Instr b out
forall (inp :: [T]) (out :: [T]).
Rule -> Instr inp out -> Instr inp out
linearizeAndReapply Rule
restart (Instr b b -> Instr b out -> Instr b out
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
Seq Instr b b
b Instr b out
c))
Instr inp out
other -> Rule -> Instr inp out -> (Any Bool, Instr inp out)
forall (inp :: [T]) (out :: [T]).
Rule -> Instr inp out -> (Any Bool, Instr inp out)
applyOnce Rule
restart Instr inp out
other