Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
GHC
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Requirements
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Container Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Yiming Yang
GHC
Commits
f27ff5cc
Commit
f27ff5cc
authored
27 years ago
by
sof
Browse files
Options
Downloads
Patches
Plain Diff
[project @ 1997-09-04 20:03:52 by sof]
unfolding code simplified
parent
e00e72df
Loading
Loading
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
ghc/compiler/simplCore/SimplVar.lhs
+43
-34
43 additions, 34 deletions
ghc/compiler/simplCore/SimplVar.lhs
with
43 additions
and
34 deletions
ghc/compiler/simplCore/SimplVar.lhs
+
43
−
34
View file @
f27ff5cc
...
...
@@ -60,30 +60,27 @@ completeVar env var args result_ty
= tick MagicUnfold `thenSmpl_`
magic_result
| not do_deforest &&
maybeToBool maybe_unfolding_info &&
(not essential_unfoldings_only || idMustBeINLINEd var) &&
-- If "essential_unfolds_only" is true we do no inlinings at all,
-- If there's an InUnfolding it means that there's no
-- let-binding left for the thing, so we'd better inline it!
| must_unfold
= let
Just (_, _, InUnfolding rhs_env rhs) = info_from_env
in
unfold var rhs_env rhs args result_ty
-- Conditional unfolding. There's a binding for the
-- thing, but perhaps we want to inline it anyway
| ( maybeToBool maybe_unfolding_info
&& (not essential_unfoldings_only || idMustBeINLINEd var)
-- If "essential_unfoldings_only" is true we do no inlinings at all,
-- EXCEPT for things that absolutely have to be done
-- (see comments with idMustBeINLINEd)
ok_to_inline &&
costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
=
{-
simplCount `thenSmpl` \ n ->
(if n > 1000 then
pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr PprDebug var])
else
id
&& ok_to_inline
&& costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
)
(if n>4000 then
returnSmpl (mkGenApp (Var var) args)
else
-}
= unfold var unf_env unf_template args result_ty
tickUnfold var `thenSmpl_`
simplExpr unfold_env unf_template args result_ty
| maybeToBool maybe_specialisation
= tick SpecialisationDone `thenSmpl_`
...
...
@@ -96,6 +93,7 @@ completeVar env var args result_ty
= returnSmpl (mkGenApp (Var var) args)
where
info_from_env = lookupOutIdEnv env var
unfolding_from_id = getIdUnfolding var
---------- Magic unfolding stuff
...
...
@@ -106,26 +104,25 @@ completeVar env var args result_ty
(Just magic_result) = maybe_magic_result
---------- Unfolding stuff
must_unfold = case info_from_env of
Just (_, _, InUnfolding _ _) -> True
other -> False
maybe_unfolding_info
= case (
lookupOutIdEnv env var
, unfolding_from_id) of
= case (
info_from_env
, unfolding_from_id) of
(Just (_, occ_info, OutUnfolding enc_cc unf), _)
-> Just (occ_info, setEnclosingCC env enc_cc, unf)
(Just (_, occ_info, InUnfolding env_unf unf), _)
-> -- pprTrace ("InUnfolding for ") (ppr PprDebug var) $
Just (occ_info, env_unf, unf)
(_, CoreUnfolding unf)
-> -- pprTrace ("CoreUnfolding for ") (ppr PprDebug var) $
Just (noBinderInfo, env, unf)
-> Just (noBinderInfo, env, unf)
other -> Nothing
Just (occ_info, unf
old
_env, simple_unfolding)
= maybe_unfolding_info
Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
SimpleUnfolding form guidance unf_template = simple_unfolding
---------- Specialisation stuff
---------- Specialisation stuff
(ty_args, remaining_args) = initialTyArgs args
maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
(Just (spec_template, (spec_bindings, leftover_ty_args))) = maybe_specialisation
...
...
@@ -142,11 +139,23 @@ completeVar env var args result_ty
is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
is_evald (LitArg l) = True
#if OMIT_DEFORESTER
do_deforest = False
#else
do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
#endif
-- Perform the unfolding
unfold var unf_env unf_template args result_ty
=
{-
simplCount `thenSmpl` \ n ->
(if n > 1000 then
pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr PprDebug var])
else
id
)
(if n>4000 then
returnSmpl (mkGenApp (Var var) args)
else
-}
tickUnfold var `thenSmpl_`
simplExpr unf_env unf_template args result_ty
-- costCentreOk checks that it's ok to inline this thing
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment