module UHC.Light.Compiler.Base.Optimize
( Optimize (..)
, allOptimizeMp
, OptimizeOption (..)
, OptimizeOptionValue (..)
, OptimizeOptionMp
, optimizeOptionMpSingleton
, optimizeOptionStictnessAnalysisQuant
, allOptimizeOptionMp
, allOptimizeOptionMpAnyOption
, OptimizationLevel (..)
, OptimizationScope (..), allOptimScopeMp
, optimizeRequiresClosure
, OptimizeS
, OptimizationLevelMp
, optimizationLevelMp )
where
import UHC.Light.Compiler.Base.Common
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.List
import UHC.Util.AssocL
import UHC.Util.Pretty
import UHC.Util.Utils
import UHC.Util.Binary
import UHC.Util.Serialize
data Optimize
= Optimize_GrinLocal
| Optimize_StrictnessAnalysis
deriving (Eq,Ord,Enum,Show,Bounded)
allOptimizeMp :: Map.Map String Optimize
allOptimizeMp
= Map.fromList [ (drop lenPrefix $ show o, o) | o <- [minBound .. maxBound] ]
where lenPrefix = length "Optimize_"
data OptimizeOption
= OptimizeOption_StrictnessAnalysisQuant
deriving (Eq,Ord,Show)
data OptimizeOptionValue
= OptimizeOptionValue_StrictnessAnalysis_NoQuant
| OptimizeOptionValue_StrictnessAnalysis_Quant
| OptimizeOptionValue_StrictnessAnalysis_QuantInstantiate
deriving (Eq,Ord,Show,Enum)
type OptimizeOptionMp' val = Map.Map Optimize (Map.Map OptimizeOption val)
type OptimizeOptionMp = OptimizeOptionMp' OptimizeOptionValue
optimizeOptionMpSingleton :: Optimize -> OptimizeOption -> OptimizeOptionValue -> OptimizeOptionMp
optimizeOptionMpSingleton o oo v = Map.singleton o (Map.singleton oo v)
optimizeOptionStictnessAnalysisQuant :: OptimizeOptionMp -> OptimizeOptionValue
optimizeOptionStictnessAnalysisQuant m
= case mapLookup2 Optimize_StrictnessAnalysis OptimizeOption_StrictnessAnalysisQuant m of
Just oo -> maybe OptimizeOptionValue_StrictnessAnalysis_Quant id $ extr oo
_ -> OptimizeOptionValue_StrictnessAnalysis_Quant
where extr = Just
allOptimizeOptionMp
:: OptimizeOptionMp'
( OptimizeOptionValue
, (OptimizeOptionValue, OptimizeOptionValue)
)
allOptimizeOptionMp
= Map.fromList $ assocLMapElt Map.fromList
[ ( Optimize_StrictnessAnalysis
, [ ( OptimizeOption_StrictnessAnalysisQuant
, ( OptimizeOptionValue_StrictnessAnalysis_Quant
, (OptimizeOptionValue_StrictnessAnalysis_NoQuant, OptimizeOptionValue_StrictnessAnalysis_QuantInstantiate)
)
)
]
)
]
allOptimizeOptionMpAnyOption :: Optimize -> (OptimizeOption, OptimizeOptionValue)
allOptimizeOptionMpAnyOption o
= panicJust "allOptimizeOptionMpAnyOption"
$ do { om <- Map.lookup o allOptimizeOptionMp
; if Map.null om
then panic ("allOptimizeOptionMpAnyOption: " ++ show o)
else do { let (oo,(dflt,_)) = Map.findMin om
; return (oo,dflt)
}
}
data OptimizationLevel
= OptimizationLevel_Off
| OptimizationLevel_Normal
| OptimizationLevel_Much
| OptimizationLevel_Full
deriving (Eq,Ord,Show,Enum,Bounded)
data OptimizationScope
= OptimizationScope_PerModule
| OptimizationScope_WholeCore
deriving (Eq,Ord,Enum,Bounded)
instance Show OptimizationScope where
show OptimizationScope_PerModule = "permodule"
show OptimizationScope_WholeCore = "perwholecore"
allOptimScopeMp :: Map.Map String OptimizationScope
allOptimScopeMp = str2stMp
type OptimizeRequiresMp = Map.Map Optimize OptimizeS
optimizeRequiresMp :: OptimizeRequiresMp
optimizeRequiresMp
= Map.map Set.fromList $ Map.fromList
[ ( Optimize_StrictnessAnalysis
, [ ]
)
]
optimizeRequiresClosure :: OptimizeS -> OptimizeS
optimizeRequiresClosure os
= closes Set.empty os
where close o os
= closes (Set.insert o os)
$ Map.findWithDefault Set.empty o optimizeRequiresMp
`Set.difference` os
closes = Set.fold close
type OptimizeS = Set.Set Optimize
type OptimizationLevelMp = Map.Map OptimizationLevel OptimizeS
optimizationLevelMp :: OptimizationLevelMp
optimizationLevelMp
= (\m -> fst $
foldl (\(m,s) (l,o) -> let s' = Set.union s o in (Map.insert l s' m, s'))
(m, Set.empty)
[ (l, Map.findWithDefault Set.empty l m) | l <- [minBound .. maxBound] ]
)
$ Map.map Set.fromList
$ Map.fromList
$ [ ( OptimizationLevel_Off
, [ ]
)
, ( OptimizationLevel_Much
, [ ]
)
, ( OptimizationLevel_Full
, []
)
]