import Char ( ord, isSpace )
import List ( isSuffixOf )
-import CostCentre -- Pretty much all of it
-import IdInfo ( InlinePragInfo(..) )
-import Name ( isLowerISO, isUpperISO, mkModule )
-
+import IdInfo ( InlinePragInfo(..), CprInfo(..) )
+import Name ( isLowerISO, isUpperISO )
import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
-import BasicTypes ( NewOrData(..), IfaceFlavour(..) )
+import BasicTypes ( NewOrData(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile )
import Maybes ( MaybeErr(..) )
-import ErrUtils ( ErrMsg )
+import ErrUtils ( Message )
import Outputable
import FastString
#endif
import Addr
-
import PrelRead ( readRational__ ) -- Glasgow non-std
\end{code}
| ITinterface -- GHC-extension keywords
| ITexport
- | ITinstimport
+ | ITdepends
| ITforall
| ITletrec
| ITcoerce
- | ITinline
- | ITccall (Bool,Bool) -- (is_casm, may_gc)
+ | ITinlineCall
+ | ITinlineMe
+ | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc)
| ITdefaultbranch
| ITbottom
| ITinteger_lit
| ITlit_lit
| ITstring_lit
| ITtypeapp
+ | ITonce -- usage annotations
+ | ITmany
| ITarity
+ | ITrules
| ITspecialise
| ITnocaf
| ITunfold InlinePragInfo
| ITstrict ([Demand], Bool)
- | ITscc CostCentre
+ | ITcprinfo (CprInfo)
+ | ITscc
+ | ITsccAllCafs
| ITdotdot -- reserved symbols
| ITdcolon
| ITconid FAST_STRING
| ITvarsym FAST_STRING
| ITconsym FAST_STRING
- | ITqvarid (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITqconid (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
- | ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqvarid (FAST_STRING,FAST_STRING)
+ | ITqconid (FAST_STRING,FAST_STRING)
+ | ITqvarsym (FAST_STRING,FAST_STRING)
+ | ITqconsym (FAST_STRING,FAST_STRING)
| ITpragma StringBuffer
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
deriving Text -- debugging
-
-instance Text CostCentre -- cheat!
-
\end{code}
%************************************************************************
buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of
[ (ch, rest)] -> cont (ITchar ch) (stepOverLexeme (incLexeme buf'))
- -- strictness pragma and __scc treated specially.
+ -- strictness and cpr pragmas and __scc treated specially.
'_'# ->
case lookAhead# buf 1# of
'_'# -> case lookAhead# buf 2# of
'S'# ->
lex_demand cont (stepOnUntil (not . isSpace)
(stepOnBy# buf 3#)) -- past __S
+ 'M'# ->
+ lex_cpr cont (stepOnUntil (not . isSpace)
+ (stepOnBy# buf 3#)) -- past __M
's'# ->
case prefixMatch (stepOnBy# buf 3#) "cc" of
- Just buf' -> lex_scc cont
- (stepOnUntil (not . isSpace)
- (stepOverLexeme buf'))
+ Just buf' -> lex_scc cont (stepOverLexeme buf')
Nothing -> lex_id cont buf
_ -> lex_id cont buf
_ -> lex_id cont buf
= case read_em [] buf of
(stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
+lex_cpr cont buf =
+ case read_em [] buf of { (cpr_inf,buf') ->
+ ASSERT ( null (tail cpr_inf) )
+ cont (ITcprinfo $ head cpr_inf) (stepOverLexeme buf')
+ }
+ where
+ -- code snatched from lex_demand above
+ read_em acc buf =
+ case currentChar# buf of
+ '-'# -> read_em (NoCPRInfo : acc) (stepOn buf)
+ '('# -> do_unpack acc (stepOn buf)
+ ')'# -> (reverse acc, stepOn buf)
+ _ -> (reverse acc, buf)
+
+ do_unpack acc buf
+ = case read_em [] buf of
+ (stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest
+
------------------
lex_scc cont buf =
case currentChar# buf of
- '"'# ->
- case prefixMatch (stepOn buf) "CAFs." of
- Just buf' ->
- case untilChar# (stepOverLexeme buf') '\"'# of
- buf'' -> cont (ITscc (mkAllCafsCC (mkModule (lexemeToString buf'')) _NIL_))
- (stepOn (stepOverLexeme buf''))
- Nothing ->
- case prefixMatch (stepOn buf) "DICTs." of
- Just buf' ->
- case untilChar# (stepOverLexeme buf') '\"'# of
- buf'' -> cont (ITscc (mkAllDictsCC (mkModule (lexemeToString buf'')) _NIL_ True))
- (stepOn (stepOverLexeme buf''))
- Nothing ->
- let
- match_user_cc buf =
- case untilChar# buf '/'# of
- buf' ->
- let mod_name = mkModule (lexemeToString buf') in
--- case untilChar# (stepOn (stepOverLexeme buf')) '/'# of
--- buf'' ->
--- let grp_name = lexemeToFastString buf'' in
- case untilChar# (stepOn (stepOverLexeme buf')) '\"'# of
- buf'' ->
- -- The label may contain arbitrary characters, so it
- -- may have been escaped etc., hence we `read' it in to get
- -- rid of these meta-chars in the string and then pack it (again.)
- -- ToDo: do the same for module name (single quotes allowed in m-names).
- -- BTW, the code in this module is totally gruesome..
- let upk_label = _UNPK_ (lexemeToFastString buf'') in
- case reads ('"':upk_label++"\"") of
- ((cc_label,_):_) ->
- let cc_name = _PK_ cc_label in
- (mkUserCC cc_name mod_name _NIL_{-grp_name-},
- stepOn (stepOverLexeme buf''))
- _ ->
- trace ("trouble lexing scc label: " ++ upk_label ++ " , ignoring")
- (mkUserCC _NIL_ mod_name _NIL_{-grp_name-},
- stepOn (stepOverLexeme buf''))
- in
- case prefixMatch (stepOn buf) "CAF:" of
- Just buf' ->
- case match_user_cc (stepOverLexeme buf') of
- (cc, buf'') -> cont (ITscc (cafifyCC cc)) buf''
- Nothing ->
- case match_user_cc (stepOn buf) of
- (cc, buf'') -> cont (ITscc cc) buf''
- c -> cont (ITunknown [C# c]) (stepOn buf)
-
+ 'C'# -> cont ITsccAllCafs (stepOverLexeme (stepOn buf))
+ other -> cont ITscc buf
-----------
lex_num :: (IfaceToken -> IfM a) -> (Int -> Int) -> Int# -> IfM a
case expandWhile# is_ident buf of { buf1 ->
case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
case currentChar# buf' of
- '.'# -> munch HiFile
- '!'# -> munch HiBootFile
+ '.'# -> lex_qid cont lexeme (stepOn new_buf) just_a_conid
_ -> just_a_conid
where
cont (ITconid lexeme) new_buf
lexeme = lexemeToFastString buf'
new_buf = stepOverLexeme buf'
- munch hif = lex_qid cont lexeme hif (stepOn new_buf) just_a_conid
}}
-lex_qid cont mod hif buf just_a_conid =
+lex_qid cont mod buf just_a_conid =
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
- ']'# -> cont (ITqconid (mod,SLIT("[]"),hif)) (stepOnBy# buf 2#)
+ ']'# -> cont (ITqconid (mod,SLIT("[]"))) (stepOnBy# buf 2#)
_ -> just_a_conid
'('# -> -- Special case for (,,,)
-- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
case lookAhead# buf 1# of
'#'# -> case lookAhead# buf 2# of
- ','# -> lex_ubx_tuple cont mod hif (stepOnBy# buf 3#)
+ ','# -> lex_ubx_tuple cont mod (stepOnBy# buf 3#)
just_a_conid
_ -> just_a_conid
- ')'# -> cont (ITqconid (mod,SLIT("()"),hif)) (stepOnBy# buf 2#)
- ','# -> lex_tuple cont mod hif (stepOnBy# buf 2#) just_a_conid
+ ')'# -> cont (ITqconid (mod,SLIT("()"))) (stepOnBy# buf 2#)
+ ','# -> lex_tuple cont mod (stepOnBy# buf 2#) just_a_conid
_ -> just_a_conid
'-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,SLIT("->"),hif)) (stepOnBy# buf 2#)
- _ -> lex_id3 cont mod hif buf just_a_conid
- _ -> lex_id3 cont mod hif buf just_a_conid
+ '>'# -> cont (ITqconid (mod,SLIT("->"))) (stepOnBy# buf 2#)
+ _ -> lex_id3 cont mod buf just_a_conid
+ _ -> lex_id3 cont mod buf just_a_conid
-lex_id3 cont mod hif buf just_a_conid
+lex_id3 cont mod buf just_a_conid
| is_symbol c =
case expandWhile# is_symbol buf of { buf' ->
let
in
case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> just_a_conid; -- avoid M.:: etc.
- Nothing -> cont (mk_qvar_token mod hif lexeme) new_buf
+ Nothing -> cont (mk_qvar_token mod lexeme) new_buf
}}
| otherwise =
Nothing ->
case lookupUFM ifaceKeywordsFM lexeme of { -- only for iface files
Just kwd_token -> just_a_conid;
- Nothing -> cont (mk_qvar_token mod hif lexeme) new_buf
+ Nothing -> cont (mk_qvar_token mod lexeme) new_buf
}}}}
where c = currentChar# buf
(C# f) = _HEAD_ pk_str
tl = _TAIL_ pk_str
-mk_qvar_token m hif token =
+mk_qvar_token m token =
case mk_var_token token of
- ITconid n -> ITqconid (m,n,hif)
- ITvarid n -> ITqvarid (m,n,hif)
- ITconsym n -> ITqconsym (m,n,hif)
- ITvarsym n -> ITqvarsym (m,n,hif)
+ ITconid n -> ITqconid (m,n)
+ ITvarid n -> ITqvarid (m,n)
+ ITconsym n -> ITqconsym (m,n)
+ ITvarsym n -> ITqvarsym (m,n)
_ -> ITunknown (show token)
\end{code}
Horrible stuff for dealing with M.(,,,)
\begin{code}
-lex_tuple cont mod hif buf back_off =
+lex_tuple cont mod buf back_off =
go 2 buf
where
go n buf =
case currentChar# buf of
','# -> go (n+1) (stepOn buf)
- ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n),hif)) (stepOn buf)
+ ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf)
_ -> back_off
-lex_ubx_tuple cont mod hif buf back_off =
+lex_ubx_tuple cont mod buf back_off =
go 2 buf
where
go n buf =
case currentChar# buf of
','# -> go (n+1) (stepOn buf)
'#'# -> case lookAhead# buf 1# of
- ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n), hif))
+ ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n)))
(stepOnBy# buf 2#)
_ -> back_off
_ -> back_off
map (\ (x,y) -> (_PK_ x,y))
[ ("__interface", ITinterface),
("__export", ITexport),
- ("__instimport", ITinstimport),
+ ("__depends", ITdepends),
("__forall", ITforall),
("__letrec", ITletrec),
("__coerce", ITcoerce),
- ("__inline", ITinline),
+ ("__inline_me", ITinlineMe),
+ ("__inline_call", ITinlineCall),
("__DEFAULT", ITdefaultbranch),
("__bot", ITbottom),
("__integer", ITinteger_lit),
("__addr", ITaddr_lit),
("__litlit", ITlit_lit),
("__string", ITstring_lit),
+ ("__R", ITrules),
("__a", ITtypeapp),
+ ("__o", ITonce),
+ ("__m", ITmany),
("__A", ITarity),
("__P", ITspecialise),
("__C", ITnocaf),
("__u", ITunfold NoInlinePragInfo),
- ("__U", ITunfold IWantToBeINLINEd),
- ("__UU", ITunfold IMustBeINLINEd),
- ("__Unot", ITunfold IMustNotBeINLINEd),
- ("__Ux", ITunfold IAmALoopBreaker),
- ("__ccall", ITccall (False, False)),
- ("__ccall_GC", ITccall (False, True)),
- ("__casm", ITccall (True, False)),
- ("__casm_GC", ITccall (True, True)),
+ ("__ccall", ITccall (False, False, False)),
+ ("__ccall_GC", ITccall (False, False, True)),
+ ("__dyn_ccall", ITccall (True, False, False)),
+ ("__dyn_ccall_GC", ITccall (True, False, True)),
+ ("__casm", ITccall (False, True, False)),
+ ("__dyn_casm", ITccall (True, True, False)),
+ ("__casm_GC", ITccall (False, True, True)),
+ ("__dyn_casm_GC", ITccall (True, True, True)),
("/\\", ITbiglam)
]
\begin{code}
type IfM a = StringBuffer -- Input string
-> SrcLoc
- -> MaybeErr a ErrMsg
+ -> MaybeErr a {-error-}Message
returnIf :: a -> IfM a
returnIf a s l = Succeeded a
-----------------------------------------------------------------
-ifaceParseErr :: StringBuffer -> SrcLoc -> ErrMsg
+ifaceParseErr :: StringBuffer -> SrcLoc -> Message
ifaceParseErr s l
= hsep [ppr l, ptext SLIT("Interface-file parse error;"),
ptext SLIT("current input ="), text first_bit]
projects / ghc-hetmet.git / blobdiff