-
-%************************************************************************
-%* *
-\subsection{Ticks}
-%* *
-%************************************************************************
-
-\begin{code}
-data Tick
- = PreInlineUnconditionally Id
- | PostInlineUnconditionally Id
-
- | UnfoldingDone Id
- | RuleFired FastString -- Rule name
-
- | LetFloatFromLet
- | EtaExpansion Id -- LHS binder
- | EtaReduction Id -- Binder on outer lambda
- | BetaReduction Id -- Lambda binder
-
-
- | CaseOfCase Id -- Bndr on *inner* case
- | KnownBranch Id -- Case binder
- | CaseMerge Id -- Binder on outer case
- | AltMerge Id -- Case binder
- | CaseElim Id -- Case binder
- | CaseIdentity Id -- Case binder
- | FillInCaseDefault Id -- Case binder
-
- | BottomFound
- | SimplifierDone -- Ticked at each iteration of the simplifier
-
-isRuleFired (RuleFired _) = True
-isRuleFired other = False
-
-instance Outputable Tick where
- ppr tick = text (tickString tick) <+> pprTickCts tick
-
-instance Eq Tick where
- a == b = case a `cmpTick` b of { EQ -> True; other -> False }
-
-instance Ord Tick where
- compare = cmpTick
-
-tickToTag :: Tick -> Int
-tickToTag (PreInlineUnconditionally _) = 0
-tickToTag (PostInlineUnconditionally _) = 1
-tickToTag (UnfoldingDone _) = 2
-tickToTag (RuleFired _) = 3
-tickToTag LetFloatFromLet = 4
-tickToTag (EtaExpansion _) = 5
-tickToTag (EtaReduction _) = 6
-tickToTag (BetaReduction _) = 7
-tickToTag (CaseOfCase _) = 8
-tickToTag (KnownBranch _) = 9
-tickToTag (CaseMerge _) = 10
-tickToTag (CaseElim _) = 11
-tickToTag (CaseIdentity _) = 12
-tickToTag (FillInCaseDefault _) = 13
-tickToTag BottomFound = 14
-tickToTag SimplifierDone = 16
-tickToTag (AltMerge _) = 17
-
-tickString :: Tick -> String
-tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
-tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
-tickString (UnfoldingDone _) = "UnfoldingDone"
-tickString (RuleFired _) = "RuleFired"
-tickString LetFloatFromLet = "LetFloatFromLet"
-tickString (EtaExpansion _) = "EtaExpansion"
-tickString (EtaReduction _) = "EtaReduction"
-tickString (BetaReduction _) = "BetaReduction"
-tickString (CaseOfCase _) = "CaseOfCase"
-tickString (KnownBranch _) = "KnownBranch"
-tickString (CaseMerge _) = "CaseMerge"
-tickString (AltMerge _) = "AltMerge"
-tickString (CaseElim _) = "CaseElim"
-tickString (CaseIdentity _) = "CaseIdentity"
-tickString (FillInCaseDefault _) = "FillInCaseDefault"
-tickString BottomFound = "BottomFound"
-tickString SimplifierDone = "SimplifierDone"
-
-pprTickCts :: Tick -> SDoc
-pprTickCts (PreInlineUnconditionally v) = ppr v
-pprTickCts (PostInlineUnconditionally v)= ppr v
-pprTickCts (UnfoldingDone v) = ppr v
-pprTickCts (RuleFired v) = ppr v
-pprTickCts LetFloatFromLet = empty
-pprTickCts (EtaExpansion v) = ppr v
-pprTickCts (EtaReduction v) = ppr v
-pprTickCts (BetaReduction v) = ppr v
-pprTickCts (CaseOfCase v) = ppr v
-pprTickCts (KnownBranch v) = ppr v
-pprTickCts (CaseMerge v) = ppr v
-pprTickCts (AltMerge v) = ppr v
-pprTickCts (CaseElim v) = ppr v
-pprTickCts (CaseIdentity v) = ppr v
-pprTickCts (FillInCaseDefault v) = ppr v
-pprTickCts other = empty
-
-cmpTick :: Tick -> Tick -> Ordering
-cmpTick a b = case (tickToTag a `compare` tickToTag b) of
- GT -> GT
- EQ | isRuleFired a || verboseSimplStats -> cmpEqTick a b
- | otherwise -> EQ
- LT -> LT
- -- Always distinguish RuleFired, so that the stats
- -- can report them even in non-verbose mode
-
-cmpEqTick :: Tick -> Tick -> Ordering
-cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
-cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
-cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
-cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
-cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
-cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
-cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
-cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
-cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
-cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
-cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
-cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
-cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
-cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
-cmpEqTick other1 other2 = EQ
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Command-line switches}
-%* *
-%************************************************************************
-
-\begin{code}
-type SwitchChecker = SimplifierSwitch -> SwitchResult
-
-data SwitchResult
- = SwBool Bool -- on/off
- | SwString FastString -- nothing or a String
- | SwInt Int -- nothing or an Int
-
-isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
-isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
- -- in the list; defaults right at the end.
- = let
- tidied_on_switches = foldl rm_dups [] on_switches
- -- The fold*l* ensures that we keep the latest switches;
- -- ie the ones that occur earliest in the list.
-
- sw_tbl :: Array Int SwitchResult
- sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds...
- all_undefined)
- // defined_elems
-
- all_undefined = [ (i, SwBool False) | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
-
- defined_elems = map mk_assoc_elem tidied_on_switches
- in
- -- (avoid some unboxing, bounds checking, and other horrible things:)
- \ switch -> unsafeAt sw_tbl $ iBox (tagOf_SimplSwitch switch)
- where
- mk_assoc_elem k@(MaxSimplifierIterations lvl)
- = (iBox (tagOf_SimplSwitch k), SwInt lvl)
- mk_assoc_elem k
- = (iBox (tagOf_SimplSwitch k), SwBool True) -- I'm here, Mom!
-
- -- cannot have duplicates if we are going to use the array thing
- rm_dups switches_so_far switch
- = if switch `is_elem` switches_so_far
- then switches_so_far
- else switch : switches_so_far
- where
- sw `is_elem` [] = False
- sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) ==# (tagOf_SimplSwitch s)
- || sw `is_elem` ss
-\end{code}
-
-\begin{code}
-getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
-getSimplIntSwitch chkr switch
- = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
-
-switchIsOn :: (switch -> SwitchResult) -> switch -> Bool
-
-switchIsOn lookup_fn switch
- = case (lookup_fn switch) of
- SwBool False -> False
- _ -> True
-
-intSwitchSet :: (switch -> SwitchResult)
- -> (Int -> switch)
- -> Maybe Int
-
-intSwitchSet lookup_fn switch
- = case (lookup_fn (switch (panic "intSwitchSet"))) of
- SwInt int -> Just int
- _ -> Nothing
-\end{code}
-
-
-These things behave just like enumeration types.
-
-\begin{code}
-instance Eq SimplifierSwitch where
- a == b = tagOf_SimplSwitch a ==# tagOf_SimplSwitch b
-
-instance Ord SimplifierSwitch where
- a < b = tagOf_SimplSwitch a <# tagOf_SimplSwitch b
- a <= b = tagOf_SimplSwitch a <=# tagOf_SimplSwitch b
-
-
-tagOf_SimplSwitch (MaxSimplifierIterations _) = _ILIT(1)
-tagOf_SimplSwitch NoCaseOfCase = _ILIT(2)
-
--- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
-
-lAST_SIMPL_SWITCH_TAG = 2
-\end{code}
-