New submission from Simon Marlow <[EMAIL PROTECTED]>: We can supply failing repositories on request.
sh-2.04$ darcs --exact-version darcs compiled on May 30 2005, at 11:54:13 # configured Mon May 30 11:48:37 USMST 2005 sh ./configure --disable-mmap --target=mingw Context: [update web page to reflect new stable release (1.0.3) Tomasz Zielonka <[EMAIL PROTECTED]>**20050524225643] [TAG 1.0.3 Tomasz Zielonka <[EMAIL PROTECTED]>**20050524215127] sh-2.04$ darcs pull http://darcs.haskell.org/ghc This is the GHC darcs repostory (HEAD branch) For more information, visit the GHC developer wiki at http://hackage.haskell.org/trac/ghc ********************** Wed May 17 16:42:04 GMT Daylight Time 2006 [EMAIL PROTECTED] * Improve pretty-printing slightly Shall I pull this patch? (1/94) [ynWvpxqadjk], or ? for help: y Wed May 17 16:43:04 GMT Daylight Time 2006 [EMAIL PROTECTED] * Comments only Shall I pull this patch? (2/94) [ynWvpxqadjk], or ? for help: y Wed May 17 16:43:49 GMT Daylight Time 2006 [EMAIL PROTECTED] * Improve pretty-printing Shall I pull this patch? (3/94) [ynWvpxqadjk], or ? for help: y Wed May 17 16:44:49 GMT Daylight Time 2006 [EMAIL PROTECTED] * Retain INLINE pragma information during indirection-shorting During indirection-shorting, we were dropping the InlinePragInfo, although were were carefully retaining strictness info etc. I think this is a long-standing bug. Shall I pull this patch? (4/94) [ynWvpxqadjk], or ? for help: y Wed May 17 16:47:10 GMT Daylight Time 2006 [EMAIL PROTECTED] * Spelling correction Shall I pull this patch? (5/94) [ynWvpxqadjk], or ? for help: a darcs.exe: bug in darcs! in function new_ur Original patch: merger 0.9 ( merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 633 --- gaw 2004 merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 589 - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff - || has_worker = Nothing -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) + inline_hsinfo | isAlwaysActive inline_prag = Nothing + | no_unfolding && not has_worker = Nothing + -- If the iface file give no unfolding info, we + -- don't need to say when inlining is OK! + | otherwise = Just (HsInline inline_prag) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 577 - unfold_info = unfoldingInfo id_info + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + + ------------ Inline prag -------------- merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 548 - wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 580 - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing + unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff + || has_worker = Nothing -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal hunk ./compiler/iface/IfaceSyn.lhs 417 -\end{code} - - -%************************************************************************ -%* * - Converting things to their Iface equivalents -%* * -%************************************************************************ - - -\begin{code} -tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl --- Assumption: the thing is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- Reason: Iface stuff uses OccNames, and the conversion here does --- not do tidying on the way -tyThingToIfaceDecl ext (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType ext (idType id), - ifIdInfo = info } - where - info = case toIfaceIdInfo ext (idInfo id) of - [] -> NoInfo - items -> HasInfo items - -tyThingToIfaceDecl ext (AClass clas) - = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, - ifName = getOccName clas, - ifTyVars = toIfaceTvBndrs clas_tyvars, - ifFDs = map toIfaceFD clas_fds, - ifSigs = map toIfaceClassOp op_stuff, - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifVrcs = tyConArgVrcs tycon } - where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - tycon = classTyCon clas - - toIfaceClassOp (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) - op_ty = funResultTy rho_ty - - toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) - -tyThingToIfaceDecl ext (ATyCon tycon) - | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifVrcs = tyConArgVrcs tycon, - ifSynRhs = toIfaceType ext syn_ty } - - | isAlgTyCon tycon - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifVrcs = tyConArgVrcs tycon, - ifGeneric = tyConHasGenerics tycon } - - | isForeignTyCon tycon - = IfaceForeign { ifName = getOccName tycon, - ifExtName = tyConExtName tycon } - - | isPrimTyCon tycon || isFunTyCon tycon - -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCtxt = [], - ifCons = IfAbstractTyCon, - ifGadtSyntax = False, - ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } - - | otherwise = pprPanic "toIfaceDecl" (ppr tycon) - where - tyvars = tyConTyVars tycon - syn_ty = synTyConRhs tycon - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The last case happens when a TyCon has been trimmed during tidying - -- Furthermore, tyThingToIfaceDecl is also used - -- in TcRnDriver for GHCi, when browsing a module, in which case the - -- AbstractTyCon case is perfectly sensible. - - ifaceConDecl data_con - = IfCon { ifConOcc = getOccName (dataConName data_con), - ifConInfix = dataConIsInfix data_con, - ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), - ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), - ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con), - ifConFields = map getOccName (dataConFieldLabels data_con), - ifConStricts = dataConStrictMarks data_con } - - to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] - -tyThingToIfaceDecl ext (ADataCon dc) - = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier - - --------------------------- -instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst -instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls, is_tcs = mb_tcs, - is_orph = orph }) - = IfaceInst { ifDFun = getOccName dfun_id, - ifOFlag = oflag, - ifInstCls = ext_lhs cls, - ifInstTys = map do_rough mb_tcs, - ifInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) - --------------------------- -toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] -toIfaceIdInfo ext id_info - = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - wrkr_hsinfo, unfold_hsinfo] - where - ------------ Arity -------------- - arity_info = arityInfo id_info - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_info = cafInfo id_info - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of - Just sig | not (isTopSig sig) -> Just (HsStrictness sig) - _other -> Nothing - - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (ext (idName work_id)) wrap_arity) - NoWorker -> Nothing - - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) - --------------------------- -coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names - -> (Name -> IfaceExtName) -- For the RHS names - -> CoreRule -> IfaceRule -coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) - = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule (mkIfaceExtName fn) - -coreRuleToIfaceRule ext_lhs ext_rhs - (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, ru_orph = orph }) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, - ifRuleHead = ext_lhs fn, - ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr ext_rhs rhs, - ifRuleOrph = orph } - where - -- For type args we must remove synonyms from the outermost - -- level. Reason: so that when we read it back in we'll - -- construct the same ru_rough field as we have right now; - -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) - do_arg arg = toIfaceExpr ext_lhs arg - -bogusIfaceRule :: IfaceExtName -> IfaceRule -bogusIfaceRule id_name - = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, - ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } - ---------------------- -toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr -toIfaceExpr ext (Var v) = toIfaceVar ext v -toIfaceExpr ext (Lit l) = IfaceLit l -toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) -toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) -toIfaceExpr ext (App f a) = toIfaceApp ext f [a] --- gaw 2004 -toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) -toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) -toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co) -toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) - ---------------------- -toIfaceNote ext (SCC cc) = IfaceSCC cc -toIfaceNote ext InlineCall = IfaceInlineCall -toIfaceNote ext InlineMe = IfaceInlineMe -toIfaceNote ext (CoreNote s) = IfaceCoreNote s - ---------------------- -toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) -toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] - ---------------------- -toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r) - ---------------------- -toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) - | otherwise = IfaceDataAlt (getOccName dc) - where - tc = dataConTyCon dc - -toIfaceCon (LitAlt l) = IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault - ---------------------- -toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) -toIfaceApp ext (Var v) as - = case isDataConWorkId_maybe v of - -- We convert the *worker* for tuples into IfaceTuples - Just dc | isTupleTyCon tc && saturated - -> IfaceTuple (tupleTyConBoxity tc) tup_args - where - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` idArity v - tup_args = map (toIfaceExpr ext) val_args - tc = dataConTyCon dc - - other -> mkIfaceApps ext (toIfaceVar ext v) as - -toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as - -mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as - ---------------------- -toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr -toIfaceVar ext v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) - -- Foreign calls have special syntax - | isExternalName name = IfaceExt (ext name) - | otherwise = IfaceLcl (nameOccName name) - where - name = idName v ) ) ) ) ) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 640 ---toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 640 -toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) +--toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) hunk ./compiler/iface/IfaceSyn.lhs 641 -toIfaceNote ext InlineCall = IfaceInlineCall ) ) ) Unwound: merger 0.9 ( merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 633 --- gaw 2004 merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 589 - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff - || has_worker = Nothing -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) + inline_hsinfo | isAlwaysActive inline_prag = Nothing + | no_unfolding && not has_worker = Nothing + -- If the iface file give no unfolding info, we + -- don't need to say when inlining is OK! + | otherwise = Just (HsInline inline_prag) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 577 - unfold_info = unfoldingInfo id_info + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + + ------------ Inline prag -------------- merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 548 - wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 580 - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing + unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff + || has_worker = Nothing -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal hunk ./compiler/iface/IfaceSyn.lhs 417 -\end{code} - - -%************************************************************************ -%* * - Converting things to their Iface equivalents -%* * -%************************************************************************ - - -\begin{code} -tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl --- Assumption: the thing is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- Reason: Iface stuff uses OccNames, and the conversion here does --- not do tidying on the way -tyThingToIfaceDecl ext (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType ext (idType id), - ifIdInfo = info } - where - info = case toIfaceIdInfo ext (idInfo id) of - [] -> NoInfo - items -> HasInfo items - -tyThingToIfaceDecl ext (AClass clas) - = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, - ifName = getOccName clas, - ifTyVars = toIfaceTvBndrs clas_tyvars, - ifFDs = map toIfaceFD clas_fds, - ifSigs = map toIfaceClassOp op_stuff, - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifVrcs = tyConArgVrcs tycon } - where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - tycon = classTyCon clas - - toIfaceClassOp (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) - op_ty = funResultTy rho_ty - - toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) - -tyThingToIfaceDecl ext (ATyCon tycon) - | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifVrcs = tyConArgVrcs tycon, - ifSynRhs = toIfaceType ext syn_ty } - - | isAlgTyCon tycon - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifVrcs = tyConArgVrcs tycon, - ifGeneric = tyConHasGenerics tycon } - - | isForeignTyCon tycon - = IfaceForeign { ifName = getOccName tycon, - ifExtName = tyConExtName tycon } - - | isPrimTyCon tycon || isFunTyCon tycon - -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCtxt = [], - ifCons = IfAbstractTyCon, - ifGadtSyntax = False, - ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } - - | otherwise = pprPanic "toIfaceDecl" (ppr tycon) - where - tyvars = tyConTyVars tycon - syn_ty = synTyConRhs tycon - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The last case happens when a TyCon has been trimmed during tidying - -- Furthermore, tyThingToIfaceDecl is also used - -- in TcRnDriver for GHCi, when browsing a module, in which case the - -- AbstractTyCon case is perfectly sensible. - - ifaceConDecl data_con - = IfCon { ifConOcc = getOccName (dataConName data_con), - ifConInfix = dataConIsInfix data_con, - ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), - ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), - ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con), - ifConFields = map getOccName (dataConFieldLabels data_con), - ifConStricts = dataConStrictMarks data_con } - - to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] - -tyThingToIfaceDecl ext (ADataCon dc) - = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier - - --------------------------- -instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst -instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls, is_tcs = mb_tcs, - is_orph = orph }) - = IfaceInst { ifDFun = getOccName dfun_id, - ifOFlag = oflag, - ifInstCls = ext_lhs cls, - ifInstTys = map do_rough mb_tcs, - ifInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) - --------------------------- -toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] -toIfaceIdInfo ext id_info - = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - wrkr_hsinfo, unfold_hsinfo] - where - ------------ Arity -------------- - arity_info = arityInfo id_info - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_info = cafInfo id_info - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of - Just sig | not (isTopSig sig) -> Just (HsStrictness sig) - _other -> Nothing - - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (ext (idName work_id)) wrap_arity) - NoWorker -> Nothing - - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) - --------------------------- -coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names - -> (Name -> IfaceExtName) -- For the RHS names - -> CoreRule -> IfaceRule -coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) - = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule (mkIfaceExtName fn) - -coreRuleToIfaceRule ext_lhs ext_rhs - (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, ru_orph = orph }) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, - ifRuleHead = ext_lhs fn, - ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr ext_rhs rhs, - ifRuleOrph = orph } - where - -- For type args we must remove synonyms from the outermost - -- level. Reason: so that when we read it back in we'll - -- construct the same ru_rough field as we have right now; - -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) - do_arg arg = toIfaceExpr ext_lhs arg - -bogusIfaceRule :: IfaceExtName -> IfaceRule -bogusIfaceRule id_name - = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, - ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } - ---------------------- -toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr -toIfaceExpr ext (Var v) = toIfaceVar ext v -toIfaceExpr ext (Lit l) = IfaceLit l -toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) -toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) -toIfaceExpr ext (App f a) = toIfaceApp ext f [a] --- gaw 2004 -toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) -toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) -toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co) -toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) - ---------------------- -toIfaceNote ext (SCC cc) = IfaceSCC cc -toIfaceNote ext InlineCall = IfaceInlineCall -toIfaceNote ext InlineMe = IfaceInlineMe -toIfaceNote ext (CoreNote s) = IfaceCoreNote s - ---------------------- -toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) -toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] - ---------------------- -toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r) - ---------------------- -toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) - | otherwise = IfaceDataAlt (getOccName dc) - where - tc = dataConTyCon dc - -toIfaceCon (LitAlt l) = IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault - ---------------------- -toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) -toIfaceApp ext (Var v) as - = case isDataConWorkId_maybe v of - -- We convert the *worker* for tuples into IfaceTuples - Just dc | isTupleTyCon tc && saturated - -> IfaceTuple (tupleTyConBoxity tc) tup_args - where - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` idArity v - tup_args = map (toIfaceExpr ext) val_args - tc = dataConTyCon dc - - other -> mkIfaceApps ext (toIfaceVar ext v) as - -toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as - -mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as - ---------------------- -toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr -toIfaceVar ext v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) - -- Foreign calls have special syntax - | isExternalName name = IfaceExt (ext name) - | otherwise = IfaceLcl (nameOccName name) - where - name = idName v ) ) ) ) ) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 640 ---toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 640 -toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) +--toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) hunk ./compiler/iface/IfaceSyn.lhs 641 -toIfaceNote ext InlineCall = IfaceInlineCall ) ) ) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 633 --- gaw 2004 merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 589 - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff - || has_worker = Nothing -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) + inline_hsinfo | isAlwaysActive inline_prag = Nothing + | no_unfolding && not has_worker = Nothing + -- If the iface file give no unfolding info, we + -- don't need to say when inlining is OK! + | otherwise = Just (HsInline inline_prag) merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 577 - unfold_info = unfoldingInfo id_info + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + + ------------ Inline prag -------------- merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 548 - wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] merger 0.0 ( hunk ./compiler/iface/IfaceSyn.lhs 580 - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing + unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff + || has_worker = Nothing -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal hunk ./compiler/iface/IfaceSyn.lhs 417 -\end{code} - - -%************************************************************************ -%* * - Converting things to their Iface equivalents -%* * -%************************************************************************ - - -\begin{code} -tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl --- Assumption: the thing is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- Reason: Iface stuff uses OccNames, and the conversion here does --- not do tidying on the way -tyThingToIfaceDecl ext (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType ext (idType id), - ifIdInfo = info } - where - info = case toIfaceIdInfo ext (idInfo id) of - [] -> NoInfo - items -> HasInfo items - -tyThingToIfaceDecl ext (AClass clas) - = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, - ifName = getOccName clas, - ifTyVars = toIfaceTvBndrs clas_tyvars, - ifFDs = map toIfaceFD clas_fds, - ifSigs = map toIfaceClassOp op_stuff, - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifVrcs = tyConArgVrcs tycon } - where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - tycon = classTyCon clas - - toIfaceClassOp (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) - op_ty = funResultTy rho_ty - - toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) - -tyThingToIfaceDecl ext (ATyCon tycon) - | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifVrcs = tyConArgVrcs tycon, - ifSynRhs = toIfaceType ext syn_ty } - - | isAlgTyCon tycon - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifVrcs = tyConArgVrcs tycon, - ifGeneric = tyConHasGenerics tycon } - - | isForeignTyCon tycon - = IfaceForeign { ifName = getOccName tycon, - ifExtName = tyConExtName tycon } - - | isPrimTyCon tycon || isFunTyCon tycon - -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCtxt = [], - ifCons = IfAbstractTyCon, - ifGadtSyntax = False, - ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } - - | otherwise = pprPanic "toIfaceDecl" (ppr tycon) - where - tyvars = tyConTyVars tycon - syn_ty = synTyConRhs tycon - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The last case happens when a TyCon has been trimmed during tidying - -- Furthermore, tyThingToIfaceDecl is also used - -- in TcRnDriver for GHCi, when browsing a module, in which case the - -- AbstractTyCon case is perfectly sensible. - - ifaceConDecl data_con - = IfCon { ifConOcc = getOccName (dataConName data_con), - ifConInfix = dataConIsInfix data_con, - ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), - ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), - ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) (dataConOrigArgTys data_con), - ifConFields = map getOccName (dataConFieldLabels data_con), - ifConStricts = dataConStrictMarks data_con } - - to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] - -tyThingToIfaceDecl ext (ADataCon dc) - = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier - - --------------------------- -instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst -instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls, is_tcs = mb_tcs, - is_orph = orph }) - = IfaceInst { ifDFun = getOccName dfun_id, - ifOFlag = oflag, - ifInstCls = ext_lhs cls, - ifInstTys = map do_rough mb_tcs, - ifInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) - --------------------------- -toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] -toIfaceIdInfo ext id_info - = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - wrkr_hsinfo, unfold_hsinfo] - where - ------------ Arity -------------- - arity_info = arityInfo id_info - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_info = cafInfo id_info - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of - Just sig | not (isTopSig sig) -> Just (HsStrictness sig) - _other -> Nothing - - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (ext (idName work_id)) wrap_arity) - NoWorker -> Nothing - - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) - --------------------------- -coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names - -> (Name -> IfaceExtName) -- For the RHS names - -> CoreRule -> IfaceRule -coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) - = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule (mkIfaceExtName fn) - -coreRuleToIfaceRule ext_lhs ext_rhs - (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, ru_orph = orph }) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, - ifRuleHead = ext_lhs fn, - ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr ext_rhs rhs, - ifRuleOrph = orph } - where - -- For type args we must remove synonyms from the outermost - -- level. Reason: so that when we read it back in we'll - -- construct the same ru_rough field as we have right now; - -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) - do_arg arg = toIfaceExpr ext_lhs arg - -bogusIfaceRule :: IfaceExtName -> IfaceRule -bogusIfaceRule id_name - = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, - ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], - ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } - ---------------------- -toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr -toIfaceExpr ext (Var v) = toIfaceVar ext v -toIfaceExpr ext (Lit l) = IfaceLit l -toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) -toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) -toIfaceExpr ext (App f a) = toIfaceApp ext f [a] --- gaw 2004 -toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) -toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) -toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co) -toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) - ---------------------- -toIfaceNote ext (SCC cc) = IfaceSCC cc -toIfaceNote ext InlineCall = IfaceInlineCall -toIfaceNote ext InlineMe = IfaceInlineMe -toIfaceNote ext (CoreNote s) = IfaceCoreNote s - ---------------------- -toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) -toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] - ---------------------- -toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r) - ---------------------- -toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) - | otherwise = IfaceDataAlt (getOccName dc) - where - tc = dataConTyCon dc - -toIfaceCon (LitAlt l) = IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault - ---------------------- -toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) -toIfaceApp ext (Var v) as - = case isDataConWorkId_maybe v of - -- We convert the *worker* for tuples into IfaceTuples - Just dc | isTupleTyCon tc && saturated - -> IfaceTuple (tupleTyConBoxity tc) tup_args - where - val_args = dropWhile isTypeArg as - saturated = val_args `lengthIs` idArity v - tup_args = map (toIfaceExpr ext) val_args - tc = dataConTyCon dc - - other -> mkIfaceApps ext (toIfaceVar ext v) as - -toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as - -mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as - ---------------------- -toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr -toIfaceVar ext v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) - -- Foreign calls have special syntax - | isExternalName name = IfaceExt (ext name) - | otherwise = IfaceLcl (nameOccName name) - where - name = idName v ) ) ) ) ) hunk ./compiler/iface/IfaceSyn.lhs 633 --- gaw 2004 hunk ./compiler/iface/IfaceSyn.lhs 589 - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff - || has_worker = Nothing -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) + inline_hsinfo | isAlwaysActive inline_prag = Nothing + | no_unfolding && not has_worker = Nothing + -- If the iface file give no unfolding info, we + -- don't need to say when inlining is OK! + | otherwise = Just (HsInline inline_prag) hunk ./compiler/iface/IfaceSyn.lhs 577 - unfold_info = unfoldingInfo id_info + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + + ------------ Inline prag -------------- hunk ./compiler/iface/IfaceSyn.lhs 548 - wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] hunk ./compiler/iface/IfaceSyn.lhs 580 - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing + unfold_hsinfo | neverUnfold unfold_info -- The CoreTidy phase retains unfolding info iff + || has_worker = Nothing -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal hunk ./compiler/iface/IfaceSyn.lhs 650 ---toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) hunk ./compiler/iface/IfaceSyn.lhs 630 -toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) +--toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1) Please report this to [EMAIL PROTECTED] If possible include the output of 'darcs --exact-version'. sh-2.04$ ---------- messages: 714 nosy: droundy, simonmar, tommy priority: urgent status: unread title: crash in function new_ur ____________________________________ Darcs issue tracker <[EMAIL PROTECTED]> <http://bugs.darcs.net/issue190> ____________________________________ _______________________________________________ darcs-devel mailing list [email protected] http://www.abridgegame.org/cgi-bin/mailman/listinfo/darcs-devel
