X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FLex.lhs;h=5e57258acdf804d9d22e888550ba34482a654aca;hb=6ee2f67e582427f931c21c1fc58f62f8619d40b7;hp=6bed0a8a2b432db0a401326649786995f00a369a;hpb=a20c26e871de939c9708892839787404420554ca;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 6bed0a8..5e57258 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -35,9 +35,8 @@ module Lex ( import Char ( ord, isSpace ) import List ( isSuffixOf ) -import IdInfo ( InlinePragInfo(..) ) +import IdInfo ( InlinePragInfo(..), CprInfo(..) ) import Name ( isLowerISO, isUpperISO ) -import Module ( IfaceFlavour, hiFile, hiBootFile ) import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck ) import Demand ( Demand(..) {- instance Read -} ) @@ -120,11 +119,12 @@ data IfaceToken | ITinterface -- GHC-extension keywords | ITexport - | ITinstimport + | ITdepends | ITforall | ITletrec | ITcoerce - | ITinline + | ITinlineCall + | ITinlineMe | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc) | ITdefaultbranch | ITbottom @@ -135,14 +135,17 @@ data IfaceToken | ITlit_lit | ITstring_lit | ITtypeapp + | ITonce -- usage annotations + | ITmany | ITarity + | ITrules | ITspecialise | ITnocaf | ITunfold InlinePragInfo | ITstrict ([Demand], Bool) + | ITcprinfo (CprInfo) | ITscc | ITsccAllCafs - | ITsccAllDicts | ITdotdot -- reserved symbols | ITdcolon @@ -174,10 +177,10 @@ data IfaceToken | 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 @@ -269,13 +272,16 @@ lexIface cont buf = 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 (stepOverLexeme buf') @@ -351,11 +357,28 @@ lex_demand 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 'C'# -> cont ITsccAllCafs (stepOverLexeme (stepOn buf)) - 'D'# -> cont ITsccAllDicts (stepOverLexeme (stepOn buf)) other -> cont ITscc buf ----------- @@ -461,8 +484,7 @@ lex_con cont buf = 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 @@ -470,33 +492,32 @@ lex_con cont buf = 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 @@ -505,7 +526,7 @@ lex_id3 cont mod hif buf just_a_conid 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 = @@ -523,7 +544,7 @@ lex_id3 cont mod hif buf just_a_conid 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 @@ -539,12 +560,12 @@ mk_var_token pk_str (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} @@ -552,23 +573,23 @@ mk_qvar_token m hif token = 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 @@ -583,11 +604,12 @@ ifaceKeywordsFM = listToUFM $ 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), @@ -596,15 +618,14 @@ ifaceKeywordsFM = listToUFM $ ("__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, False)), ("__ccall_GC", ITccall (False, False, True)),