X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplMonad.lhs;h=4265efb3f070d9fd41e642aeb4c8dce91faa9d06;hb=ec576735c81107dc2947abfd6c9a74b3d0103c4b;hp=26d19bb05a402b54aad48d2decc36176289f09c6;hpb=a11685b343f5687e812e91d1f0b4bb5ba3b9706a;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 26d19bb..4265efb 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -14,8 +14,7 @@ module SimplMonad ( -- The monad SimplM, - initSmpl, returnSmpl, thenSmpl, thenSmpl_, - mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, + initSmpl, getDOptsSmpl, getRules, getFamEnvs, -- Unique supply @@ -32,8 +31,6 @@ module SimplMonad ( isAmongSimpl, intSwitchSet, switchIsOn ) where -#include "HsVersions.h" - import Id ( Id, mkSysLocal ) import Type ( Type ) import FamInstEnv ( FamInstEnv ) @@ -44,14 +41,12 @@ import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize ) import Unique ( Unique ) import Maybes ( expectJust ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList ) -import FastString ( FastString ) +import FastString import Outputable import FastTypes import Data.Array import Data.Array.Base (unsafeAt) - -infixr 0 `thenSmpl`, `thenSmpl_` \end{code} %************************************************************************ @@ -112,30 +107,11 @@ thenSmpl_ m k = SM (\st_env us0 sc0 -> case (unSM m st_env us0 sc0) of (_, us1, sc1) -> unSM k st_env us1 sc1) -\end{code} - -\begin{code} -mapSmpl :: (a -> SimplM b) -> [a] -> SimplM [b] -mapAndUnzipSmpl :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) - -mapSmpl f [] = returnSmpl [] -mapSmpl f (x:xs) - = f x `thenSmpl` \ x' -> - mapSmpl f xs `thenSmpl` \ xs' -> - returnSmpl (x':xs') - -mapAndUnzipSmpl f [] = returnSmpl ([],[]) -mapAndUnzipSmpl f (x:xs) - = f x `thenSmpl` \ (r1, r2) -> - mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) -> - returnSmpl (r1:rs1, r2:rs2) - -mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) -mapAccumLSmpl f acc [] = returnSmpl (acc, []) -mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> - mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') -> - returnSmpl (acc'', x':xs') +-- TODO: this specializing is not allowed +{-# -- SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-} +{-# -- SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-} +{-# -- SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-} \end{code} @@ -276,15 +252,15 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) plusSimplCount VerySimplZero VerySimplZero = VerySimplZero plusSimplCount sc1 sc2 = VerySimplNonZero -pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!") -pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!") +pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!") +pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!") pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [ptext SLIT("Total ticks: ") <+> int tks, + = vcat [ptext (sLit "Total ticks: ") <+> int tks, text "", pprTickCounts (fmToList dts), if verboseSimplStats then vcat [text "", - ptext SLIT("Log (most recent first)"), + ptext (sLit "Log (most recent first)"), nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] else empty ]