projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add a compileToCore function to the GHC API
[ghc-hetmet.git]
/
compiler
/
main
/
DynFlags.hs
diff --git
a/compiler/main/DynFlags.hs
b/compiler/main/DynFlags.hs
index
5a00401
..
7b06a48
100644
(file)
--- a/
compiler/main/DynFlags.hs
+++ b/
compiler/main/DynFlags.hs
@@
-177,6
+177,9
@@
data DynFlag
| Opt_BangPatterns
| Opt_TypeFamilies
| Opt_OverloadedStrings
| Opt_BangPatterns
| Opt_TypeFamilies
| Opt_OverloadedStrings
+ | Opt_DisambiguateRecordFields
+ | Opt_RecordDotDot
+ | Opt_RecordPuns
| Opt_GADTs
| Opt_RelaxedPolyRec -- -X=RelaxedPolyRec
| Opt_GADTs
| Opt_RelaxedPolyRec -- -X=RelaxedPolyRec
@@
-558,13
+561,14
@@
data Option
updOptLevel :: Int -> DynFlags -> DynFlags
-- Set dynflags appropriate to the optimisation level
updOptLevel n dfs
updOptLevel :: Int -> DynFlags -> DynFlags
-- Set dynflags appropriate to the optimisation level
updOptLevel n dfs
- = dfs2{ optLevel = n }
+ = dfs2{ optLevel = final_n }
where
where
+ final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2
dfs1 = foldr (flip dopt_unset) dfs remove_dopts
dfs2 = foldr (flip dopt_set) dfs1 extra_dopts
dfs1 = foldr (flip dopt_unset) dfs remove_dopts
dfs2 = foldr (flip dopt_set) dfs1 extra_dopts
- extra_dopts = [ f | (ns,f) <- optLevelFlags, n `elem` ns ]
- remove_dopts = [ f | (ns,f) <- optLevelFlags, n `notElem` ns ]
+ extra_dopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]
+ remove_dopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]
optLevelFlags :: [([Int], DynFlag)]
optLevelFlags
optLevelFlags :: [([Int], DynFlag)]
optLevelFlags
@@
-1025,7
+1029,8
@@
dynamic_flags = [
, ( "f", PrefixPred (isNoFlag fFlags) (\f -> unSetDynFlag (getNoFlag fFlags f)) )
-- For now, allow -X flags with -f; ToDo: report this as deprecated
, ( "f", PrefixPred (isNoFlag fFlags) (\f -> unSetDynFlag (getNoFlag fFlags f)) )
-- For now, allow -X flags with -f; ToDo: report this as deprecated
- , ( "f", PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag fFlags f)) )
+ , ( "f", PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag xFlags f)) )
+ , ( "f", PrefixPred (isNoFlag xFlags) (\f -> unSetDynFlag (getNoFlag xFlags f)) )
-- the rest of the -X* and -Xno-* flags
, ( "X", PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag xFlags f)) )
-- the rest of the -X* and -Xno-* flags
, ( "X", PrefixPred (isFlag xFlags) (\f -> setDynFlag (getFlag xFlags f)) )
@@
-1117,6
+1122,7
@@
impliedFlags = [
glasgowExtsFlags = [ Opt_GlasgowExts
, Opt_FFI
glasgowExtsFlags = [ Opt_GlasgowExts
, Opt_FFI
+ , Opt_GADTs
, Opt_ImplicitParams
, Opt_ScopedTypeVariables
, Opt_TypeFamilies ]
, Opt_ImplicitParams
, Opt_ScopedTypeVariables
, Opt_TypeFamilies ]
@@
-1138,10
+1144,12
@@
getFlag, getNoFlag :: [(String,a)] -> String -> a
getFlag flags f = get_flag flags (normaliseFlag f)
getFlag flags f = get_flag flags (normaliseFlag f)
-getNoFlag flags f = getFlag flags (fromJust (noFlag_maybe (normaliseFlag f)))
+getNoFlag flags f = get_flag flags (fromJust (noFlag_maybe (normaliseFlag f)))
-- The flag should be a no-flag already
-- The flag should be a no-flag already
-get_flag flags nf = head [ opt | (ff, opt) <- flags, normaliseFlag ff == nf]
+get_flag flags nf = case [ opt | (ff, opt) <- flags, normaliseFlag ff == nf] of
+ (o:os) -> o
+ [] -> panic ("get_flag " ++ nf)
------------------
noFlag_maybe :: String -> Maybe String
------------------
noFlag_maybe :: String -> Maybe String