Updated inliner to account for occurrences

parsley-core/src/ghc/Parsley/Internal/Backend/Analysis/Inliner.hs

@@ -27,8 +27,8 @@ entry to a machine are actually used in the computation.
 -}
 shouldInline :: (?flags :: Opt.Flags) => Fix4 (Instr o) xs n r a -> Bool
 shouldInline
-  | Just thresh <- Opt.inlineThreshold ?flags = (< thresh) . getWeight . cata4 (InlineWeight . alg)
-  | otherwise                                 = const False
+  | Just thresh <- Opt.secondaryInlineThreshold ?flags = (< thresh) . getWeight . cata4 (InlineWeight . alg)
+  | otherwise                                          = const False
 
 newtype InlineWeight xs (n :: Nat) r a = InlineWeight { getWeight :: Rational }
 

parsley-core/src/ghc/Parsley/Internal/Frontend/Analysis/Cut.hs

@@ -33,8 +33,6 @@ newtype CutAnalysis a = CutAnalysis { doCut :: Bool -> (Fix Combinator a, Bool)
 -- TODO: UnguardedEffects should track a set of registers
 data Guardedness (a :: Type) = Guarded | UnguardedEffect | NoEffect deriving stock Eq
 
--- FIXME: the top-level binding needs a `cut unit *>` at the top-level
-
 guardednessAlg :: Combinator Guardedness a -> Guardedness a
 guardednessAlg Pure{} = NoEffect
 guardednessAlg Satisfy{} = Guarded

parsley-core/src/ghc/Parsley/Internal/Frontend/Analysis/Inliner.hs

@@ -27,35 +27,43 @@ Annotate a tree with its cut-points. We assume a cut for let-bound parsers.
 inliner :: (?flags :: Opt.Flags) => Maybe Int -> MVar a -> Fix Combinator a -> Fix Combinator a
 inliner occs _ body
   | Just n <- occs
-  , Just thresh <- Opt.inlineThreshold ?flags
+  , Just thresh <- Opt.primaryInlineThreshold ?flags
   , shouldInline n thresh body = body
 inliner _ μ _ = In (Let μ)
 
---TODO: account for the number of occurrences: large number should penalise
 shouldInline :: Int -> Rational -> Fix Combinator a -> Bool
-shouldInline _occs inlineThreshold = (< inlineThreshold) . getWeight . cata (InlineWeight . alg)
+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{}                = 2 % 3
+alg Let{}                = callCost
 alg (Try p)              = getWeight p
-alg (l :<|>: r)          = 1 % 4 + 2 % 5 + getWeight l + getWeight r
+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)    = 1 % 4 + getWeight p
-alg (Debug _ c)          = 2 % 4 + getWeight c
-alg (Loop body exit)     = 2 % 3 + getWeight body + getWeight exit
+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) = 1 % 3 + getWeight l + getWeight r
-alg (GetRegister _)      = 1 % 3
-alg (PutRegister _ c)    = 1 % 3 + getWeight c
+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

parsley-core/src/ghc/Parsley/Internal/Opt.hs

@@ -6,40 +6,46 @@ on, off :: Bool
 on = True
 off = False
 
-defaultInlineThreshold :: Maybe Rational
-defaultInlineThreshold = Just (13 % 10)
+defaultPrimaryInlineThreshold :: Maybe Rational
+defaultPrimaryInlineThreshold = Just $ 13 % 10 * {- Occurrence Bias -} 5
 
-data Flags = Flags { lawBasedOptimisations :: !Bool
-                   , termNormalisation     :: !Bool
-                   , inlineThreshold       :: !(Maybe Rational)
+defaultSecondaryInlineThreshold :: Maybe Rational
+defaultSecondaryInlineThreshold = Just $ 13 % 10
+
+data Flags = Flags { lawBasedOptimisations    :: !Bool
+                   , termNormalisation        :: !Bool
+                   , primaryInlineThreshold   :: !(Maybe Rational)
+                   , secondaryInlineThreshold :: !(Maybe Rational)
                    -- TODO: merge these together
-                   , lengthCheckFactoring  :: !Bool
-                   , leadCharFactoring     :: !Bool
-                   , factorAheadOfJoins    :: !Bool
-                   , reclaimInput          :: !Bool
-                   , deduceFailPath        :: !Bool
-                   --, closeFreeRegisters    :: !Bool
+                   , lengthCheckFactoring     :: !Bool
+                   , leadCharFactoring        :: !Bool
+                   , factorAheadOfJoins       :: !Bool
+                   , reclaimInput             :: !Bool
+                   , deduceFailPath           :: !Bool
+                   --, closeFreeRegisters       :: !Bool
                    }
 
 none, fast, full :: Flags
-none = Flags { lawBasedOptimisations = off
-             , termNormalisation     = off
-             , inlineThreshold       = Nothing
-             , lengthCheckFactoring  = off
-             , leadCharFactoring     = off
-             , factorAheadOfJoins    = off
-             , reclaimInput          = off
-             , deduceFailPath        = off
-             --, closeFreeRegisters    = off
+none = Flags { lawBasedOptimisations    = off
+             , termNormalisation        = off
+             , primaryInlineThreshold   = Nothing
+             , secondaryInlineThreshold = Nothing
+             , lengthCheckFactoring     = off
+             , leadCharFactoring        = off
+             , factorAheadOfJoins       = off
+             , reclaimInput             = off
+             , deduceFailPath           = off
+             --, closeFreeRegisters       = off
              }
 fast = full  --{ }
-full = Flags { lawBasedOptimisations = on
-             , termNormalisation     = on
-             , inlineThreshold       = defaultInlineThreshold
-             , lengthCheckFactoring  = on
-             , leadCharFactoring     = on
-             , factorAheadOfJoins    = on
-             , reclaimInput          = on
-             , deduceFailPath        = on
-             --, closeFreeRegisters    = on
+full = Flags { lawBasedOptimisations    = on
+             , termNormalisation        = on
+             , primaryInlineThreshold   = defaultPrimaryInlineThreshold
+             , secondaryInlineThreshold = defaultSecondaryInlineThreshold
+             , lengthCheckFactoring     = on
+             , leadCharFactoring        = on
+             , factorAheadOfJoins       = on
+             , reclaimInput             = on
+             , deduceFailPath           = on
+             --, closeFreeRegisters       = on
              }