From: sewardj Date: Wed, 18 Oct 2000 14:04:12 +0000 (+0000) Subject: [project @ 2000-10-18 14:04:12 by sewardj] X-Git-Tag: Approximately_9120_patches~3540 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9bb6b6d0fbca6c82040027fab9859c9fcbc1ef7e;p=ghc-hetmet.git [project @ 2000-10-18 14:04:12 by sewardj] Make the desugarer compile. --- diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index b45b8c5..5090a9e 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -8,8 +8,9 @@ module Desugar ( deSugar ) where #include "HsVersions.h" -import CmdLineOpts ( opt_D_dump_ds ) -import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) +import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), + HsExpr(..), HsBinds(..), MonoBinds(..) ) import TcHsSyn ( TypecheckedRuleDecl ) import TcModule ( TcResults(..) ) import CoreSyn @@ -25,11 +26,11 @@ import Module ( Module ) import VarEnv import VarSet import Bag ( isEmptyBag ) -import CmdLineOpts ( opt_SccProfilingOn ) import CoreLint ( beginPass, endPass ) import ErrUtils ( doIfSet, pprBagOfWarnings ) import Outputable import UniqSupply ( UniqSupply ) +import HscTypes ( HomeSymbolTable ) \end{code} %************************************************************************ @@ -42,20 +43,24 @@ The only trick here is to get the @DsMonad@ stuff off to a good start. \begin{code} -deSugar :: Module +deSugar :: DynFlags + -> Module -> UniqSupply + -> HomeSymbolTable -> TcResults -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr]) -deSugar mod_name us (TcResults {tc_env = global_val_env, - tc_binds = all_binds, - tc_rules = rules, - tc_fords = fo_decls}) +deSugar dflags mod_name us hst + (TcResults {tc_env = global_val_env, + tc_pcs = pcs, + tc_binds = all_binds, + tc_rules = rules, + tc_fords = fo_decls}) = do - beginPass "Desugar" + beginPass dflags "Desugar" -- Do desugaring let (result, ds_warns) = - initDs us global_val_env mod_name + initDs dflags us (hst,pcs,global_val_env) mod_name (dsProgram mod_name all_binds rules fo_decls) (ds_binds, ds_rules, _, _, _) = result @@ -64,9 +69,10 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, (printErrs (pprBagOfWarnings ds_warns)) -- Lint result if necessary - endPass "Desugar" opt_D_dump_ds ds_binds + let do_dump_ds = dopt Opt_D_dump_ds dflags + endPass dflags "Desugar" do_dump_ds ds_binds - doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules)) + doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules)) return result diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index ee7e668..12df319 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -41,8 +41,9 @@ import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, ) import TysPrim ( addrPrimTy ) import PrelNames ( Uniquable(..), hasKey, - ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, - bindIOIdKey, makeStablePtrIdKey + ioTyConKey, deRefStablePtrName, returnIOIdKey, + bindIOName, + returnIOName, makeStablePtrName ) import Outputable @@ -213,7 +214,7 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn returnDs (\body -> body, orig_res_ty, res_ty) other -> -- The function returns t, so wrap the call in returnIO - dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId -> + dsLookupGlobalValue returnIOName `thenDs` \ retIOId -> returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body], funResultTy (applyTy (idType retIOId) orig_res_ty), -- We don't have ioTyCon conveniently to hand @@ -228,8 +229,8 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn (if isDyn then newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value -> - dsLookupGlobalValue deRefStablePtrIdKey `thenDs` \ deRefStablePtrId -> - dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> + dsLookupGlobalValue deRefStablePtrName `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue bindIOName `thenDs` \ bindIOId -> let the_deref_app = mkApps (Var deRefStablePtrId) [ Type stbl_ptr_to_ty, Var stbl_ptr ] @@ -336,11 +337,11 @@ dsFExportDynamic i ty mod_name ext_name cconv = dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (feb, fe, h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId -> + dsLookupGlobalValue makeStablePtrName `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] in - dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> + dsLookupGlobalValue bindIOName `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> let stbl_app cont ret_ty diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index a7cec0c..c39cddd 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -26,7 +26,7 @@ import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar ) import TysWiredIn ( nilDataCon, consDataCon ) import Match ( matchSimply ) -import PrelNames ( foldrIdKey, buildIdKey ) +import PrelNames ( foldrName, buildName ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -54,7 +54,7 @@ dsListComp quals elt_ty dfListComp c n quals `thenDs` \ result -> - dsLookupGlobalValue buildIdKey `thenDs` \ build_id -> + dsLookupGlobalValue buildName `thenDs` \ build_id -> returnDs (Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] result) \end{code} @@ -207,7 +207,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return - dsLookupGlobalValue foldrIdKey `thenDs` \ foldr_id -> + dsLookupGlobalValue foldrName `thenDs` \ foldr_id -> returnDs ( Var foldr_id `App` Type x_ty `App` Type b_ty diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 8b61bbb..5516cef 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -15,9 +15,9 @@ module DsMonad ( getSrcLocDs, putSrcLocDs, getModuleDs, getUniqueDs, + getDOptsDs, dsLookupGlobalValue, - ValueEnv, dsWarn, DsWarnings, DsMatchContext(..), DsMatchKind(..) @@ -33,13 +33,16 @@ import Var ( TyVar, setTyVarUnique ) import Outputable import SrcLoc ( noSrcLoc, SrcLoc ) import TcHsSyn ( TypecheckedPat ) -import TcEnv ( ValueEnv ) import Type ( Type ) import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, UniqSM, UniqSupply ) import Unique ( Unique ) import UniqFM ( lookupWithDefaultUFM_Directly ) import Util ( zipWithEqual ) +import Name ( Name, lookupNameEnv ) +import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), + TyThing(..), TypeEnv, lookupTypeEnv ) +import CmdLineOpts ( DynFlags ) infixr 9 `thenDs` \end{code} @@ -49,7 +52,8 @@ a @UniqueSupply@ and some annotations, which presumably include source-file location information: \begin{code} type DsM result = - UniqSupply + DynFlags + -> UniqSupply -> (Name -> Id) -- Lookup well-known Ids -> SrcLoc -- to put in pattern-matching error msgs -> Module -- module: for SCC profiling @@ -65,20 +69,21 @@ type DsWarnings = Bag WarnMsg -- The desugarer reports matches which a -- initDs returns the UniqSupply out the end (not just the result) -initDs :: UniqSupply +initDs :: DynFlags + -> UniqSupply -> (HomeSymbolTable, PersistentCompilerState, TypeEnv) -> Module -- module name: for profiling -> DsM a -> (a, DsWarnings) -initDs init_us (hst,pcs,local_type_env) mod action - = action init_us lookup noSrcLoc mod emptyBag +initDs dflags init_us (hst,pcs,local_type_env) mod action + = action dflags init_us lookup noSrcLoc mod emptyBag where -- This lookup is used for well-known Ids, -- such as fold, build, cons etc, so the chances are -- it'll be found in the package symbol table. That's -- why we don't merge all these tables - pst = pcsPST pcs + pst = pcs_PST pcs lookup n = case lookupTypeEnv pst n of { Just (AnId v) -> v ; other -> @@ -88,23 +93,24 @@ initDs init_us (hst,pcs,local_type_env) mod action case lookupNameEnv local_type_env n of Just (AnId v) -> v ; other -> pprPanic "initDS: lookup:" (ppr n) + }} thenDs :: DsM a -> (a -> DsM b) -> DsM b andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a -thenDs m1 m2 us genv loc mod warns +thenDs m1 m2 dflags us genv loc mod warns = case splitUniqSupply us of { (s1, s2) -> - case (m1 s1 genv loc mod warns) of { (result, warns1) -> - m2 result s2 genv loc mod warns1}} + case (m1 dflags s1 genv loc mod warns) of { (result, warns1) -> + m2 result dflags s2 genv loc mod warns1}} -andDs combiner m1 m2 us genv loc mod warns +andDs combiner m1 m2 dflags us genv loc mod warns = case splitUniqSupply us of { (s1, s2) -> - case (m1 s1 genv loc mod warns) of { (result1, warns1) -> - case (m2 s2 genv loc mod warns1) of { (result2, warns2) -> + case (m1 dflags s1 genv loc mod warns) of { (result1, warns1) -> + case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) -> (combiner result1 result2, warns2) }}} returnDs :: a -> DsM a -returnDs result us genv loc mod warns = (result, warns) +returnDs result dflags us genv loc mod warns = (result, warns) listDs :: [DsM a] -> DsM [a] listDs [] = returnDs [] @@ -151,29 +157,33 @@ it easier to read debugging output. \begin{code} newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs ty us genv loc mod warns +newSysLocalDs ty dflags us genv loc mod warns = case uniqFromSupply us of { assigned_uniq -> (mkSysLocal SLIT("ds") assigned_uniq ty, warns) } newSysLocalsDs tys = mapDs newSysLocalDs tys -newFailLocalDs ty us genv loc mod warns +newFailLocalDs ty dflags us genv loc mod warns = case uniqFromSupply us of { assigned_uniq -> (mkSysLocal SLIT("fail") assigned_uniq ty, warns) } -- The UserLocal bit just helps make the code a little clearer getUniqueDs :: DsM Unique -getUniqueDs us genv loc mod warns +getUniqueDs dflags us genv loc mod warns = case (uniqFromSupply us) of { assigned_uniq -> (assigned_uniq, warns) } +getDOptsDs :: DsM DynFlags +getDOptsDs dflags us genv loc mod warns + = (dflags, warns) + duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local us genv loc mod warns +duplicateLocalDs old_local dflags us genv loc mod warns = case uniqFromSupply us of { assigned_uniq -> (setIdUnique old_local assigned_uniq, warns) } cloneTyVarsDs :: [TyVar] -> DsM [TyVar] -cloneTyVarsDs tyvars us genv loc mod warns +cloneTyVarsDs tyvars dflags us genv loc mod warns = case uniqsFromSupply (length tyvars) us of { uniqs -> (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) } \end{code} @@ -181,7 +191,7 @@ cloneTyVarsDs tyvars us genv loc mod warns \begin{code} newTyVarsDs :: [TyVar] -> DsM [TyVar] -newTyVarsDs tyvar_tmpls us genv loc mod warns +newTyVarsDs tyvar_tmpls dflags us genv loc mod warns = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs -> (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) } \end{code} @@ -191,35 +201,31 @@ the @SrcLoc@ being carried around. \begin{code} uniqSMtoDsM :: UniqSM a -> DsM a -uniqSMtoDsM u_action us genv loc mod warns +uniqSMtoDsM u_action dflags us genv loc mod warns = (initUs_ us u_action, warns) getSrcLocDs :: DsM SrcLoc -getSrcLocDs us genv loc mod warns +getSrcLocDs dflags us genv loc mod warns = (loc, warns) putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc expr us genv old_loc mod warns - = expr us genv new_loc mod warns +putSrcLocDs new_loc expr dflags us genv old_loc mod warns + = expr dflags us genv new_loc mod warns dsWarn :: WarnMsg -> DsM () -dsWarn warn us genv loc mod warns = ((), warns `snocBag` warn) +dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn) \end{code} \begin{code} getModuleDs :: DsM Module -getModuleDs us genv loc mod warns = (mod, warns) +getModuleDs dflags us genv loc mod warns = (mod, warns) \end{code} \begin{code} dsLookupGlobalValue :: Name -> DsM Id -dsLookupGlobalValue key us genv loc mod warns - = (result, warns) - where - result = case lookupNameEnv genv name of - Just (AnId v) -> v - Nothing -> pprPanic "dsLookupGlobalValue:" (ppr name) +dsLookupGlobalValue name dflags us genv loc mod warns + = (genv name, warns) \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 7446c22..f27b78c 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -63,8 +63,8 @@ import TysWiredIn ( nilDataCon, consDataCon, ) import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) -import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey, - plusIntegerIdKey, timesIntegerIdKey ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name, + plusIntegerName, timesIntegerName ) import Outputable import UnicodeUtil ( stringToUtf8 ) \end{code} @@ -384,8 +384,8 @@ mkIntegerLit i -- integral literals. This improves constant folding. | otherwise -- Big, so start from a string - = dsLookupGlobalValue plusIntegerIdKey `thenDs` \ plus_id -> - dsLookupGlobalValue timesIntegerIdKey `thenDs` \ times_id -> + = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id -> + dsLookupGlobalValue timesIntegerName `thenDs` \ times_id -> let plus a b = Var plus_id `App` a `App` b times a b = Var times_id `App` a `App` b @@ -420,11 +420,11 @@ mkStringLitFS str returnDs (mkConsExpr charTy the_char (mkNilExpr charTy)) | all safeChar chars - = dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id -> + = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id -> returnDs (App (Var unpack_id) (Lit (MachStr str))) | otherwise - = dsLookupGlobalValue unpackCStringUtf8IdKey `thenDs` \ unpack_id -> + = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id -> returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars))))) where diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 7f6136a..f65de3c 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,9 +8,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w #include "HsVersions.h" -import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns, - opt_WarnSimplePatterns - ) +import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) import HsSyn import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) import DsHsSyn ( outPatType ) @@ -45,7 +43,12 @@ matchExport :: [Id] -- Vars rep'ing the exprs we're matching with -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) + +matchExport vars qs + = getDOptsDs `thenDs` \ dflags -> + matchExport_really dflags vars qs + +matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | incomplete && shadow = dsShadowWarn ctx eqns_shadow `thenDs` \ () -> dsIncompleteWarn ctx pats `thenDs` \ () -> @@ -59,8 +62,10 @@ matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | otherwise = match vars qs where (pats,indexs) = check qs - incomplete = opt_WarnIncompletePatterns && (length pats /= 0) - shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns + incomplete = dopt Opt_WarnIncompletePatterns dflags + && (length pats /= 0) + shadow = dopt Opt_WarnOverlappingPatterns dflags + && sizeUniqSet indexs < no_eqns no_eqns = length qs unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs) eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns @@ -701,20 +706,22 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper kind matches error_string - = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> + = getDOptsDs `thenDs` \ dflags -> + flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> let EqnInfo _ _ arg_pats _ : _ = eqns_info in - mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> - match_fun new_vars eqns_info `thenDs` \ match_result -> + mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> + match_fun dflags new_vars eqns_info `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) - where match_fun = case kind of - LambdaMatch | opt_WarnSimplePatterns -> matchExport - | otherwise -> match - _ -> matchExport + where match_fun dflags + = case kind of + LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -749,10 +756,12 @@ matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat -> MatchResult -> DsM MatchResult matchSinglePat (Var var) ctx pat match_result - = match_fn [var] [EqnInfo 1 ctx [pat] match_result] + = getDOptsDs `thenDs` \ dflags -> + match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result] where - match_fn | opt_WarnSimplePatterns = matchExport - | otherwise = match + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchExport + | otherwise = match matchSinglePat scrut ctx pat match_result = selectMatchVar pat `thenDs` \ var ->