diff options
author | Max Bolingbroke <batterseapower@hotmail.com> | 2012-03-07 17:28:21 +0000 |
---|---|---|
committer | Max Bolingbroke <batterseapower@hotmail.com> | 2012-03-07 17:28:21 +0000 |
commit | 4f070dd16ee31f38aff931f4b7b0ce562dcb98f4 (patch) | |
tree | dd41663f9b3fc6934e573c6f8ee2106db8259192 | |
parent | feeedb3ccf4977eb028924d072244237ff6e3984 (diff) | |
parent | 28f783f1c367784e0adcac2447682061a38f2ba3 (diff) | |
download | haskell-4f070dd16ee31f38aff931f4b7b0ce562dcb98f4.tar.gz |
Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc into unboxed-tuple-argumentsunboxed-tuple-arguments
-rw-r--r-- | aclocal.m4 | 5 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUnfold.lhs | 2 | ||||
-rw-r--r-- | compiler/deSugar/DsBinds.lhs | 31 | ||||
-rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 8 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 9 | ||||
-rw-r--r-- | compiler/main/DriverPipeline.hs | 13 | ||||
-rw-r--r-- | compiler/main/TidyPgm.lhs | 66 | ||||
-rw-r--r-- | compiler/rename/RnPat.lhs | 8 | ||||
-rw-r--r-- | compiler/simplCore/CoreMonad.lhs | 11 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.lhs | 2 | ||||
-rw-r--r-- | compiler/specialise/Specialise.lhs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.lhs | 45 | ||||
-rw-r--r-- | compiler/typecheck/TcPat.lhs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 43 | ||||
-rw-r--r-- | compiler/utils/Outputable.lhs | 66 | ||||
-rw-r--r-- | compiler/utils/Platform.hs | 2 |
16 files changed, 183 insertions, 134 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 05470196dd..6d80ad3759 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -223,7 +223,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], netbsd) test -z "[$]2" || eval "[$]2=OSNetBSD" ;; - dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + haiku) + test -z "[$]2" || eval "[$]2=OSHaiku" + ;; + dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) test -z "[$]2" || eval "[$]2=OSUnknown" ;; *) diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 930041dea4..96a1abdcbe 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -863,7 +863,7 @@ tryUnfolding dflags id lone_variable -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) + = pprTrace ("Considering inlining: " ++ showSDocDump (ppr id)) (vcat [text "arg infos" <+> ppr arg_infos, text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 09ab98fff1..4f94a1c3e9 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -153,8 +153,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abs_exports = exports, abs_ev_binds = ev_binds , abs_binds = binds }) + -- See Note [Desugaring AbsBinds] = do { bind_prs <- ds_lhs_binds binds - ; let core_bind = Rec (fromOL bind_prs) + ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs + | (lcl_id, rhs) <- fromOL bind_prs ] -- Monomorphic recursion possible, hence Rec tup_expr = mkBigCoreVarTup locals @@ -176,13 +178,28 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts mkVarApps (Var poly_tup_id) (tyvars ++ dicts) rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = addIdSpecialisations global rules + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. ; return ((global', rhs) `consOL` spec_binds) } ; export_binds_s <- mapM mk_bind exports ; return ((poly_tup_id, poly_tup_rhs) `consOL` concatOL export_binds_s) } + where + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + add_inline :: Id -> Id -- tran + add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id ------------------------ makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) @@ -219,6 +236,16 @@ dictArity :: [Var] -> Arity dictArity dicts = count isId dicts \end{code} +[Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + Note [Rules and inlining] ~~~~~~~~~~~~~~~~~~~~~~~~~ Common special case: no type or dictionary abstraction diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index bb8b337a00..f756578e2d 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -175,12 +175,12 @@ data HsBindLR idL idR -- of this last construct.) data ABExport id - = ABE { abe_poly :: id + = ABE { abe_poly :: id -- Any INLINE pragmas is attached to this Id , abe_mono :: id - , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] + , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags } - deriving (Data, Typeable) + , abe_prags :: TcSpecPrags -- SPECIALISE pragmas + } deriving (Data, Typeable) placeHolderNames :: NameSet -- Used for the NameSet in FunBind and PatBind prior to the renamer diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a1cd558bc0..0de092742c 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1283,8 +1283,13 @@ tcIfaceGlobal name -- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name - ; return (tyThingTyCon thing) } +tcIfaceTyCon (IfaceTc name) + = do { thing <- tcIfaceGlobal name + ; case thing of -- A "type constructor" can be a promoted data constructor + -- c.f. Trac #5881 + ATyCon tc -> return tc + ADataCon dc -> return (buildPromotedDataCon dc) + _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) } tcIfaceCoAxiom :: Name -> IfL CoAxiom tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index fab7600c01..488df37a79 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1176,14 +1176,17 @@ runPhase As input_fn dflags = do llvmVer <- io $ figureLlvmVersion dflags return $ case llvmVer of - Just n | n >= 30 -> SysTools.runClang - _ -> SysTools.runAs + -- using cGccLinkerOpts here but not clear if + -- opt_c isn't a better choice + Just n | n >= 30 -> + (SysTools.runClang, cGccLinkerOpts) + + _ -> (SysTools.runAs, getOpts dflags opt_a) | otherwise - = return SysTools.runAs + = return (SysTools.runAs, getOpts dflags opt_a) - as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a + (as_prog, as_opts) <- whichAsProg let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 34afd5ca0e..01de9af4ee 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -309,6 +309,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; omit_prags = dopt Opt_OmitInterfacePragmas dflags ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = xopt Opt_TemplateHaskell dflags + ; data_kinds = xopt Opt_DataKinds dflags + ; no_trim_types = th || data_kinds + -- See Note [When we can't trim types] } ; showPass dflags CoreTidy @@ -334,7 +337,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] - ; tidy_type_env = tidyTypeEnv omit_prags th export_set + ; tidy_type_env = tidyTypeEnv omit_prags no_trim_types export_set (extendTypeEnvWithIds type_env final_ids) ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts @@ -410,7 +413,7 @@ lookup_dfun type_env dfun_id -------------------------- tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> Bool -- Template Haskell is on + -> Bool -- Type-trimming flag -> NameSet -> TypeEnv -> TypeEnv -- The competed type environment is gotten from @@ -423,11 +426,11 @@ tidyTypeEnv :: Bool -- Compiling without -O, so omit prags -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags th exports type_env +tidyTypeEnv omit_prags no_trim_types exports type_env = let type_env1 = filterNameEnv (not . isWiredInName . getName) type_env -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1 + type_env2 | omit_prags = mapNameEnv (trimThing no_trim_types exports) type_env1 | otherwise = type_env1 -- (2) trimmed if necessary in @@ -436,9 +439,9 @@ tidyTypeEnv omit_prags th exports type_env -------------------------- trimThing :: Bool -> NameSet -> TyThing -> TyThing -- Trim off inessentials, for boot files and no -O -trimThing th exports (ATyCon tc) - | not th && not (mustExposeTyCon exports tc) - = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell] +trimThing no_trim_types exports (ATyCon tc) + | not (mustExposeTyCon no_trim_types exports tc) + = ATyCon (makeTyConAbstract tc) -- Note [When we can't trim types] trimThing _th _exports (AnId id) | not (isImplicitId id) @@ -448,30 +451,61 @@ trimThing _th _exports other_thing = other_thing -{- Note [Trimming and Template Haskell] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #2386) this +{- Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (Trac #2386) this module M(T, makeOne) where data T = Yay String makeOne = [| Yay "Yep" |] Notice that T is exported abstractly, but makeOne effectively exports it too! A module that splices in $(makeOne) will then look for a declartion of Yay, so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. -} - - -mustExposeTyCon :: NameSet -- Exports +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (Trac #5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + -} + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports -> TyCon -- The tycon -> Bool -- Can its rep be hidden? -- We are compiling without -O, and thus trying to write as little as -- possible into the interface file. But we must expose the details of -- any data types whose constructors or fields are exported -mustExposeTyCon exports tc - | not (isAlgTyCon tc) -- Synonyms +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) = True + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors = True -- won't lead to the need for further exposure -- (This includes data types with no constructors.) + | isFamilyTyCon tc -- Open type family = True diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 162ce22775..d0302a19a2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -502,7 +502,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } = return [] rn_dotdot (Just {}) Nothing _flds -- ".." on record update = do { addErr (badDotDot ctxt); return [] } - rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat + rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match = ASSERT( n == length flds ) do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM Opt_RecordWildCards @@ -526,11 +526,11 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } where rdr = mkRdrUnqual (nameOccName fld) - dot_dot_gres = [ gre + dot_dot_gres = [ head gres | fld <- con_fields , not (fld `elem` present_flds) - , let gres@(gre:_) = lookupGRE_Name rdr_env fld - , not (null gres) + , let gres = lookupGRE_Name rdr_env fld + , not (null gres) -- Check field is in scope , case ctxt of HsRecFieldCon {} -> arg_in_scope fld _other -> True ] diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 829c2ca40f..4af626d053 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -137,7 +137,7 @@ showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () endPass dflags pass binds rules - = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules + = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules ; lintPassResult dflags pass binds } where mb_flag = case coreDumpFlag pass of @@ -167,9 +167,9 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules -- This has the side effect of forcing the intermediate to be evaluated where - dump_doc = vcat [ text "Result size =" <+> int (coreBindsSize binds) - , extra_info - , blankLine + dump_doc = vcat [ nest 2 extra_info + , nest 2 (text "Result size =" <+> int (coreBindsSize binds)) + , blankLine , pprCoreBindings binds , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine @@ -307,7 +307,8 @@ instance Outputable CoreToDo where ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n +pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n + , ppr md ] pprPassDetails _ = empty \end{code} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index ee20a52034..b8c8160972 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1416,7 +1416,7 @@ completeCall env var cont pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 14235f4651..321deb866a 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -1137,7 +1137,7 @@ specCalls subst rules_for_me calls_for_me fn rhs ; let -- The rule to put in the function's specialisation is: -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b - rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) + rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args)) spec_env_rule = mkRule True {- Auto generated -} is_local rule_name inl_act -- Note [Auto-specialisation and RULES] diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 54642e575f..91ce4887a4 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -30,7 +30,7 @@ module TcHsType ( tcHsContext, tcInferApps, tcHsArgTys, ExpKind(..), ekConstraint, expArgKind, checkExpectedKind, - kindGeneralizeKind, kindGeneralizeKinds, + kindGeneralize, -- Sort-checking kinds tcLHsKind, @@ -823,53 +823,26 @@ tcHsTyVarBndr (L _ hs_tv) ------------------ tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] - -> TcM r - -> TcM ([TyVar], r) + -> TcM (TcTyVarSet, r) -- Result + free tyvars of thing inside + -> TcM ([TyVar], r) -- Generalised kind variables + -- + zonked tyvars + result result -- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside -- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)] tcHsTyVarBndrsGen hs_tvs thing_inside = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) - ; (tvs, res) <- tcHsTyVarBndrs hs_tvs $ \ tvs -> + ; (tvs, (ftvs, res)) <- tcHsTyVarBndrs hs_tvs $ \ tvs -> do { res <- thing_inside ; return (tvs, res) } ; let kinds = map tyVarKind tvs - ; (kvs', zonked_kinds) <- kindGeneralizeKinds kinds + ; kvs' <- kindGeneralize (tyVarsOfTypes kinds `unionVarSet` + (ftvs `delVarSetList` tvs)) + ; zonked_kinds <- mapM zonkTcKind kinds ; let tvs' = zipWith setTyVarKind tvs zonked_kinds -- See Note [Kinds of quantified type variables] ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs)) ; return (kvs' ++ tvs', res) } ------------------- --- Used when generalizing binders and type family patterns --- It takes a kind from the type checker (like `k0 -> *`), and returns the --- final, kind-generalized kind (`forall k::BOX. k -> *`) -kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind]) --- INVARIANT: the returned kinds are zonked, and --- mention the returned kind variables -kindGeneralizeKinds kinds - = do { -- Quantify over kind variables free in - -- the kinds, and *not* in the environment - ; traceTc "kindGeneralizeKinds 1" (ppr kinds) - - ; kvs <- kindGeneralize (tyVarsOfTypes kinds) - - -- Zonk the kinds again, to pick up either the kind - -- variables we quantify over, or *, depending on whether - -- zonkQuantifiedTyVars decided to generalise (which in - -- turn depends on PolyKinds) - ; final_kinds <- mapM zonkTcKind kinds - - ; traceTc "kindGeneralizeKinds 2" (vcat [ ppr kinds, ppr kvs, ppr final_kinds ]) - ; return (kvs, final_kinds) } - - -kindGeneralizeKind :: TcKind -> TcM ([KindVar], Kind) --- Unary version of kindGeneralizeKinds -kindGeneralizeKind kind - = do { kvs <- kindGeneralize (tyVarsOfType kind) - ; kind' <- zonkTcKind kind - ; return (kvs, kind') } - +------------------- kindGeneralize :: TyVarSet -> TcM [KindVar] kindGeneralize tkvs = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 7ad12efc67..46a6abd540 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -251,12 +251,14 @@ newNoSigLetBndr (LetGblBndr prags) name ty ---------- addInlinePrags :: TcId -> [LSig Name] -> TcM TcId addInlinePrags poly_id prags - = tc_inl inl_sigs + = do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags) + ; tc_inl inl_sigs } where inl_sigs = filter isInlineLSig prags tc_inl [] = return poly_id tc_inl (L loc (InlineSig _ prag) : other_inls) = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) ; return (poly_id `setInlinePragma` prag) } tc_inl _ = panic "tc_inl" diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index b04f4156aa..c166e6210e 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -294,7 +294,8 @@ kcTyClGroup decls ; let kc_kind = case thing of AThing k -> k _ -> pprPanic "kcTyClGroup" (ppr thing) - ; (kvs, kc_kind') <- kindGeneralizeKind kc_kind + ; kvs <- kindGeneralize (tyVarsOfType kc_kind) + ; kc_kind' <- zonkTcKind kc_kind ; return (name, mkForAllTys kvs kc_kind') } getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] @@ -433,6 +434,8 @@ kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d) kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () kcResultKind Nothing res_k = discardResult (unifyKind res_k liftedTypeKind) + -- type family F a + -- defaults to type family F a :: * kcResultKind (Just k) res_k = do { k' <- tcLHsKind k ; discardResult (unifyKind k' res_k) } @@ -749,24 +752,18 @@ tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside = splitKindFunTysN fam_arity $ substKiWith fam_kvs fam_arg_kinds fam_body - -- Kind-check - ; (tvs, typats) <- tcHsTyVarBndrs tyvars $ \tvs -> do + -- Kind-check and quantify + -- See Note [Quantifying over family patterns] + ; (tkvs, typats) <- tcHsTyVarBndrsGen tyvars $ do { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds ; kind_checker res_kind - ; return (tvs, typats) } + ; return (tyVarsOfTypes typats, typats) } - -- Quantify - -- See Note [Quantifying over family patterns] - ; let tv_kinds = map tyVarKind tvs - ; (kvs, kinds') <- kindGeneralizeKinds (tv_kinds ++ fam_arg_kinds) - ; typats' <- zonkTcTypeToTypes emptyZonkEnv typats + ; all_args' <- zonkTcTypeToTypes emptyZonkEnv (fam_arg_kinds ++ typats) ; res_kind' <- zonkTcTypeToType emptyZonkEnv res_kind - ; let (tv_kinds', fam_arg_kinds') = splitAtList tv_kinds kinds' - tvs' = zipWith setTyVarKind tvs tv_kinds' - tkvs = kvs ++ tvs' -- Kind and type variables - ; traceTc "tcFamPats" (ppr tvs' $$ ppr kvs $$ ppr kinds') + ; traceTc "tcFamPats" (ppr tkvs $$ ppr all_args' $$ ppr res_kind') ; tcExtendTyVarEnv tkvs $ - thing_inside tkvs (fam_arg_kinds' ++ typats') res_kind' } + thing_inside tkvs all_args' res_kind' } \end{code} Note [Quantifying over family patterns] @@ -876,21 +873,25 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types , con_details = details, con_res = res_ty }) = addErrCtxt (dataConCtxt name) $ do { traceTc "tcConDecl 1" (ppr name) - ; (tvs', stuff) <- tcHsTyVarBndrsGen tvs $ + ; (tvs', (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) + <- tcHsTyVarBndrsGen tvs $ do { ctxt' <- tcHsContext ctxt ; details' <- tcConArgs new_or_data details ; res_ty' <- tcConRes res_ty - ; return (ctxt', details', res_ty') } + ; let (is_infix, field_lbls, btys') = details' + (arg_tys', stricts) = unzip btys' + ftvs = tyVarsOfTypes ctxt' `unionVarSet` + tyVarsOfTypes arg_tys' `unionVarSet` + case res_ty' of + ResTyH98 -> emptyVarSet + ResTyGADT ty -> tyVarsOfType ty + ; return (ftvs, (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) } - ; let (ctxt', details', res_ty') = stuff - (is_infix, field_lbls, btys') = details' - (arg_tys', stricts) = unzip btys' -- Substitute, to account for the kind -- unifications done by tcHsTyVarBndrsGen - ze = mkTyVarZonkEnv tvs' - ; traceTc "tcConDecl 2" (ppr name) + ; let ze = mkTyVarZonkEnv tvs' ; arg_tys' <- zonkTcTypeToTypes ze arg_tys' ; ctxt' <- zonkTcTypeToTypes ze ctxt' ; res_ty' <- case res_ty' of diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index b71389663e..b96ae5e063 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -388,29 +388,29 @@ renderWithStyle sdoc sty = -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. showSDocOneLine :: SDoc -> String -showSDocOneLine d = - Pretty.showDocWith PageMode +showSDocOneLine d + = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultUserStyle)) showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = - show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) +showSDocForUser unqual doc + = show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) showSDocUnqual :: SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = - show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) +showSDocUnqual d + = show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) showsPrecSDoc :: Int -> SDoc -> ShowS showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) showSDocDump :: SDoc -> String -showSDocDump d = - Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) +showSDocDump d + = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle)) showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = - Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) +showSDocDumpOneLine d + = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) showSDocDebug :: SDoc -> String showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) @@ -923,27 +923,27 @@ plural _ = char 's' pprPanic :: String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" -pprPanic = pprAndThen panic +pprPanic = pprDebugAndThen panic pprSorry :: String -> SDoc -> a -- ^ Throw an exception saying "this isn't finished yet" -pprSorry = pprAndThen sorry +pprSorry = pprDebugAndThen sorry pprPgmError :: String -> SDoc -> a -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pprAndThen pgmError +pprPgmError = pprDebugAndThen pgmError pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | opt_NoDebugOutput = x - | otherwise = pprAndThen trace str doc x + | otherwise = pprDebugAndThen trace str doc x pprDefiniteTrace :: String -> SDoc -> a -> a -- ^ Same as pprTrace, but show even if -dno-debug-output is on -pprDefiniteTrace str doc x = pprAndThen trace str doc x +pprDefiniteTrace str doc x = pprDebugAndThen trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' @@ -952,33 +952,31 @@ pprPanicFastInt heading pretty_msg = where doc = text heading <+> pretty_msg - -pprAndThen :: (String -> a) -> String -> SDoc -> a -pprAndThen cont heading pretty_msg = - cont (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [text heading, nest 4 pretty_msg] - -assertPprPanic :: String -> Int -> SDoc -> a --- ^ Panic with an assertation failure, recording the given file and line number. --- Should typically be accessed with the ASSERT family of macros -assertPprPanic file line msg - = panic (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [hsep[text "ASSERT failed! file", - text file, - text "line", int line], - msg] - warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x + = pprDebugAndThen trace "WARNING:" doc x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg] + +assertPprPanic :: String -> Int -> SDoc -> a +-- ^ Panic with an assertation failure, recording the given file and line number. +-- Should typically be accessed with the ASSERT family of macros +assertPprPanic file line msg + = pprDebugAndThen panic "ASSERT failed!" doc + where + doc = sep [ hsep [ text "file", text file + , text "line", int line ] + , msg ] + +pprDebugAndThen :: (String -> a) -> String -> SDoc -> a +pprDebugAndThen cont heading pretty_msg + = cont (show (runSDoc doc (initSDocContext PprDebug))) + where + doc = sep [text heading, nest 4 pretty_msg] \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 66f51e64e6..47dd7798cd 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -58,6 +58,7 @@ data OS | OSOpenBSD | OSNetBSD | OSKFreeBSD + | OSHaiku deriving (Read, Show, Eq) -- | ARM Instruction Set Architecture and Extensions @@ -91,6 +92,7 @@ osElfTarget OSSolaris2 = True osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False osElfTarget OSKFreeBSD = True +osElfTarget OSHaiku = True osElfTarget OSUnknown = False -- Defaulting to False is safe; it means don't rely on any -- ELF-specific functionality. It is important to have a default for |