Commit 63338b5b authored by Finn Teegen's avatar Finn Teegen
Browse files

Make inlining of dictionaries optional

Fixes #108
parent 66dc5964
......@@ -104,8 +104,9 @@ data DebugOpts = DebugOpts
} deriving Show
data OptimizationOpts = OptimizationOpts
{ optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL
, optDesugarNewtypes :: Bool -- ^ Desugar newtypes
{ optDesugarNewtypes :: Bool -- ^ Desugar newtypes
, optInlineDictionaries :: Bool -- ^ Inline type class dictionaries
, optRemoveUnusedImports :: Bool -- ^ Remove unused imports in IL
} deriving Show
-- | Default compiler options
......@@ -165,8 +166,9 @@ defaultDebugOpts = DebugOpts
defaultOptimizationOpts :: OptimizationOpts
defaultOptimizationOpts = OptimizationOpts
{ optRemoveUnusedImports = True
, optDesugarNewtypes = False
{ optDesugarNewtypes = False
, optInlineDictionaries = True
, optRemoveUnusedImports = True
}
-- |Modus operandi of the program
......@@ -591,12 +593,16 @@ debugDescriptions =
optimizeDescriptions :: OptErrTable OptimizationOpts
optimizeDescriptions =
[ ( "desugar-newtypes", "desugars newtypes in FlatCurry"
[ ( "desugar-newtypes" , "desugars newtypes in FlatCurry"
, \ opts -> opts { optDesugarNewtypes = True })
, ( "inline-dictionaries" , "inlines type class dictionaries"
, \ opts -> opts { optInlineDictionaries = True })
, ( "remove-unused-imports" , "removes unused imports"
, \ opts -> opts { optRemoveUnusedImports = True })
, ( "no-desugar-newtypes", "prevents desugaring of newtypes in FlatCurry"
, ( "no-desugar-newtypes" , "prevents desugaring of newtypes in FlatCurry"
, \ opts -> opts { optDesugarNewtypes = False })
, ( "no-inline-dictionaries" , "prevents inlining of type class dictionaries"
, \ opts -> opts { optInlineDictionaries = False })
, ( "no-remove-unused-imports", "prevents removing of unused imports"
, \ opts -> opts { optRemoveUnusedImports = False })
]
......
......@@ -263,7 +263,7 @@ transModule :: Options -> CompEnv (CS.Module PredType)
transModule opts mdl = do
derived <- dumpCS DumpDerived $ derive mdl
desugared <- dumpCS DumpDesugared $ desugar derived
dicts <- dumpCS DumpDictionaries $ insertDicts desugared
dicts <- dumpCS DumpDictionaries $ insertDicts inlDi desugared
newtypes <- dumpCS DumpNewtypes $ removeNewtypes remNT dicts
simplified <- dumpCS DumpSimplified $ simplify newtypes
lifted <- dumpCS DumpLifted $ lift simplified
......@@ -272,6 +272,7 @@ transModule opts mdl = do
return (ilCaseComp, newtypes)
where
optOpts = optOptimizations opts
inlDi = optInlineDictionaries optOpts
remIm = optRemoveUnusedImports optOpts
remNT = optDesugarNewtypes optOpts
dumpCS :: Show a => DumpLevel -> CompEnv (CS.Module a)
......
......@@ -50,14 +50,15 @@ desugar (env, mdl) = (env { valueEnv = tyEnv' }, mdl')
(tyConsEnv env) mdl
-- |Insert dictionaries, changes the type constructor and value environments.
insertDicts :: CompEnv (Module PredType) -> CompEnv (Module Type)
insertDicts (env, mdl) = (env { interfaceEnv = intfEnv'
, tyConsEnv = tcEnv'
, valueEnv = vEnv'
, opPrecEnv = pEnv' }, mdl')
insertDicts :: Bool -> CompEnv (Module PredType) -> CompEnv (Module Type)
insertDicts inlDi (env, mdl) = (env { interfaceEnv = intfEnv'
, tyConsEnv = tcEnv'
, valueEnv = vEnv'
, opPrecEnv = pEnv' }, mdl')
where (mdl', intfEnv', tcEnv', vEnv', pEnv') =
DI.insertDicts (interfaceEnv env) (tyConsEnv env) (valueEnv env)
(classEnv env) (instEnv env) (opPrecEnv env) mdl
DI.insertDicts inlDi (interfaceEnv env) (tyConsEnv env)
(valueEnv env) (classEnv env) (instEnv env)
(opPrecEnv env) mdl
-- |Remove newtype constructors.
removeNewtypes :: Bool -> CompEnv (Module Type) -> CompEnv (Module Type)
......
......@@ -70,15 +70,15 @@ data DTState = DTState
type DTM = S.State DTState
insertDicts :: InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv
-> OpPrecEnv -> Module PredType
insertDicts :: Bool -> InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv
-> InstEnv -> OpPrecEnv -> Module PredType
-> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv)
insertDicts intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ _ m _ _ _) =
insertDicts inlDi intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ _ m _ _ _) =
(mdl', intfEnv', tcEnv', vEnv', pEnv')
where initState =
DTState m tcEnv vEnv clsEnv inEnv pEnv emptyAugEnv emptyDictEnv emptySpEnv 1
(mdl', tcEnv', vEnv', pEnv') =
runDTM (augment mdl >>= dictTrans >>= specialize >>= cleanup) initState
runDTM (augment mdl >>= dictTrans >>= (if inlDi then specialize else return) >>= cleanup) initState
intfEnv' = dictTransInterfaces vEnv' clsEnv intfEnv
runDTM :: DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment