reader profiling parser
-ifeq ($(GhcWithDeforester),YES)
- DIRS += deforest
-endif
-
ifeq ($(GhcWithNativeCodeGen),YES)
DIRS += nativeGen
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
addIdDemandInfo,
addIdStrictness,
addIdUpdateInfo,
- addIdDeforestInfo,
getIdArity,
getIdDemandInfo,
getIdInfo,
%************************************************************************
%* *
-\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)}
%* *
%************************************************************************
UpdateInfo, SYN_IE(UpdateSpec),
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
- DeforestInfo(..),
- deforestInfo, ppDeforestInfo, addDeforestInfo,
-
ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType),
mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
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.
\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@
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
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}
-> 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,
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]
\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 #-}"
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}
%************************************************************************
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_")
%************************************************************************
\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}
%************************************************************************
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
\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@}
%* *
\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)
\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))
| 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
= 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 "#-}"])
| HsStrictness (HsStrictnessInfo name)
| HsUnfold Bool (UfExpr name) -- True <=> INLINE pragma
| HsUpdate UpdateInfo
- | HsDeforest DeforestInfo
| HsArgUsage ArgUsageInfo
| HsFBType FBTypeInfo
-- ToDo: specialisations
= 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;
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,
| CoreDoStaticArgs
| CoreDoStrictness
| CoreDoSpecialising
- | CoreDoDeforest
| CoreDoFoldrBuildWorkerWrapper
| CoreDoFoldrBuildWWAnal
\end{code}
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")
"-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)
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; >;
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;
%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
%token INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
-%token DEFOREST_UPRAGMA END_UPRAGMA
+%token END_UPRAGMA
%token SOURCE_UPRAGMA
/**********************************************************************
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
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));
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));
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));
-- user pragmas come in in a Sig-ish way/form...
| RdrSpecValSig [RdrNameSig]
| RdrInlineValSig RdrNameSig
- | RdrDeforestSig RdrNameSig
| RdrMagicUnfoldingSig RdrNameSig
| RdrSpecInstSig RdrNameSpecInstSig
| RdrSpecDataSig RdrNameSpecDataSig
cvInstDeclSig (RdrSpecValSig sigs) = sigs
cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
-cvInstDeclSig (RdrDeforestSig sig) = [ sig ]
cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ]
\end{code}
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)
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 ->
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 ->
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
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 ->
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
import Bag
import Maybes
-
-#ifndef OMIT_DEFORESTER
-import Deforest ( deforestProgram )
-import DefUtils ( deforestable )
-#endif
-
\end{code}
\begin{code}
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) >>
idMustBeINLINEd, GenId{-instance Outputable-}
)
import SpecEnv ( SpecEnv, lookupSpecEnv )
-import IdInfo ( DeforestInfo(..) )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
import Outputable ( Outputable(..), PprStyle(..) )
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)
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
import HsPat ( OutPat )
import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas )
import Id ( StrictnessMark, GenId, Id(..) )
-import IdInfo ( IdInfo, ArityInfo, DeforestInfo, StrictnessInfo, UpdateInfo )
+import IdInfo ( IdInfo, ArityInfo, StrictnessInfo, UpdateInfo )
import Demand ( Demand )
import Kind ( Kind )
import Literal ( Literal )
data Coercion
data CostCentre
data DataPragmas a
-data DeforestInfo
data Demand
data ExportFlag
data FieldLabel
projects / ghc-hetmet.git / commitdiff