needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel,
- pprCLabel, pprCLabel_asm
+ pprCLabel
+#if ! OMIT_NATIVE_CODEGEN
+ , pprCLabel_asm
+#endif
#ifdef GRAN
, isSlowEntryCCodeBlock
import AbsCLoop ( CtrlReturnConvention(..),
ctrlReturnConvAlg
)
+#if ! OMIT_NATIVE_CODEGEN
import NcgLoop ( underscorePrefix, fmtAsmLbl )
+#endif
import CStrings ( pp_cSEP )
import Id ( externallyVisibleId, cmpId_withSpecDataCon,
\begin{code}
-- specialised for PprAsm: saves lots of arg passing in NCG
+#if ! OMIT_NATIVE_CODEGEN
pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl)
+#endif
pprCLabel :: PprStyle -> CLabel -> Unpretty
)
import Maybes ( catMaybes )
import Name ( isLocallyDefined )
+#ifdef DEBUG
import PprAbsC ( pprAmode )
+#endif
import PprStyle ( PprStyle(..) )
import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
import Unpretty ( uppShow )
mkCoLetsNoUnboxed [] expr = expr
mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
---mkCoLetrecNoUnboxed :: [(Id, CoreExpr)] -- bindings
--- -> CoreExpr -- body
--- -> CoreExpr -- result
+mkCoLetrecNoUnboxed :: [(GenId (GenType a b), GenCoreExpr (GenId (GenType a b)) c d e)]
+ -> GenCoreExpr (GenId (GenType a b)) c d e
+ -> GenCoreExpr (GenId (GenType a b)) c d e
mkCoLetrecNoUnboxed [] body = body
mkCoLetrecNoUnboxed binds body
import DsLoop -- break dsExpr-ish loop
import HsSyn -- lots of things
+ hiding ( collectBinders{-also in CoreSyn-} )
import CoreSyn -- lots of things
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
- TypecheckedBind(..), TypecheckedMonoBinds(..) )
+ TypecheckedBind(..), TypecheckedMonoBinds(..),
+ TypecheckedPat(..)
+ )
import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
import DsMonad
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
import PprCore--ToDo:rm
-import PprType--ToDo:rm
+import PprType ( GenTyVar ) --ToDo:rm
import Usage--ToDo:rm
import Unique--ToDo:rm
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
Match, Qual, HsBinds, Stmt, PolyType )
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
- TypecheckedRecordBinds(..)
+ TypecheckedRecordBinds(..), TypecheckedPat(..)
)
import CoreSyn
import DsCCall ( dsCCall )
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
- mkErrorAppDs, showForErr
+ mkErrorAppDs, showForErr, EquationInfo,
+ MatchResult
)
import Match ( matchWrapper )
)
import Literal ( mkMachInt, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
+import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
import DsLoop -- break dsExpr-ish loop
import HsSyn ( Qual(..), HsExpr, HsBinds )
-import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) )
+import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
import DsHsSyn ( outPatType )
import CoreSyn
import DsLoop -- here for paranoia-checking reasons
-- and to break dsExpr/dsBinds-ish loop
-import HsSyn
+import HsSyn hiding ( collectBinders{-also from CoreSyn-} )
import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..),
TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
-import TcHsSyn ( TypecheckedHsExpr(..) )
-import CoreSyn ( CoreExpr(..) )
+import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
+ TypecheckedPat(..)
+ )
+import CoreSyn ( CoreExpr(..), CoreBinding(..) )
import DsMonad
import DsUtils
import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import CmdLineOpts ( opt_ProduceHi )
import FieldLabel ( FieldLabel{-instance NamedThing-} )
+import FiniteMap ( fmToList )
import HsSyn
import Id ( idType, dataConSig, dataConFieldLabels,
dataConStrictMarks, StrictnessMark(..),
\begin{code}
ifaceUsages Nothing{-no iface handle-} _ = return ()
-ifaceUsages (Just if_hdl) version_info
- = hPutStr if_hdl "__usages__\nFoo 1" -- a stub, obviously
+ifaceUsages (Just if_hdl) usages
+ | null usages_list
+ = return ()
+ | otherwise
+ = hPutStr if_hdl "__usages__\n" >>
+ hPutStr if_hdl (ppShow 10000 (ppAboves (map pp_uses usages_list)))
+ where
+ usages_list = fmToList usages
+
+ pp_uses (m, (mv, versions))
+ = ppBesides [ppPStr m, ppSP, ppInt mv, ppPStr SLIT(" :: "),
+ pp_versions (fmToList versions), ppSemi]
\end{code}
\begin{code}
ifaceVersions Nothing{-no iface handle-} _ = return ()
ifaceVersions (Just if_hdl) version_info
- = hPutStr if_hdl "\n__versions__\nFoo 1" -- a stub, obviously
+ | null version_list
+ = return ()
+ | otherwise
+ = hPutStr if_hdl "\n__versions__\n" >>
+ hPutStr if_hdl (ppShow 10000 (pp_versions version_list))
+ where
+ version_list = fmToList version_info
+
+pp_versions nvs
+ = ppInterleave ppComma [ ppCat [ppPStr n, ppInt v] | (n,v) <- nvs ]
\end{code}
\begin{code}
import HsPragmas ( noGenPragmas, noClassOpPragmas )
import SrcLoc ( mkSrcLoc2 )
-import Util ( panic, assertPanic )
+import Util ( mapAndUnzip, panic, assertPanic )
\end{code}
%************************************************************************
cvFunMonoBind sf matches
= (head srcfuns, head infixdefs, cvMatches sf False matches)
where
- (srcfuns, infixdefs) = unzip (map get_mdef matches)
+ (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
-- ToDo: Check for consistent srcfun and infixdef
get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
lexIface :: String -> [IfaceToken]
lexIface str
- = case str of
+ = _scc_ "Lexer"
+ case str of
[] -> []
-- whitespace and comments
-- ]}) $
findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files ->
- newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
+ newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) ->
let
\begin{code}
{- TESTING:
-pprPIface (ParsedIface m v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
+pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
= ppAboves [
ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
case mv of { Nothing -> ppNil; Just n -> ppInt n }],
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
import Pretty
-import UniqFM ( lookupUFM )
+import UniqFM ( lookupUFM, ufmToList{-ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
- UniqSet(..) )
+ UniqSet(..)
+ )
import Util ( Ord3(..), removeDups, panic )
\end{code}
precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
+ -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
case cmp op1_prec op_prec of
LT_ -> rearrange
EQ_ -> case (op1_fix, op_fix) of
lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
lookupFixity op
= getExtraRn `thenRn` \ fixity_fm ->
+ -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $
case lookupUFM fixity_fm op of
Nothing -> returnRn (INFIXL, 9)
Just (InfixL _ n) -> returnRn (INFIXL, n)
unionBags, unionManyBags, isEmptyBag, bagToList )
import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, plusFM_C, eltsFM,
- fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-}
+import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
+ fmToList, delListFromFM, sizeFM, foldFM, unitFM,
+ plusFM_C, keysFM{-ToDo:rm-}
)
import Maybes ( maybeToBool )
import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) )
findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
findHiFiles dirs sysdirs
- = hPutStr stderr " findHiFiles " >>
+ = --hPutStr stderr " findHiFiles " >>
do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
- hPutStr stderr " done\n" >>
+ --hPutStr stderr " done\n" >>
return result
where
do_dirs env [] = return env
do_dirs new_env dirs
-------
do_dir env dir
- = hPutStr stderr "D" >>
+ = --hPutStr stderr "D" >>
getDirectoryContents dir >>= \ entries ->
do_entries env entries
where
do_entry env e
= case (acceptable_hi (reverse e)) of
Nothing -> --trace ("Deemed uncool:"++e) $
- hPutStr stderr "." >>
+ --hPutStr stderr "." >>
return env
Just mod ->
let
in
case (lookupFM env pmod) of
Nothing -> --trace ("Adding "++mod++" -> "++e) $
- hPutStr stderr "!" >>
+ --hPutStr stderr "!" >>
return (addToFM env pmod (dir ++ '/':e))
-- ToDo: use DIR_SEP, not /
Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
- hPutStr stderr "." >>
+ --hPutStr stderr "." >>
return env
-------
acceptable_hi rev_e -- looking at pathname *backwards*
where
want_iface iface orig_fm
| want_orig_iface
- = case lookupFM orig_fm of
+ = case lookupFM orig_fm mod of
Nothing -> Failed (noOrigIfaceErr mod)
Just orig_iface -> Succeeded orig_iface
| otherwise
where
dup_merge str ppr_dup dup1 dup2
= pprTrace "mergeIfaces:"
- (ppCat [ppPStr mod, ppPStr mod1, ppStr ": dup", ppStr str, ppStr "decl",
+ (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
ppr_dup dup1, ppr_dup dup2]) $
dup2
-> IO (MaybeErr ParsedIface Error)
readIface file mod
- = hPutStr stderr (" reading "++file) >>
+ = --hPutStr stderr (" reading "++file) >>
readFile file `thenPrimIO` \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> hPutStr stderr " parsing" >>
+ Right contents -> --hPutStr stderr " parsing" >>
let parsed = parseIface contents in
- hPutStr stderr " done\n" >>
- return (Succeeded (init_merge mod parsed))
+ --hPutStr stderr " done\n" >>
+ return (
+ case parsed of
+ Failed _ -> parsed
+ Succeeded p -> Succeeded (init_merge mod p)
+ )
where
init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
= ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
-- finalize what we want to say we learned about the
-- things we used
- finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
+ finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
\ usage_stuff@(usage_info, version_info, instance_mods) ->
return (HsModule modname iface_version exports imports fixities
\begin{code}
finalIfaceInfo ::
IfaceCache -- iface cache
+ -> Module -- this module's name
-> RnEnv
-> [RenamedInstDecl]
-- -> [RnName] -- all imported names required
VersionsMap, -- info about version numbers
[Module]) -- special instance modules
-finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
+finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
=
pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+ let
+ val_stuff@(val_usages, val_versions)
+ = foldFM process_item (emptyFM, emptyFM){-init-} qual
- return (emptyFM, emptyFM, [])
+ (all_usages, all_versions)
+ = foldFM process_item val_stuff{-keep going-} tc_qual
+ in
+ return (all_usages, all_versions, [])
+ where
+ process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
+ -> (UsagesMap, VersionsMap) -- input
+ -> (UsagesMap, VersionsMap) -- output
+
+ process_item (n,m) rn as_before@(usages, versions)
+ | irrelevant rn
+ = as_before
+ | m == modname -- this module => add to "versions"
+ = (usages, addToFM versions n 1{-stub-})
+ | otherwise -- from another module => add to "usages"
+ = (add_to_usages usages m n 1{-stub-}, versions)
+
+ irrelevant (RnConstr _ _) = True -- We don't report these in their
+ irrelevant (RnField _ _) = True -- own right in usages/etc.
+ irrelevant (RnClassOp _ _) = True
+ irrelevant _ = False
+
+ add_to_usages usages m n version
+ = addToFM usages m (
+ case (lookupFM usages m) of
+ Nothing -> -- nothing for this module yet...
+ (1{-stub-}, unitFM n version)
+
+ Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
+ (mversion, addToFM mstuff n version)
+ )
\end{code}
Just exp -> exp
Nothing -> exp_fn n
- n = mkTopLevName uniq orig locn exp (occ_fn n)
+ n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s
in
addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_`
addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
then [{- no "import Prelude" -}]
else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
+ prel_imps -- WDP: Just guessing on this defn... ToDo
+ = [ imp | imp@(ImportDecl mod _ _ _ _) <- the_imps, fromPrelude mod ]
+
prel_loc = mkBuiltinSrcLoc
(uniq_imps, imp_dups) = removeDups cmp_mod the_imps
>>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
accumulate (map (checkOrigIE iface_cache) chk_ies)
>>= \ chk_errs_warns ->
- accumulate (map (getFixityDecl iface_cache) (bagToList ie_vals))
+ let
+ final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
+ final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
+ in
+ accumulate (map (getFixityDecl iface_cache) (bagToList final_vals))
>>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
- final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals
- final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
-
unquals = if qual then emptyBag
else mapBag pair_as (ie_vals `unionBags` ie_tcs)
(vals, tcs, ies_left) = do_builtin ies
-getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
= (map mkAllIE (eltsFM exps), [], emptyBag)
-getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
= (map mkAllIE (eltsFM exps_left), found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
-getOrigIEs (ParsedIface _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
+getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
= (map fst found_ies, found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
Succeeded decl -> return (do_decl decl)
-getFixityDecl iface_cache rn
+getFixityDecl iface_cache (_,rn)
= let
(mod, str) = moduleNamePair rn
in
case maybe_iface of
Failed err ->
return (Nothing, unitBag err)
- Succeeded (ParsedIface _ _ _ _ _ _ _ fixes _ _ _ _) ->
+ Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
case lookupFM fixes str of
Nothing -> return (Nothing, emptyBag)
Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag)
(imp_flag, imp_locs) = imp_fn n
- n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n)
+ n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s
in
returnRn n
\end{code}
SpecialiseData) -- specialisation data
core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
- = _scc_ "Core2Core"
- if null core_todos then -- very rare, I suspect...
+ = if null core_todos then -- very rare, I suspect...
-- well, we still must do some renumbering
return (
(substCoreBindings nullIdEnv nullTyVarEnv binds us,
[CostCentre])) -- "extern" cost-centres
stg2stg stg_todos module_name ppr_style us binds
- = _scc_ "Stg2Stg"
- case (splitUniqSupply us) of { (us4now, us4later) ->
+ = case (splitUniqSupply us) of { (us4now, us4later) ->
(if do_verbose_stg2stg then
hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
plusFM,
plusFM_C,
minusFM,
+ foldFM,
IF_NOT_GHC(intersectFM COMMA)
IF_NOT_GHC(intersectFM_C COMMA)
- IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA)
+ IF_NOT_GHC(mapFM COMMA filterFM COMMA)
sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
projects / ghc-hetmet.git / commitdiff