From: simonpj Date: Fri, 24 Mar 2000 17:49:31 +0000 (+0000) Subject: [project @ 2000-03-24 17:49:29 by simonpj] X-Git-Tag: Approximately_9120_patches~4903 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6c872fff42025a842e8500ddbb13fdcca60eaf75;p=ghc-hetmet.git [project @ 2000-03-24 17:49:29 by simonpj] a) Small wibbles to do with inlining and floating b) Implement Ralf's request, so that one can write type F = forall a. a -> a f :: Int -> F f = ... The for-alls inside F are hoisted out to the top of the type signature for f. This applies uniformly to all user-written types --- diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index bf76243..7df3b66 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -220,7 +220,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr let n_val_binders = length val_binders --- max_inline_size = n_val_binders+2 + max_inline_size = n_val_binders+2 -- The idea is that if there is an INLINE pragma (inline is True) -- and there's a big body, we give a size of n_val_binders+2. This -- This is just enough to fail the no-size-increase test in callSiteInline, @@ -228,9 +228,9 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr -- but no more. -- Experimental thing commented in for now - max_inline_size = case cpr_info of - NoCPRInfo -> n_val_binders + 2 - ReturnsCPR -> n_val_binders + 1 +-- max_inline_size = case cpr_info of +-- NoCPRInfo -> n_val_binders + 2 +-- ReturnsCPR -> n_val_binders + 1 -- However, the wrapper for a CPR'd function is particularly good to inline, -- even in a boring context, because we may get to do update in place: @@ -624,7 +624,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont -- Constructors have compulsory unfoldings, but -- may have rules, in which case they are -- black listed till later - CoreUnfolding unf_template is_top is_cheap _ is_bot guidance -> + CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance -> let result | yes_or_no = Just unf_template @@ -632,8 +632,8 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont n_val_args = length arg_infos - ok_inside_lam = is_cheap || is_bot -- I'm experimenting with is_cheap - -- instead of is_value + ok_inside_lam = is_value || is_bot || (is_cheap && not is_top) + -- I'm experimenting with is_cheap && not is_top yes_or_no | black_listed = False @@ -718,6 +718,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont text "occ info:" <+> ppr occ, text "arg infos" <+> ppr arg_infos, text "interesting continuation" <+> ppr interesting_cont, + text "is value:" <+> ppr is_value, text "is cheap:" <+> ppr is_cheap, text "is bottom:" <+> ppr is_bot, text "is top-level:" <+> ppr is_top, diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 5594ece..cf7ed63 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -432,7 +432,7 @@ opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (2::Int) opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int) -opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.0::Float) +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for opt_UF_DearOp = ( 4 :: Int) diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index f88af6a..e252d73 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -57,7 +57,7 @@ import NativeInfo ( os, arch ) \end{code} \begin{code} -main = +main = stderr `seq` -- Bug fix. Sigh -- _scc_ "main" doIt classifyOpts \end{code} diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index a1f0283..b705f89 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.28 2000/03/23 17:45:22 simonpj Exp $ +$Id: Parser.y,v 1.29 2000/03/24 17:49:30 simonpj Exp $ Haskell grammar. @@ -326,7 +326,7 @@ topdecls :: { [RdrBinding] } | topdecl { [$1] } topdecl :: { RdrBinding } - : srcloc 'type' simpletype '=' type + : srcloc 'type' simpletype '=' sigtype { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) } | srcloc 'data' ctype '=' constrs deriving diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 0f47641..cdaff2e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -619,6 +619,10 @@ availNames :: AvailInfo -> [Name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns +addSysAvails :: AvailInfo -> [Name] -> AvailInfo +addSysAvails avail [] = avail +addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) + filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 6b1b90c..d15cd25 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -33,7 +33,7 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleD import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName, lookupOccRn, lookupImplicitOccRn, pprAvail, - availName, availNames, addAvailToNameSet, + availName, availNames, addAvailToNameSet, addSysAvails, FreeVars, emptyFVs ) import RnMonad @@ -265,10 +265,15 @@ loadDecl mod decls_map (version, decl) getDeclSysBinders new_name decl `thenRn` \ sys_bndrs -> let + full_avail = addSysAvails avail sys_bndrs + -- Add the sys-binders to avail. When we import the decl, + -- it's full_avail that will get added to the 'already-slurped' set (iSlurp) + -- If we miss out sys-binders, we'll read the decl multiple times! + main_name = availName avail new_decls_map = foldl add_decl decls_map - [ (name, (version, avail, name==main_name, (mod, decl'))) - | name <- sys_bndrs ++ availNames avail] + [ (name, (version, full_avail, name==main_name, (mod, decl'))) + | name <- availNames full_avail] add_decl decls_map (name, stuff) = WARN( name `elemNameEnv` decls_map, ppr name ) addToNameEnv decls_map name stuff diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 1531d8c..982acda 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -49,7 +49,7 @@ import Bag ( bagToList ) import List ( partition, nub ) import Outputable import SrcLoc ( SrcLoc ) -import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars +import CmdLineOpts ( opt_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars import Unique ( Uniquable(..) ) import UniqFM ( lookupUFM ) import ErrUtils ( Message ) @@ -159,11 +159,16 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn name `thenRn` \ name' -> bindTyVarsFVRn syn_doc tyvars $ \ tyvars' -> - rnHsType syn_doc ty `thenRn` \ (ty', ty_fvs) -> + rnHsPolyType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) -> returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) + -- For H98 we do *not* universally quantify on the RHS of a synonym + -- Silently discard context... but the tyvars in the rest won't be in scope + unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty + unquantify ty = ty + rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas tname dname dwname snames src_loc)) = pushSrcLocRn src_loc $ @@ -553,7 +558,7 @@ rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars --------------------------------------- rnHsPolyType doc (HsForAllTy Nothing ctxt ty) - -- From source code (no kinds on tyvars) + -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} = getLocalNameEnv `thenRn` \ name_env -> diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index ca22634..f95828c 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -122,6 +122,9 @@ ltLvl (Level maj1 min1) (Level maj2 min2) ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft *lambda* level to another + -- But it returns True regardless if l1 is the top level + -- We always like to float to the top! +ltMajLvl (Level 0 0) _ = True ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool @@ -202,9 +205,14 @@ lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v) lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit) lvlExpr ctxt_lvl env (_, AnnApp fun arg) - = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' -> + = lvl_fun fun `thenLvl` \ fun' -> lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' -> returnLvl (App fun' arg') + where + lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun + lvl_fun other = lvlExpr ctxt_lvl env fun + -- We don't do MFE on partial applications generally, + -- but we do if the function is big and hairy, like a case lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr) -- Don't float anything out of an InlineMe @@ -284,16 +292,7 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty) lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) | isUnLiftedType ty -- Can't let-bind it - || not (dest_lvl `ltMajLvl` ctxt_lvl) -- Does not escape a value lambda - -- A decision to float entails let-binding this thing, and we only do - -- that if we'll escape a value lambda. I considered doing it if it - -- would make the thing go to top level, but I found things like - -- concat = /\ a -> foldr ..a.. (++) [] - -- was getting turned into - -- concat = /\ a -> lvl a - -- lvl = /\ a -> foldr ..a.. (++) [] - -- which is pretty stupid. So for now at least, I don't let-bind things - -- simply because they could go to top level. + || not good_destination || exprIsTrivial expr -- Is trivial || (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom = -- Don't float it out @@ -309,6 +308,17 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) ty = exprType expr dest_lvl = destLevel env fvs (isFunction ann_expr) abs_vars = abstractVars dest_lvl env fvs + + good_destination = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda + || (isTopLvl dest_lvl && not strict_ctxt) -- Goes to the top + -- A decision to float entails let-binding this thing, and we only do + -- that if we'll escape a value lambda, or will go to the top level. + -- But beware + -- concat = /\ a -> foldr ..a.. (++) [] + -- was getting turned into + -- concat = /\ a -> lvl a + -- lvl = /\ a -> foldr ..a.. (++) [] + -- which is pretty stupid. Hence the strict_ctxt test \end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 4999db5..3fee836 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -34,8 +34,9 @@ import Maybes ( maybeToBool, catMaybes ) import Name ( isLocalName, setNameUnique ) import SimplMonad import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, - splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys + splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys ) +import DataCon ( dataConRepArity ) import TysPrim ( statePrimTyCon ) import Var ( setVarUnique ) import VarSet @@ -247,7 +248,7 @@ analyseCont in_scope cont analyse_arg subst (Note _ a) = analyse_arg subst a analyse_arg subst other = True - interesting_call_context (Stop _) = False + interesting_call_context (Stop ty) = canUpdateInPlace ty interesting_call_context (InlinePlease _) = True interesting_call_context (Select _ _ _ _ _) = True interesting_call_context (CoerceIt _ cont) = interesting_call_context cont @@ -274,6 +275,20 @@ discardInline :: SimplCont -> SimplCont discardInline (InlinePlease cont) = cont discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont) discardInline cont = cont + +-- Consider let x = in ... +-- If returns an explicit constructor, we might be able +-- to do update in place. So we treat even a thunk RHS context +-- as interesting if update in place is possible. We approximate +-- this by seeing if the type has a single constructor with a +-- small arity. But arity zero isn't good -- we share the single copy +-- for that case, so no point in sharing. + +canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of + Just (_, _, [dc]) -> arity == 1 || arity == 2 + where + arity = dataConRepArity dc + other -> False \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index ba847de..2f88b17 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -226,15 +226,18 @@ simplExprF (App fun arg) cont simplExprF fun (ApplyTo NoDup arg se cont) simplExprF (Case scrut bndr alts) cont - = getSubst `thenSmpl` \ subst -> + = getSubstEnv `thenSmpl` \ subst_env -> getSwitchChecker `thenSmpl` \ chkr -> - if switchIsOn chkr NoCaseOfCase then - -- If case-of-case is off, simply simplify the scrutinee and rebuild - simplExprC scrut (Stop (substTy subst (idType bndr))) `thenSmpl` \ scrut' -> - rebuild_case False scrut' bndr alts (substEnv subst) cont + if not (switchIsOn chkr NoCaseOfCase) then + -- Simplify the scrutinee with a Select continuation + simplExprF scrut (Select NoDup bndr alts subst_env cont) + else - -- But if it's on, we simplify the scrutinee with a Select continuation - simplExprF scrut (Select NoDup bndr alts (substEnv subst) cont) + -- If case-of-case is off, simply simplify the case expression + -- in a vanilla Stop context, and rebuild the result around it + simplExprC scrut (Select NoDup bndr alts subst_env + (Stop (contResultType cont))) `thenSmpl` \ case_expr' -> + rebuild case_expr' cont simplExprF (Let (Rec pairs) body) cont @@ -694,9 +697,14 @@ wantToExpose :: Int -> CoreExpr -> Bool -- v = E -- z = \w -> g v w -- Which is what we want; chances are z will be inlined now. +-- +-- This defn isn't quite like +-- exprIsCheap (it ignores non-cheap args) +-- exprIsValue (may not say True for a lone variable) +-- which is slightly weird wantToExpose n (Var v) = idAppIsCheap v n wantToExpose n (Lit l) = True -wantToExpose n (Lam _ e) = ASSERT( n==0 ) True -- We won't have applied \'s +wantToExpose n (Lam _ e) = True wantToExpose n (Note _ e) = wantToExpose n e wantToExpose n (App f (Type _)) = wantToExpose n f wantToExpose n (App f a) = wantToExpose (n+1) f @@ -737,10 +745,13 @@ simplVar var cont completeCall var occ cont = getBlackList `thenSmpl` \ black_list_fn -> - getSwitchChecker `thenSmpl` \ chkr -> getInScope `thenSmpl` \ in_scope -> + getSwitchChecker `thenSmpl` \ chkr -> let - black_listed = black_list_fn var + dont_use_rules = switchIsOn chkr DontApplyRules + no_case_of_case = switchIsOn chkr NoCaseOfCase + black_listed = black_list_fn var + (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont discard_inline_cont | inline_call = discardInline cont | otherwise = cont @@ -772,10 +783,10 @@ completeCall var occ cont -- won't occur for things that have specialisations till a later phase, so -- it's ok to try for inlining first. - prepareArgs (switchIsOn chkr NoCaseOfCase) var cont $ \ args' cont' -> + prepareArgs no_case_of_case var cont $ \ args' cont' -> let - maybe_rule | switchIsOn chkr DontApplyRules = Nothing - | otherwise = lookupRule in_scope var args' + maybe_rule | dont_use_rules = Nothing + | otherwise = lookupRule in_scope var args' in case maybe_rule of { Just (rule_name, rule_rhs) -> @@ -1026,7 +1037,7 @@ rebuild expr (InlinePlease cont) = rebuild (Note InlineCall expr) cont rebuild scrut (Select _ bndr alts se cont) - = rebuild_case True scrut bndr alts se cont + = rebuild_case scrut bndr alts se cont \end{code} Case elimination [see the code above] @@ -1114,7 +1125,7 @@ Blob of helper functions for the "case-of-something-else" situation. --------------------------------------------------------- -- Eliminate the case if possible -rebuild_case add_eval_info scrut bndr alts se cont +rebuild_case scrut bndr alts se cont | maybeToBool maybe_con_app = knownCon scrut (DataAlt con) args bndr alts se cont @@ -1127,7 +1138,7 @@ rebuild_case add_eval_info scrut bndr alts se cont simplExprF (head (rhssOfAlts alts)) cont) | otherwise - = complete_case add_eval_info scrut bndr alts se cont + = complete_case scrut bndr alts se cont where maybe_con_app = analyse (collectArgs scrut) @@ -1192,7 +1203,7 @@ canEliminateCase scrut bndr alts --------------------------------------------------------- -- Case of something else -complete_case add_eval_info scrut case_bndr alts se cont +complete_case scrut case_bndr alts se cont = -- Prepare case alternatives prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr)) impossible_cons alts `thenSmpl` \ better_alts -> @@ -1206,7 +1217,10 @@ complete_case add_eval_info scrut case_bndr alts se cont -- Deal with variable scrutinee - ( simplCaseBinder add_eval_info scrut case_bndr $ \ case_bndr' zap_occ_info -> + ( + getSwitchChecker `thenSmpl` \ chkr -> + simplCaseBinder (switchIsOn chkr NoCaseOfCase) + scrut case_bndr $ \ case_bndr' zap_occ_info -> -- Deal with the case alternatives simplAlts zap_occ_info impossible_cons diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index d9dc3a2..b52ef1f 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -30,7 +30,7 @@ import TcEnv ( tcExtendLocalValEnv, ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) import TcImprove ( tcImprove ) -import TcMonoType ( tcHsType, checkSigTyVars, +import TcMonoType ( tcHsSigType, checkSigTyVars, TcSigInfo(..), tcTySig, maybeSig, sigCtxt ) import TcPat ( tcPat ) @@ -857,7 +857,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) tcAddErrCtxt (valSpecSigCtxt name poly_ty) $ -- Get and instantiate its alleged specialised type - tcHsType poly_ty `thenTc` \ sig_ty -> + tcHsSigType poly_ty `thenTc` \ sig_ty -> -- Check that f has a more general type, and build a RHS for -- the spec-pragma-id at the same time diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index ccfd18a..3c39da1 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -33,7 +33,7 @@ import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, import TcBinds ( tcBindWithSigs, tcSpecSigs ) import TcUnify ( unifyKinds ) import TcMonad -import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope, +import TcMonoType ( kcHsType, tcHsTopType, tcExtendTopTyVarScope, tcContext, checkSigTyVars, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) @@ -128,7 +128,7 @@ kcClassDecl (ClassDecl context class_name where the_class_sigs = filter isClassOpSig class_sigs - kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty) + kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 9ab1460..f622d1c 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -35,7 +35,7 @@ import TcEnv ( tcInstId, tcLookupTyCon, tcLookupDataCon ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) -import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt ) +import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE ) import TcType ( TcType, TcTauType, @@ -699,7 +699,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty \begin{code} tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty = tcSetErrCtxt (exprSigCtxt in_expr) $ - tcHsType poly_ty `thenTc` \ sig_tc_ty -> + tcHsSigType poly_ty `thenTc` \ sig_tc_ty -> if not (isForAllTy sig_tc_ty) then -- Easy case diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index b87355d..37b7036 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -51,7 +51,6 @@ import TcMonad import TcType ( TcType, TcTyVar, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType ) -import TyCon ( isDataTyCon ) import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type ) import Name ( isLocallyDefined ) import Var ( TyVar ) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 0c32116..0d9ffac 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -49,7 +49,7 @@ import NameSet ( emptyNameSet ) import PrelInfo ( eRROR_ID ) import PprType ( pprConstraint ) import SrcLoc ( SrcLoc ) -import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings ) +import TyCon ( isSynTyCon, tyConDerivings ) import Type ( Type, isUnLiftedType, mkTyVarTys, splitSigmaTy, isTyVarTy, splitTyConApp_maybe, splitDictTy_maybe, diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 484aa3c..e213632 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -19,7 +19,7 @@ import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt ) import TcHsSyn ( TcMatch, TcGRHSs, TcStmt ) import TcMonad -import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt ) +import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt ) import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs ) import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars ) import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig ) @@ -175,7 +175,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt -- STEP 3: Unify with the rhs type signature if any (case maybe_rhs_sig of Nothing -> returnTc () - Just sig -> tcHsType sig `thenTc` \ sig_ty -> + Just sig -> tcHsSigType sig `thenTc` \ sig_ty -> -- Check that the signature isn't a polymorphic one, which -- we don't permit (at present, anyway) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 1d6087c..af02410 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,8 +4,8 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind, - tcContext, tcHsTyVar, kcHsTyVar, +module TcMonoType ( tcHsType, tcHsSigType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind, + tcContext, tcHsTyVar, kcHsTyVar, kcHsType, tcExtendTyVarScope, tcExtendTopTyVarScope, TcSigInfo(..), tcTySig, mkTcSig, maybeSig, checkSigTyVars, sigCtxt, sigPatCtxt @@ -32,7 +32,7 @@ import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr ) import TcUnify ( unifyKind, unifyKinds, unifyTypeKind ) import Type ( Type, PredType(..), ThetaType, UsageAnn(..), mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy, - mkUsForAllTy, zipFunTys, + mkUsForAllTy, zipFunTys, hoistForAllTys, mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, boxedTypeKind, unboxedTypeKind, tyVarsOfType, @@ -72,6 +72,18 @@ tcHsType and tcHsTypeKind tcHsType checks that the type really is of kind Type! \begin{code} +kcHsType :: RenamedHsType -> TcM c () + -- Kind-check the type +kcHsType ty = tc_type ty `thenTc_` + returnTc () + +tcHsSigType :: RenamedHsType -> TcM s TcType + -- Used for type sigs written by the programmer + -- Hoist any inner for-alls to the top +tcHsSigType ty + = tcHsType ty `thenTc` \ ty' -> + returnTc (hoistForAllTys ty') + tcHsType :: RenamedHsType -> TcM s TcType tcHsType ty = -- tcAddErrCtxt (typeCtxt ty) $ @@ -100,20 +112,22 @@ tcHsTopType :: RenamedHsType -> TcM s Type tcHsTopType ty = -- tcAddErrCtxt (typeCtxt ty) $ tc_type ty `thenTc` \ ty' -> - forkNF_Tc (zonkTcTypeToType ty') + forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ ty'' -> + returnTc (hoistForAllTys ty'') + +tcHsTopBoxedType :: RenamedHsType -> TcM s Type +tcHsTopBoxedType ty + = -- tcAddErrCtxt (typeCtxt ty) $ + tc_boxed_type ty `thenTc` \ ty' -> + forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ ty'' -> + returnTc (hoistForAllTys ty'') tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type) tcHsTopTypeKind ty = -- tcAddErrCtxt (typeCtxt ty) $ tc_type_kind ty `thenTc` \ (kind, ty') -> forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ zonked_ty -> - returnNF_Tc (kind, zonked_ty) - -tcHsTopBoxedType :: RenamedHsType -> TcM s Type -tcHsTopBoxedType ty - = -- tcAddErrCtxt (typeCtxt ty) $ - tc_boxed_type ty `thenTc` \ ty' -> - forkNF_Tc (zonkTcTypeToType ty') + returnNF_Tc (kind, hoistForAllTys zonked_ty) \end{code} @@ -415,7 +429,7 @@ tcTySig :: RenamedSig -> TcM s TcSigInfo tcTySig (Sig v ty src_loc) = tcAddSrcLoc src_loc $ - tcHsType ty `thenTc` \ sigma_tc_ty -> + tcHsSigType ty `thenTc` \ sigma_tc_ty -> mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> returnTc sig diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 7974073..88914ac 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -25,7 +25,7 @@ import TcEnv ( tcLookupValue, tcLookupClassByKey, tcLookupValueByKey, newLocalId, badCon ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) -import TcMonoType ( tcHsType ) +import TcMonoType ( tcHsSigType ) import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy ) @@ -142,7 +142,7 @@ tcPat tc_bndr (ParPatIn parend_pat) pat_ty = tcPat tc_bndr parend_pat pat_ty tcPat tc_bndr (SigPatIn pat sig) pat_ty - = tcHsType sig `thenTc` \ sig_ty -> + = tcHsSigType sig `thenTc` \ sig_ty -> -- Check that the signature isn't a polymorphic one, which -- we don't permit (at present, anyway) diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index c5cdf0c..1d9edb8 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -16,7 +16,7 @@ import TcMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) import TcType ( zonkTcTypes, newTyVarTy_OpenKind ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) -import TcMonoType ( tcHsType, tcHsTyVar, checkSigTyVars ) +import TcMonoType ( tcHsSigType, tcHsTyVar, checkSigTyVars ) import TcExpr ( tcExpr ) import TcEnv ( tcExtendLocalValEnv, newLocalId, tcExtendTyVarEnv @@ -104,7 +104,7 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) where new_id (RuleBndr var) = newTyVarTy_OpenKind `thenNF_Tc` \ ty -> returnNF_Tc (mkVanillaId var ty) - new_id (RuleBndrSig var rn_ty) = tcHsType rn_ty `thenTc` \ ty -> + new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty -> returnNF_Tc (mkVanillaId var ty) ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 73282fe..88b7428 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -374,7 +374,3 @@ pp_cycle str decls where name = tyClDeclName decl \end{code} - - - - diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 78c6f32..4508cb0 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -21,7 +21,7 @@ import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope, - tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType, + tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType, tcContext, tcHsTopTypeKind ) import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints ) @@ -35,18 +35,16 @@ import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon, markedStrict, notMarkedStrict, markedUnboxed ) import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) -import Id ( idUnfolding ) -import CoreUnfold ( unfoldingTemplate ) import FieldLabel import Var ( Id, TyVar ) import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) import Outputable -import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, +import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isSynTyCon, tyConDataCons, isNewTyCon ) import Type ( getTyVar, tyVarsOfTypes, mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, - mkTyVarTy, + mkTyVarTy, splitForAllTys, isForAllTy, mkArrowKind, mkArrowKinds, boxedTypeKind, isUnboxedType, Type, ThetaType, classesOfPreds ) @@ -54,6 +52,7 @@ import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) import Util ( equivClasses ) import FiniteMap ( FiniteMap, lookupWithDefaultFM ) +import CmdLineOpts ( opt_GlasgowExts ) \end{code} %************************************************************************ @@ -88,12 +87,12 @@ kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc) where kc_con (VanillaCon btys) = mapTc kc_bty btys `thenTc_` returnTc () kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2] `thenTc_` returnTc () - kc_con (NewCon ty _) = tcHsType ty `thenTc_` returnTc () + kc_con (NewCon ty _) = kcHsType ty kc_con (RecCon flds) = mapTc kc_field flds `thenTc_` returnTc () - kc_bty (Banged ty) = tcHsType ty - kc_bty (Unbanged ty) = tcHsType ty - kc_bty (Unpacked ty) = tcHsType ty + kc_bty (Banged ty) = kcHsType ty + kc_bty (Unbanged ty) = kcHsType ty + kc_bty (Unpacked ty) = kcHsType ty kc_field (_, bty) = kc_bty bty \end{code} @@ -112,6 +111,10 @@ tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) -> + -- If the RHS mentions tyvars that aren't in scope, we'll + -- quantify over them. With gla-exts that's right, but for H98 + -- we should complain. We can't do that here without falling into + -- a black hole, so we do it in rnDecl (TySynonym case) let -- Construct the tycon argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 33d59ba..9d15297 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -41,10 +41,10 @@ module Type ( repType, splitRepFunTys, splitNewType_maybe, typePrimRep, UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg, - mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, + mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - isForAllTy, applyTy, applyTys, mkPiType, + isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys, TauType, RhoType, SigmaType, PredType(..), ThetaType, ClassPred, ClassContext, mkClassPred, @@ -670,6 +670,22 @@ Note that we allow applications to be of usage-annotated- types, as an extension: we handle them by lifting the annotation outside. The argument, however, must still be unannotated. +\begin{code} +hoistForAllTys :: Type -> Type + -- Move all the foralls to the top + -- e.g. T -> forall a. a ==> forall a. T -> a +hoistForAllTys ty + = case hoist ty of { (tvs, body) -> mkForAllTys tvs body } + where + hoist :: Type -> ([TyVar], Type) + hoist ty = case splitFunTys ty of { (args, res) -> + case splitForAllTys res of { + ([], body) -> ([], ty) ; + (tvs1, body1) -> case hoist body1 of { (tvs2,body2) -> + (tvs1 ++ tvs2, mkFunTys args body2) + }}} +\end{code} + %************************************************************************ %* *