Commit a6c7e7dc authored by simonm's avatar simonm
Browse files

[project @ 1997-09-24 09:08:21 by simonm]

Remove deforester
parent 7806e746
......@@ -44,10 +44,6 @@ DIRS = \
reader profiling parser
ifeq ($(GhcWithDeforester),YES)
DIRS += deforest
endif
ifeq ($(GhcWithNativeCodeGen),YES)
DIRS += nativeGen
else
......@@ -145,13 +141,6 @@ else
SRC_HC_OPTS += -recomp
endif
ifeq ($(GhcWithDeforester),NO)
ifeq "$(Ghc2_0)" "NO"
SRC_MKDEPENDHS_OPTS += -DOMIT_DEFORESTER
endif
SRC_HC_OPTS += -DOMIT_DEFORESTER
endif
SRC_HC_OPTS += $(GhcHcOpts)
# Special flags for particular modules
......
......@@ -98,7 +98,6 @@ module Id (
addIdDemandInfo,
addIdStrictness,
addIdUpdateInfo,
addIdDeforestInfo,
getIdArity,
getIdDemandInfo,
getIdInfo,
......@@ -845,18 +844,6 @@ addIdArity (Id u n ty details pinfo info) arity
= Id u n ty details pinfo (info `addArityInfo` arity)
\end{code}
%************************************************************************
%* *
\subsection[Id-arities]{Deforestation related functions}
%* *
%************************************************************************
\begin{code}
addIdDeforestInfo :: Id -> DeforestInfo -> Id
addIdDeforestInfo (Id u n ty details pinfo info) def_info
= Id u n ty details pinfo (info `addDeforestInfo` def_info)
\end{code}
%************************************************************************
%* *
\subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)}
......
......@@ -37,9 +37,6 @@ module IdInfo (
UpdateInfo, SYN_IE(UpdateSpec),
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
DeforestInfo(..),
deforestInfo, ppDeforestInfo, addDeforestInfo,
ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType),
mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
......@@ -109,9 +106,6 @@ data IdInfo
UpdateInfo -- Which args should be updated
DeforestInfo -- Whether its definition should be
-- unfolded during deforestation
ArgUsageInfo -- how this Id uses its arguments
FBTypeInfo -- the Foldr/Build W/W property of this function.
......@@ -119,7 +113,7 @@ data IdInfo
\begin{code}
noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding
NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo
NoUpdateInfo NoArgUsageInfo NoFBTypeInfo
\end{code}
Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@
......@@ -127,7 +121,7 @@ will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very
nasty loop, friends...)
\begin{code}
apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
update deforest arg_usage fb_ww)
update arg_usage fb_ww)
| isNullSpecEnv spec
= idinfo
| otherwise
......@@ -137,7 +131,7 @@ apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
Variant of the same thing for the typechecker.
\begin{code}
applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
update deforest arg_usage fb_ww)
update arg_usage fb_ww)
= panic "IdInfo:applySubstToIdInfo"
\end{code}
......@@ -148,12 +142,11 @@ ppIdInfo :: PprStyle
-> Doc
ppIdInfo sty specs_please
(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype)
(IdInfo arity demand specenv strictness unfold update arg_usage fbtype)
= hsep [
-- order is important!:
ppArityInfo sty arity,
ppUpdateInfo sty update,
ppDeforestInfo sty deforest,
ppStrictnessInfo sty strictness,
......@@ -186,9 +179,9 @@ exactArity = ArityExactly
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity
arityInfo (IdInfo arity _ _ _ _ _ _ _) = arity
addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i
addArityInfo (IdInfo _ a b c d e f g) arity = IdInfo arity a b c d e f g
ppArityInfo sty UnknownArity = empty
ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
......@@ -226,9 +219,9 @@ willBeDemanded _ = False
\end{code}
\begin{code}
demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand
demandInfo (IdInfo _ demand _ _ _ _ _ _) = demand
addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i
addDemandInfo (IdInfo a _ c d e f g h) demand = IdInfo a demand c d e f g h
ppDemandInfo PprInterface _ = empty
ppDemandInfo sty UnknownDemand = text "{-# L #-}"
......@@ -244,10 +237,10 @@ ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info]
See SpecEnv.lhs
\begin{code}
specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec
specInfo (IdInfo _ _ spec _ _ _ _ _) = spec
addSpecInfo id_info spec | isNullSpecEnv spec = id_info
addSpecInfo (IdInfo a b _ d e f g h i) spec = IdInfo a b spec d e f g h i
addSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h
\end{code}
%************************************************************************
......@@ -307,10 +300,10 @@ mkBottomStrictnessInfo = BottomGuaranteed
bottomIsGuaranteed BottomGuaranteed = True
bottomIsGuaranteed other = False
strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict
strictnessInfo (IdInfo _ _ _ strict _ _ _ _) = strict
addStrictnessInfo id_info NoStrictnessInfo = id_info
addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i
addStrictnessInfo (IdInfo a b d _ e f g h) strict = IdInfo a b d strict e f g h
ppStrictnessInfo sty NoStrictnessInfo = empty
ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_")
......@@ -334,9 +327,9 @@ workerExists other = False
%************************************************************************
\begin{code}
unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding
unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _) = unfolding
addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i
addUnfoldInfo (IdInfo a b d e _ f g h) uf = IdInfo a b d e uf f g h
\end{code}
%************************************************************************
......@@ -378,43 +371,16 @@ instance Text UpdateInfo where
ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
| otherwise = panic "IdInfo: not a digit while reading update pragma"
updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update
updateInfo (IdInfo _ _ _ _ _ update _ _) = update
addUpdateInfo id_info NoUpdateInfo = id_info
addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i
addUpdateInfo (IdInfo a b d e f _ g h) upd_info = IdInfo a b d e f upd_info g h
ppUpdateInfo sty NoUpdateInfo = empty
ppUpdateInfo sty (SomeUpdateInfo []) = empty
ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
\end{code}
%************************************************************************
%* *
\subsection[deforest-IdInfo]{Deforestation info about an @Id@}
%* *
%************************************************************************
The deforest info says whether this Id is to be unfolded during
deforestation. Therefore, when the deforest pragma is true, we must
also have the unfolding information available for this Id.
\begin{code}
data DeforestInfo
= Don'tDeforest -- just a bool, might extend this
| DoDeforest -- later.
-- deriving (Eq, Ord)
\end{code}
\begin{code}
deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest
addDeforestInfo id_info Don'tDeforest = id_info
addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i
ppDeforestInfo sty Don'tDeforest = empty
ppDeforestInfo sty DoDeforest = ptext SLIT("_DEFOREST_")
\end{code}
%************************************************************************
%* *
\subsection[argUsage-IdInfo]{Argument Usage info about an @Id@}
......@@ -442,10 +408,10 @@ getArgUsage (SomeArgUsageInfo u) = u
\end{code}
\begin{code}
argUsageInfo (IdInfo _ _ _ _ _ _ _ au _) = au
argUsageInfo (IdInfo _ _ _ _ _ _ au _) = au
addArgUsageInfo id_info NoArgUsageInfo = id_info
addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i
addArgUsageInfo (IdInfo a b d e f g _ h) au_info = IdInfo a b d e f g au_info h
ppArgUsageInfo sty NoArgUsageInfo = empty
ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
......@@ -485,10 +451,10 @@ getFBType (SomeFBTypeInfo u) = Just u
\end{code}
\begin{code}
fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb
fbTypeInfo (IdInfo _ _ _ _ _ _ _ fb) = fb
addFBTypeInfo id_info NoFBTypeInfo = id_info
addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info
addFBTypeInfo (IdInfo a b d e f g h _) fb_info = IdInfo a b d e f g h fb_info
ppFBTypeInfo sty NoFBTypeInfo = empty
ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod))
......
......@@ -246,9 +246,6 @@ data Sig name
| InlineSig name -- INLINE f
SrcLoc
| DeforestSig name -- Deforest using this function definition
SrcLoc
| MagicUnfoldingSig
name -- Associate the "name"d function with
FAST_STRING -- the compiler-builtin unfolding (known
......@@ -268,9 +265,6 @@ ppr_sig sty (ClassOpSig var _ ty _)
= sep [ppr sty (getOccName var) <+> ptext SLIT("::"),
nest 4 (ppr sty ty)]
ppr_sig sty (DeforestSig var _)
= hsep [text "{-# DEFOREST", ppr sty var, text "#-}"]
ppr_sig sty (SpecSig var ty using _)
= sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")],
nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
......
......@@ -381,7 +381,6 @@ data HsIdInfo name
| HsStrictness (HsStrictnessInfo name)
| HsUnfold Bool (UfExpr name) -- True <=> INLINE pragma
| HsUpdate UpdateInfo
| HsDeforest DeforestInfo
| HsArgUsage ArgUsageInfo
| HsFBType FBTypeInfo
-- ToDo: specialisations
......
......@@ -91,7 +91,6 @@ data GenPragmas name
= NoGenPragmas
| GenPragmas (Maybe Int) -- arity (maybe)
(Maybe UpdateInfo) -- update info (maybe)
DeforestInfo -- deforest info
(ImpStrictness name) -- strictness, worker-wrapper
(ImpUnfolding name) -- unfolding (maybe)
[([Maybe (HsType name)], -- Specialisations: types to which spec'd;
......
......@@ -25,7 +25,6 @@ module CmdLineOpts (
opt_CompilingGhcInternals,
opt_D_dump_absC,
opt_D_dump_asm,
opt_D_dump_deforest,
opt_D_dump_deriv,
opt_D_dump_ds,
opt_D_dump_flatC,
......@@ -170,7 +169,6 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreDoStaticArgs
| CoreDoStrictness
| CoreDoSpecialising
| CoreDoDeforest
| CoreDoFoldrBuildWorkerWrapper
| CoreDoFoldrBuildWWAnal
\end{code}
......@@ -279,7 +277,6 @@ opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals
maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals="
opt_D_dump_absC = lookUp SLIT("-ddump-absC")
opt_D_dump_asm = lookUp SLIT("-ddump-asm")
opt_D_dump_deforest = lookUp SLIT("-ddump-deforest")
opt_D_dump_deriv = lookUp SLIT("-ddump-deriv")
opt_D_dump_ds = lookUp SLIT("-ddump-ds")
opt_D_dump_flatC = lookUp SLIT("-ddump-flatC")
......@@ -412,7 +409,6 @@ classifyOpts = sep argv [] [] -- accumulators...
"-fstatic-args" -> CORE_TD(CoreDoStaticArgs)
"-fstrictness" -> CORE_TD(CoreDoStrictness)
"-fspecialise" -> CORE_TD(CoreDoSpecialising)
"-fdeforest" -> CORE_TD(CoreDoDeforest)
"-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper)
"-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal)
......
......@@ -74,9 +74,6 @@ type binding;
inline_uprag: < ginline_id : qid;
ginline_line : long; >;
deforest_uprag: < gdeforest_id : qid;
gdeforest_line : long; >;
magicuf_uprag:< gmagicuf_id : qid;
gmagicuf_str : stringId;
gmagicuf_line : long; >;
......
......@@ -329,10 +329,6 @@ NL [\n\r]
PUSH_STATE(UserPragma);
RETURN(MAGIC_UNFOLDING_UPRAGMA);
}
<Code,GlaExt>"{-#"{WS}*"DEFOREST" {
PUSH_STATE(UserPragma);
RETURN(DEFOREST_UPRAGMA);
}
<Code,GlaExt>"{-#"{WS}*"GENERATE_SPECS" {
/* these are handled by hscpp */
nested_comments =1;
......
......@@ -185,7 +185,7 @@ BOOLEAN inpat;
%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
%token INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
%token DEFOREST_UPRAGMA END_UPRAGMA
%token END_UPRAGMA
%token SOURCE_UPRAGMA
/**********************************************************************
......@@ -613,12 +613,6 @@ decl : qvarsk DCOLON sigtype
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
| DEFOREST_UPRAGMA qvark END_UPRAGMA
{
$$ = mkdeforest_uprag($2, startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
/* end of user-specified pragmas */
| valdef
......
......@@ -534,11 +534,6 @@ prbind(b)
plineno(ginline_line(b));
pqid(ginline_id(b));
break;
case deforest_uprag:
PUTTAGSTR("Sd");
plineno(gdeforest_line(b));
pqid(gdeforest_id(b));
break;
case magicuf_uprag:
PUTTAGSTR("Su");
plineno(gmagicuf_line(b));
......@@ -744,7 +739,6 @@ ppragma(p)
case igen_pragma: PUTTAGSTR("Pg");
ppragma(gprag_arity(p));
ppragma(gprag_update(p));
ppragma(gprag_deforest(p));
ppragma(gprag_strictness(p));
ppragma(gprag_unfolding(p));
plist(ppragma, gprag_specs(p));
......@@ -755,8 +749,6 @@ ppragma(p)
case iupdate_pragma: PUTTAGSTR("Pu");
pid(gprag_update_val(p));
break;
case ideforest_pragma: PUTTAGSTR("PD");
break;
case istrictness_pragma: PUTTAGSTR("PS");
print_string(gprag_strict_spec(p));
ppragma(gprag_strict_wrkr(p));
......
......@@ -63,7 +63,6 @@ data RdrBinding
-- user pragmas come in in a Sig-ish way/form...
| RdrSpecValSig [RdrNameSig]
| RdrInlineValSig RdrNameSig
| RdrDeforestSig RdrNameSig
| RdrMagicUnfoldingSig RdrNameSig
| RdrSpecInstSig RdrNameSpecInstSig
| RdrSpecDataSig RdrNameSpecDataSig
......
......@@ -49,7 +49,6 @@ cvClassOpSig (RdrTySig vars poly_ty src_loc)
cvInstDeclSig (RdrSpecValSig sigs) = sigs
cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
cvInstDeclSig (RdrDeforestSig sig) = [ sig ]
cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ]
\end{code}
......@@ -96,7 +95,6 @@ cvMonoBindsAndSigs sf sig_cvtr fb
mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc)
mangle_bind (b_acc, s_acc) (RdrInlineValSig sig) = (b_acc, sig : s_acc)
mangle_bind (b_acc, s_acc) (RdrDeforestSig sig) = (b_acc, sig : s_acc)
mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
mangle_bind (b_acc, s_acc)
......
......@@ -683,12 +683,6 @@ wlk_sig_thing (U_inline_uprag ivar srcline)
wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrInlineValSig (InlineSig var src_loc))
-- "deforest me" user-pragma
wlk_sig_thing (U_deforest_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrDeforestSig (DeforestSig var src_loc))
-- "magic" unfolding user-pragma
wlk_sig_thing (U_magicuf_uprag ivar str srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
......
......@@ -498,11 +498,6 @@ renameSig (InlineSig v src_loc)
lookupBndrRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc)
renameSig (DeforestSig v src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
returnRn (DeforestSig new_v src_loc)
renameSig (MagicUnfoldingSig v str src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
......@@ -529,7 +524,6 @@ sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _ _) = ILIT(2)
sig_tag (InlineSig n1 _) = ILIT(3)
sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
sig_tag (DeforestSig n1 _) = ILIT(5)
sig_tag _ = panic# "tag(RnBinds)"
sig_name (Sig n _ _) = n
......
......@@ -275,11 +275,6 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
lookupBndrRn op `thenRn` \ op_name ->
returnRn (InlineSig op_name locn)
rn_uprag (DeforestSig op locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
returnRn (DeforestSig op_name locn)
rn_uprag (MagicUnfoldingSig op str locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
......@@ -562,7 +557,6 @@ rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
rnIdInfo (HsDeforest df) = returnRn (HsDeforest df)
rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
......
......@@ -92,12 +92,6 @@ import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
import Bag
import Maybes
#ifndef OMIT_DEFORESTER
import Deforest ( deforestProgram )
import DefUtils ( deforestable )
#endif
\end{code}
\begin{code}
......@@ -222,16 +216,6 @@ core2core core_todos module_name us local_tycons tycon_specs binds
end_pass us2 p spec_data2 simpl_stats "Specialise"
}
CoreDoDeforest
#if OMIT_DEFORESTER
-> error "ERROR: CoreDoDeforest: not built into compiler\n"
#else
-> _scc_ "Deforestation"
begin_pass "Deforestation" >>
case (deforestProgram binds us1) of { binds2 ->
end_pass us2 binds2 spec_data simpl_stats "Deforestation" }
#endif
CoreDoPrintCore -- print result of last pass
-> dumpIfSet (not opt_D_verbose_core2core) "Print Core"
(pprCoreBindings pprDumpStyle binds) >>
......
......@@ -33,7 +33,6 @@ import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
idMustBeINLINEd, GenId{-instance Outputable-}
)
import SpecEnv ( SpecEnv, lookupSpecEnv )
import IdInfo ( DeforestInfo(..) )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
import Outputable ( Outputable(..), PprStyle(..) )
......
......@@ -693,8 +693,6 @@ tcPragmaSigs sigs
Here are the easy cases for tcPragmaSigs
\begin{code}
tcPragmaSig (DeforestSig name loc)
= returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
tcPragmaSig (InlineSig name loc)
= returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
tcPragmaSig (MagicUnfoldingSig name string loc)
......
......@@ -94,7 +94,6 @@ tcIdInfo unf_env name ty info info_ins
go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
go info (HsDeforest df : rest) = go (info `addDeforestInfo` df) rest
go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
go (info `addUnfoldInfo` unfold_info) rest
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment