module Michelson.Optimizer
( optimize
, optimizeWithConf
, defaultRules
, defaultRulesAndPushPack
, orRule
, orSimpleRule
, Rule
, OptimizerConf (..)
) where
import Prelude hiding (EQ)
import Data.Default (Default(def))
import Michelson.Interpret.Pack (packValue')
import Michelson.Typed.Aliases (Value)
import Michelson.Typed.CValue
import Michelson.Typed.Instr
import Michelson.Typed.Scope (PackedValScope)
import Michelson.Typed.T
import Michelson.Typed.Util (DfsSettings(..), dfsInstr)
import Michelson.Typed.Value
import Util.Peano (Sing(..))
data OptimizerConf = OptimizerConf
{ gotoValues :: Bool
, ruleset :: Rule -> Rule
}
instance Default OptimizerConf where
def = OptimizerConf
{ gotoValues = False
, ruleset = defaultRules
}
optimize :: Instr inp out -> Instr inp out
optimize = optimizeWithConf def
optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out
optimizeWithConf (OptimizerConf gotoValues rules)
= (fst .)
$ dfsInstr dfsSettings
$ (adapter .)
$ applyOnce
$ fixpoint rules
where
dfsSettings = def{ dsGoToValues = gotoValues }
type Rule = forall inp out. Instr inp out -> Maybe (Instr inp out)
defaultRules :: Rule -> Rule
defaultRules =
flattenSeqLHS
`orSimpleRule` removeNesting
`orSimpleRule` dipDrop2swapDrop
`orSimpleRule` ifNopNop2Drop
`orSimpleRule` nopIsNeutralForSeq
`orSimpleRule` variousNops
`orSimpleRule` dupSwap2dup
`orSimpleRule` noDipNeeded
`orSimpleRule` branchShortCut
`orSimpleRule` compareWithZero
`orSimpleRule` simpleDrops
`orSimpleRule` internalNop
`orSimpleRule` simpleDips
defaultRulesAndPushPack :: Rule -> Rule
defaultRulesAndPushPack = defaultRules `orSimpleRule` pushPack
flattenSeqLHS :: Rule -> Rule
flattenSeqLHS toplevel = \case
it@(Seq (Seq _ _) _) -> Just $ linearizeAndReapply toplevel it
_ -> Nothing
removeNesting :: Rule
removeNesting = \case
Nested i -> Just i
_ -> Nothing
dipDrop2swapDrop :: Rule
dipDrop2swapDrop = \case
DIP DROP -> Just $ Seq SWAP DROP
_ -> Nothing
ifNopNop2Drop :: Rule
ifNopNop2Drop = \case
IF Nop Nop -> Just DROP
_ -> Nothing
nopIsNeutralForSeq :: Rule
nopIsNeutralForSeq = \case
Seq Nop i -> Just i
Seq i Nop -> Just i
_ -> Nothing
variousNops :: Rule
variousNops = \case
Seq SWAP (Seq SWAP c) -> Just c
Seq (PUSH _) (Seq DROP c) -> Just c
Seq DUP (Seq DROP c) -> Just c
Seq UNIT (Seq DROP c) -> Just c
Seq SWAP SWAP -> Just Nop
Seq (PUSH _) DROP -> Just Nop
Seq DUP DROP -> Just Nop
Seq UNIT DROP -> Just Nop
_ -> Nothing
dupSwap2dup :: Rule
dupSwap2dup = \case
Seq DUP (Seq SWAP c) -> Just (Seq DUP c)
Seq DUP SWAP -> Just DUP
_ -> Nothing
noDipNeeded :: Rule
noDipNeeded = \case
Seq (PUSH x) (Seq (DIP f) c) -> Just (Seq f (Seq (PUSH x) c))
Seq (PUSH x) (DIP f) -> Just (Seq f (PUSH x))
Seq UNIT (Seq (DIP f) c) -> Just (Seq f (Seq UNIT c))
Seq UNIT (DIP f) -> Just (Seq f UNIT)
Seq (DIP f) (Seq DROP c) -> Just (Seq DROP (Seq f c))
Seq (DIP f) DROP -> Just (Seq DROP f)
_ -> Nothing
branchShortCut :: Rule
branchShortCut = \case
Seq LEFT (Seq (IF_LEFT f _) c) -> Just (Seq f c)
Seq RIGHT (Seq (IF_LEFT _ f) c) -> Just (Seq f c)
Seq CONS (Seq (IF_CONS f _) c) -> Just (Seq f c)
Seq NIL (Seq (IF_CONS _ f) c) -> Just (Seq f c)
Seq NONE (Seq (IF_NONE f _) c) -> Just (Seq f c)
Seq SOME (Seq (IF_NONE _ f) c) -> Just (Seq f c)
Seq (PUSH (VC (CvBool True))) (Seq (IF f _) c) -> Just (Seq f c)
Seq (PUSH (VC (CvBool False))) (Seq (IF _ f) c) -> Just (Seq f c)
Seq LEFT (IF_LEFT f _) -> Just f
Seq RIGHT (IF_LEFT _ f) -> Just f
Seq CONS (IF_CONS f _) -> Just f
Seq NIL (IF_CONS _ f) -> Just f
Seq NONE (IF_NONE f _) -> Just f
Seq SOME (IF_NONE _ f) -> Just f
Seq (PUSH (VC (CvBool True))) (IF f _) -> Just f
Seq (PUSH (VC (CvBool False))) (IF _ f) -> Just f
_ -> Nothing
compareWithZero :: Rule
compareWithZero = \case
Seq (PUSH (VC (CvInt 0))) (Seq COMPARE (Seq EQ c)) -> Just (Seq EQ c)
Seq (PUSH (VC (CvNat 0))) (Seq COMPARE (Seq EQ c)) -> Just (Seq INT (Seq EQ c))
Seq (PUSH (VC (CvInt 0))) (Seq COMPARE EQ) -> Just EQ
Seq (PUSH (VC (CvNat 0))) (Seq COMPARE EQ) -> Just (Seq INT EQ)
_ -> Nothing
simpleDrops :: Rule
simpleDrops = \case
Seq (DROPN SZ) c -> Just c
DROPN SZ -> Just Nop
_ -> Nothing
internalNop :: Rule
internalNop = \case
DIP Nop -> Just Nop
Seq (DIP Nop) c -> Just c
_ -> Nothing
simpleDips :: Rule
simpleDips = \case
Seq (DIPN SZ i) c -> Just (Seq i c)
DIPN SZ i -> Just i
_ -> Nothing
pushPack :: Rule
pushPack = \case
Seq (PUSH x) PACK -> Just (pushPacked x)
Seq (PUSH x) (Seq PACK c) -> Just (pushPacked x `Seq` c)
_ -> Nothing
where
pushPacked :: PackedValScope t => Value t -> Instr s ('Tc 'CBytes ': s)
pushPacked = PUSH . VC . CvBytes . packValue'
linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out
linearizeAndReapply restart = \case
Seq (Seq a b) c ->
applyOnce restart $ Seq a (linearizeAndReapply restart (Seq b c))
other -> applyOnce restart other
orRule :: (Rule -> Rule) -> (Rule -> Rule) -> (Rule -> Rule)
orRule l r topl x = l topl x <|> r topl x
orSimpleRule :: (Rule -> Rule) -> Rule -> (Rule -> Rule)
orSimpleRule l r topl x = l topl x <|> r x
fixpoint :: (Rule -> Rule) -> Rule
fixpoint r = go
where
go :: Rule
go = whileApplies (r go)
applyOnce :: Rule -> Instr inp out -> Instr inp out
applyOnce r i = maybe i id (r i)
adapter :: a -> (a, ())
adapter a = (a, ())
whileApplies :: Rule -> Rule
whileApplies r = go
where
go i = maybe (Just i) go (r i)