Inliner.hs

{-# LANGUAGE ImplicitParams #-}
{-|
Module      : Parsley.Internal.Frontend.Analysis.Inliner
Description : Decides whether to inline a let-bound parser.
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

Exposes a transformation which can be used to inline let-bindings into their use-sites.

@since 1.7.0.0
-}
module Parsley.Internal.Frontend.Analysis.Inliner (inliner) where

import Data.Ratio                          ((%))
import Parsley.Internal.Common.Indexed     (Fix(..), cata)
import Parsley.Internal.Core.CombinatorAST (Combinator(..))
import Parsley.Internal.Core.Identifiers   (MVar)

import qualified Parsley.Internal.Opt   as Opt

{-|
Annotate a tree with its cut-points. We assume a cut for let-bound parsers.

@since 1.7.0.0
-}
inliner :: (?flags :: Opt.Flags) => Maybe Int -> MVar a -> Fix Combinator a -> Fix Combinator a
inliner occs _ body
  | Just n <- occs
  , Just thresh <- Opt.primaryInlineThreshold ?flags
  , shouldInline n thresh body = body
inliner _ μ _ = In (Let μ)

shouldInline :: Int -> Rational -> Fix Combinator a -> Bool
shouldInline occs inlineThreshold = (<= inlineThreshold) . (* toRational occs) . subtract callCost . getWeight . cata (InlineWeight . alg)

newtype InlineWeight a = InlineWeight { getWeight :: Rational }

callCost :: Rational
callCost = 1 % 3

handlerCost :: Rational
handlerCost = 1 % 4

registerCost :: Rational
registerCost = 1 % 3

-- Ideally these should mirror those in the backend inliner, how can we unify them?
alg :: Combinator InlineWeight a -> Rational
alg (Pure _)             = 0
alg (Satisfy _)          = 1
alg Empty                = 0
alg Let{}                = callCost
alg (Try p)              = getWeight p
alg (l :<|>: r)          = handlerCost + 1 % 5 + getWeight l + getWeight r
alg (l :<*>: r)          = 1 % 5 + getWeight l + getWeight r
alg (l :<*: r)           = getWeight l + getWeight r
alg (l :*>: r)           = getWeight l + getWeight r
alg (LookAhead c)        = getWeight c
alg (NotFollowedBy p)    = handlerCost + getWeight p
alg (Debug _ c)          = getWeight c
alg (Loop body exit)     = handlerCost + callCost + 2 % 3 + getWeight body + getWeight exit
alg (Branch b p q)       = 1 % 3 + 2 % 5 + getWeight b + getWeight p + getWeight q
alg (Match p _ qs def)   = fromIntegral (length qs + 1) % 3 + sum (map getWeight qs) + getWeight def + getWeight p
alg (MakeRegister _ l r) = registerCost + getWeight l + getWeight r
alg (GetRegister _)      = registerCost
alg (PutRegister _ c)    = registerCost + getWeight c
alg (Position _)         = 1 % 5
alg (MetaCombinator _ c) = getWeight c