opt_IrrefutableTuples,
opt_LiberateCaseThreshold,
opt_MultiParamClasses,
+ opt_NoHiCheck,
opt_NoImplicitPrelude,
opt_NumbersStrict,
opt_OmitBlackHoling,
assoc_opts = assocMaybe [ (a, True) | a <- argv ]
unpacked_opts = map _UNPK_ argv
+
+{-
+ Putting the compiler options into temporary at-files
+ may turn out to be necessary later on if we turn hsc into
+ a pure Win32 application where I think there's a command-line
+ length limit of 255. unpacked_opts understands the @ option.
+
+assoc_opts = assocMaybe [ (_PK_ a, True) | a <- unpacked_opts ]
+
+unpacked_opts :: [String]
+unpacked_opts =
+ concat $
+ map (expandAts) $
+ map _UNPK_ argv
+ where
+ expandAts ('@':fname) = words (unsafePerformIO (readFile fname))
+ expandAts l = [l]
+-}
\end{code}
\begin{code}
classifyOpts = sep argv [] [] -- accumulators...
where
- sep :: [FAST_STRING] -- cmd-line opts (input)
+ sep :: [FAST_STRING] -- cmd-line opts (input)
-> [CoreToDo] -> [StgToDo] -- to_do accumulators
-> ([CoreToDo], [StgToDo]) -- result
# define CORE_TD(to_do) sep opts (to_do:core_td) stg_td
# define STG_TD(to_do) sep opts core_td (to_do:stg_td)
-# define IGNORE_ARG() sep opts core_td stg_td
sep (opt1:opts) core_td stg_td
- =
- case (_UNPK_ opt1) of -- the non-"just match a string" options are at the end...
-
- ',' : _ -> IGNORE_ARG() -- it is for the parser
+ = case (_UNPK_ opt1) of -- the non-"just match a string" options are at the end...
+ ',' : _ -> sep opts core_td stg_td -- it is for the parser
"-fsimplify" -> -- gather up SimplifierSwitches specially...
simpl_sep opts defaultSimplSwitches core_td stg_td
"-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling)
_ -> -- NB: the driver is really supposed to handle bad options
- IGNORE_ARG()
+ sep opts core_td stg_td
----------------
- simpl_sep :: [FAST_STRING] -- cmd-line opts (input)
- -> [SimplifierSwitch] -- simplifier-switch accumulator
- -> [CoreToDo] -> [StgToDo] -- to_do accumulators
- -> ([CoreToDo], [StgToDo]) -- result
+ simpl_sep :: [FAST_STRING] -- cmd-line opts (input)
+ -> [SimplifierSwitch] -- simplifier-switch accumulator
+ -> [CoreToDo] -> [StgToDo] -- to_do accumulators
+ -> ([CoreToDo], [StgToDo]) -- result
-- "simpl_sep" tailcalls "sep" once it's seen one set
-- of SimplifierSwitches for a CoreDoSimplify.
%************************************************************************
\begin{code}
-# define ARRAY Array
-# define LIFT Lift
-# define SET_TO =:
-(=:) a b = (a,b)
-
isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult
isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
all_undefined)
// defined_elems
- all_undefined = [ i SET_TO SwBool False | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ]
+ 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:)
- case sw_tbl of { ARRAY bounds_who_needs_'em stuff ->
+ case sw_tbl of { Array bounds_who_needs_'em stuff ->
\ switch ->
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
- LIFT v -> v
+ Lift v -> v
}
where
- mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl
+ mk_assoc_elem k@(MaxSimplifierIterations lvl) = (IBOX(tagOf_SimplSwitch k), SwInt lvl)
- mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool True -- I'm here, Mom!
+ 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
import {-# SOURCE #-} CostCentre
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
import BasicTypes ( NewOrData(..), IfaceFlavour(..) )
of the information contained in the file turns out to be useful, so
delaying as much as possible of the scanning and parsing of an
interface file Makes Sense (Heap profiles of the compiler
-show at a reduction in heap usage by at least a factor of two,
+show a reduction in heap usage by at least a factor of two,
post-renamer).
Hence, the interface file lexer spots when value declarations are
------------------
lex_demand cont buf =
--- _trace ("demand: "++[C# (currentChar# buf)]) $
case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme buf')}
where
-- code snatched from Demand.lhs
read_em acc buf =
--- _trace ("read_em: "++[C# (currentChar# buf)]) $
case currentChar# buf of
'L'# -> read_em (WwLazy False : acc) (stepOn buf)
'A'# -> read_em (WwLazy True : acc) (stepOn buf)
------------------
lex_scc cont buf =
--- _trace ("scc: "++[C# (currentChar# buf)]) $
case currentChar# buf of
'"'# ->
-- YUCK^2
-----------
lex_cstring cont buf =
--- _trace ("lex_cstring: "++[C# (currentChar# buf)]) $
case expandUntilMatch buf "\'\'" of
buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
(stepOverLexeme buf')
-----------
lex_tuple cont module_dot buf =
--- _trace ("lex_tuple: "++[C# (currentChar# buf)]) $
go 2 buf
where
go n buf =
-- Dealt with [], (), : special cases
lex_id3 cont module_dot buf =
--- _trace ("lex_id3: "++[C# (currentChar# buf)]) $
case expandWhile (is_id_char) buf of
buf' ->
case module_dot of
new_buf = stepOverLexeme buf'
-{- OLD:
-lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs
-lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs
-lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs
-lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs
-lex_id2 module_dot xs cs = lex_id3 module_dot xs cs
--}
-
-- Dealt with [], (), : special cases
-
-{-
-lex_id3 module_dot len_xs xs cs =
- case my_span' (is_id_char) cs of
- (xs1,len_xs1,rest) ->
- case module_dot of
- Just m -> end_lex_id (Just m) (mk_var_token rxs) rest --OLD:_PK_ (reverse xs))) rest
- Nothing ->
- case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM rxs of
- Just kwd_token -> kwd_token : lexIface rest
- other -> token : lexIface cs end_lex_id Nothing (mk_var_token rxs) rest
- where
- rxs = packNChars (len_xs+len_xs1) (xs++xs1) -- OLD: _PK_ (reverse xs)
--}
mk_var_token pk_str =
let
f = _HEAD_ pk_str
else if isUpperISO f then ITconid pk_str
else ITvarsym pk_str
-{-
- mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n
- | f == ':' = ITconsym n
- | isAlpha f = ITvarid n
- | otherwise = ITvarsym n
- where
- n = _PK_ xs
--}
-
end_lex_id cont Nothing token buf = cont token buf
end_lex_id cont (Just (m,hif)) token buf =
case token of
{-
- Note that if the file we're processing ends with `hi-boot',
- we accept it on faith as having the right version.
- This is done so that .hi-boot files that comes with hsc
- don't have to be updated before every release, and it
- allows us to share .hi-boot files with versions of hsc
- that don't have .hi version checking (e.g., ghc-2.10's)
+ Note that if the name of the file we're processing ends
+ with `hi-boot', we accept it on faith as having the right
+ version. This is done so that .hi-boot files that comes
+ with hsc don't have to be updated before every release,
+ *and* it allows us to share .hi-boot files with versions
+ of hsc that don't have .hi version checking (e.g., ghc-2.10's)
If the version number is 0, the checking is also turned off.
+ (needed to deal with GHC.hi only!)
+
+ Once we can assume we're compiling with a version of ghc that
+ supports interface file checking, we can drop the special
+ pleading
-}
checkVersion :: Maybe Integer -> IfM ()
checkVersion mb@(Just v) s l
- | (v==0) || (v == PROJECTVERSION) = Succeeded ()
+ | (v==0) || (v == PROJECTVERSION) || opt_NoHiCheck = Succeeded ()
| otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
checkVersion mb@Nothing s l
| "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile l)) = Succeeded ()
projects / ghc-hetmet.git / commitdiff