[commit: ghc] supercompiler: Remove some tabs the commit hook is complaining about (7b68eb7)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/7b68eb7d761fbf288e74f2fe300bf132cb6bfb97
---
commit 7b68eb7d761fbf288e74f2fe300bf132cb6bfb97
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Thu Oct 4 15:08:44 2012 +0100
Remove some tabs the commit hook is complaining about
---
compiler/supercompile/Supercompile/Drive/Split2.hs |3 +++
compiler/typecheck/TcInstDcls.lhs |6 +++---
2 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs
b/compiler/supercompile/Supercompile/Drive/Split2.hs
index 3af1f52..51b412e 100644
--- a/compiler/supercompile/Supercompile/Drive/Split2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split2.hs
@@ -208,6 +208,9 @@ data Context = HeapContext Var
| FocusContext
deriving (Eq, Ord)
+instance Show Context where
+show = showPpr
+
instance Outputable Context where
pprPrec prec (HeapContext x') = pprPrec prec x'
pprPrec prec (StackContext i) = pprPrec prec i
diff --git a/compiler/typecheck/TcInstDcls.lhs
b/compiler/typecheck/TcInstDcls.lhs
index 2106da1..4bb8b6b 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -511,7 +511,7 @@ cyclicDeclErr :: Outputable d = [Located d] - TcRn ()
cyclicDeclErr inst_decls
= setSrcSpan (getLoc (head sorted_decls)) $
addErr (sep [ptext (sLit Cycle in type declarations: data constructor
used (in a type) before it is defined),
-nest 2 (vcat (map ppr_decl sorted_decls))])
+ nest 2 (vcat (map ppr_decl sorted_decls))])
where
sorted_decls = sortLocated inst_decls
ppr_decl (L loc decl) = ppr loc colon + ppr decl
@@ -585,8 +585,8 @@ tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty,
cid_binds = binds
-- Dfun location is that of instance *header*
; overlap_flag - getOverlapFlag
-; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
- ispec= mkLocalInstance dfun overlap_flag
+; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
+ ispec = mkLocalInstance dfun overlap_flag
inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst
binds uprags False }
; return ( [inst_info], fam_insts0 ++ concat fam_insts1) }
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix MSG not preserving global-idness (ea23213)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ea232136c947a1d68da35809ea62a2d3074e48e4
---
commit ea232136c947a1d68da35809ea62a2d3074e48e4
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Thu Oct 4 16:30:16 2012 +0100
Fix MSG not preserving global-idness
---
compiler/supercompile/Supercompile.hs |1 -
compiler/supercompile/Supercompile/Drive/MSG.hs | 20 ++--
2 files changed, 10 insertions(+), 11 deletions(-)
diff --git a/compiler/supercompile/Supercompile.hs
b/compiler/supercompile/Supercompile.hs
index 5f59e69..5e52e96 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -147,7 +147,6 @@ mkLiftedTupleSelector xs want_x tup_e
termUnfoldings :: S.Term - [(Var, S.Term)]
termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] []
where
--- FIXME: varBndrFreeVars?
go new_fvs all_fvs all_xwhy_nots all_xes
| isEmptyVarSet added_fvs = pprTrace termUnfoldings (vcat [hang (text
why_not text :) 2 (vcat (map ppr xs)) | (why_not, xs) - groups snd fst
all_xwhy_nots]) $
all_xes
diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs
b/compiler/supercompile/Supercompile/Drive/MSG.hs
index 3736fc0..a702cc0 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -23,8 +23,8 @@ import Util
import Coercion
import CoreUtils (hashCoercion, hashType {- , hashExpr -})
import Name (mkSystemVarName)
-import Var(TyVar, mkTyVar, isTyVar, isId, varType, setVarType,
tyVarKind, setTyVarKind, varName, idDetails, setIdDetails, idInfo,
lazySetIdInfo)
-import Id (Id, idType, idName, realIdUnfolding, setIdUnfolding,
idSpecialisation, setIdSpecialisation, mkSysLocal, mkLocalId)
+import Var(TyVar, mkTyVar, isTyVar, isId, varType, setVarType,
tyVarKind, setTyVarKind, varName, idDetails, setIdDetails, idInfo,
lazySetIdInfo, varUnique)
+import Id (Id, idType, idName, realIdUnfolding, setIdUnfolding,
idSpecialisation, setIdSpecialisation, mkSysLocal, mkLocalId, isGlobalId)
import IdInfo (SpecInfo(..))
import VarEnv
import Pair
@@ -235,14 +235,14 @@ msgPend rn2 x0 pending = MSG $ \e s0 - case
lookupUpdatePending s0 of
Right x - (s0, pure x)
Left (mb_eq, binderise, mk_s) - case res of (_, Left msg) - (s0, Left
msg)
(s3, Right x) - (s3, Right
x) -- NB: must revert state or else x_looped will be in the msgKnownVars, and
pulling on it will fail the irrefutible pattern match
- where -- The use of s here is necessary to ensure we only allocate a
given common var once
-extra_iss | Just eq - mb_eq
- , eq `elemInScopeSet` msgCommonHeapVars (msgMode e)
- = emptyInScopeSet
- | otherwise
- = msgInScopeSet s0
--- This use of rn2 is 1/2 of the story necessary to ensure new
common vars don't clash with rigid binders
-x1 = uniqAway (rnInScopeSet rn2 `unionInScope` extra_iss) x0
+ where x1 = case mb_eq of
+ Just eq | eq `elemInScopeSet` msgCommonHeapVars (msgMode e)
|| isGlobalId eq
+ -- The incoming x0 is always a local variable, but we
better make a damn sure that we return a global variable if necessary
+ -- TODO: maybe all global ids should be in the initial
InScopeSet? Would need to change prepareTerm.
+ - eq
+ -- This use of rn2 is 1/2 of the story necessary to ensure
new common vars don't clash with rigid binders
+ -- The use of s here is necessary to ensure we only
allocate a given common var once
+ _ - uniqAway (rnInScopeSet rn2 `unionInScope`
msgInScopeSet s0) x0
-- We *don't* need to uniqAway with the set of common variables
(in e) because the msgInScopeSet
-- was initialized to contain them all.
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Checkpoint speculator work (8fa49be)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/8fa49be1a3195e1b5e9a1babd5158202cf25580c --- commit 8fa49be1a3195e1b5e9a1babd5158202cf25580c Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Oct 5 08:53:13 2012 +0100 Checkpoint speculator work .../supercompile/Supercompile/Drive/Process.hs | 113 +--- .../supercompile/Supercompile/Drive/Process3.hs|2 +- compiler/supercompile/Supercompile/Utilities.hs| 31 -- 3 files changed, 119 insertions(+), 27 deletions(-) Diff suppressed because of size. To see it, use: git show 8fa49be1a3195e1b5e9a1babd5158202cf25580c ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Add comments only (fac9686)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/fac968604ccd4e0595136c120fb2ad1ba5905af0
---
commit fac968604ccd4e0595136c120fb2ad1ba5905af0
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 5 12:00:48 2012 +0100
Add comments only
---
.../supercompile/Supercompile/Drive/Process.hs |5 +
1 files changed, 5 insertions(+), 0 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs
b/compiler/supercompile/Supercompile/Drive/Process.hs
index cbbe6b6..0a73a22 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -638,6 +638,11 @@ type SpecRB = SpecHistory - SpecM (SpecHistory, Deeds,
Heap)
type Depth = Train (SpecRB, Var) (SpecRB, Var)
newtype SpecHistory = SH { unSH :: LinearHistory (State, Depth) }
+-- FIXME: AlreadySpeculated should be renamed when we generalise since heap
bindings may change name
+
+-- NB: we can't use the domain of the heap incoming to the previous reduce
call as the AlreadySpeculated
+-- set because normalisation may have caused some unspeculated bindings to
enter the heap since the last speculate
+-- (e.g. consider splitting into the branch of a case where the branch has
some top level lets)
speculateHeap :: AlreadySpeculated - (SCStats, Deeds, Heap) -
(AlreadySpeculated, (SCStats, Deeds, Heap))
speculateHeap speculated (stats, deeds, heap@(Heap h _)) = {-# SCC speculate
#-} (M.keysSet h', (mempty, deeds', heap'))
where
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Checkpoint possible new speculator implementation that goes to some trouble to be idempotent (6a48bdd)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6a48bdd3ec9c6162010172f163151f122be44b45 --- commit 6a48bdd3ec9c6162010172f163151f122be44b45 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Oct 9 18:39:14 2012 +0100 Checkpoint possible new speculator implementation that goes to some trouble to be idempotent .../supercompile/Supercompile/Drive/Process.hs | 92 ++-- compiler/supercompile/Supercompile/Utilities.hs| 17 +++- 2 files changed, 101 insertions(+), 8 deletions(-) Diff suppressed because of size. To see it, use: git show 6a48bdd3ec9c6162010172f163151f122be44b45 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: FIx stupid bug with summary given to GHC heuristics (0a2664c)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/0a2664ce044b22c3a12800da2a50299b0e3f6c35
---
commit 0a2664ce044b22c3a12800da2a50299b0e3f6c35
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Thu Oct 18 20:58:23 2012 +0100
FIx stupid bug with summary given to GHC heuristics
---
.../Supercompile/Evaluator/Evaluate.hs |2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index e6b044b..c182c5b 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -363,7 +363,7 @@ step' normalising ei_state = {-# SCC step' #-}
--
-- Perhaps if we had deep normalisation + GC we could get these
results by penalising heap allocation heavily?
-- If so we must remember to do it for heap bindings *and* letrecs.
-let k_summary = summariseContext h k
+let k_summary = summariseContext h (Car kf k)
guard $ case () of
_ -- If the lambda is marked SUPERINLINABLE, always inline it
| super
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Horrible patches to make memocache preinit work (b99c6ae)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/b99c6ae21dc46543c0c4db29aff2260dd368bbfe --- commit b99c6ae21dc46543c0c4db29aff2260dd368bbfe Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Oct 18 20:59:09 2012 +0100 Horrible patches to make memocache preinit work .../supercompile/Supercompile/Drive/Process.hs | 82 +++ compiler/supercompile/Supercompile/StaticFlags.hs |4 +- 2 files changed, 67 insertions(+), 19 deletions(-) Diff suppressed because of size. To see it, use: git show b99c6ae21dc46543c0c4db29aff2260dd368bbfe ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Idempotent speculator (9d99feb)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/9d99febef391d3c43d481d5efb9290821dab6c80 --- commit 9d99febef391d3c43d481d5efb9290821dab6c80 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Oct 18 20:58:57 2012 +0100 Idempotent speculator .../supercompile/Supercompile/Drive/Process.hs | 68 .../Supercompile/Termination/TagBag.hs |5 +- 2 files changed, 44 insertions(+), 29 deletions(-) Diff suppressed because of size. To see it, use: git show 9d99febef391d3c43d481d5efb9290821dab6c80 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Disable instance matching by default (9cf9598)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/9cf959869c26a561e88fb9f791b61d2fed66933f --- commit 9cf959869c26a561e88fb9f791b61d2fed66933f Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Oct 19 10:44:25 2012 +0100 Disable instance matching by default --- compiler/supercompile/Supercompile/StaticFlags.hs |2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs index 1244224..a583acd 100644 --- a/compiler/supercompile/Supercompile/StaticFlags.hs +++ b/compiler/supercompile/Supercompile/StaticFlags.hs @@ -25,7 +25,7 @@ data InstanceMatching = NoInstances | InstancesOfGeneralised | AllInstances -- of MSG-based generalisation+rollback, and has the potential to lose more useful optimisation than that combo does. -- Matching back to generalised stuff is still a good idea, but we need to propagate generalised flags more agressively (FIXME) iNSTANCE_MATCHING :: InstanceMatching -iNSTANCE_MATCHING = parseEnum -fsupercompiler-instance-matching InstancesOfGeneralised [(full, AllInstances), (generalised, InstancesOfGeneralised), (none, NoInstances)] +iNSTANCE_MATCHING = parseEnum -fsupercompiler-instance-matching NoInstances [(full, AllInstances), (generalised, InstancesOfGeneralised), (none, NoInstances)] -- This is not remotely safe: fLOAT_TO_MATCH :: Bool ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Do memocache preinit even when using let-bindings (7936e48)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/7936e4879e73957ea96cc639db9897d7899cf70b --- commit 7936e4879e73957ea96cc639db9897d7899cf70b Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Oct 19 12:05:29 2012 +0100 Do memocache preinit even when using let-bindings .../supercompile/Supercompile/Drive/Process.hs | 21 ++- .../supercompile/Supercompile/Drive/Process1.hs|2 +- .../supercompile/Supercompile/Drive/Process2.hs|2 +- .../supercompile/Supercompile/Drive/Process3.hs| 12 ++ compiler/supercompile/Supercompile/StaticFlags.hs |4 +++ 5 files changed, 28 insertions(+), 13 deletions(-) Diff suppressed because of size. To see it, use: git show 7936e4879e73957ea96cc639db9897d7899cf70b ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Don't pull on prepareTerm result unless needed (f89af0c)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/f89af0cc364255f77fb0ab9f2109ee54821be850
---
commit f89af0cc364255f77fb0ab9f2109ee54821be850
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 19 10:45:35 2012 +0100
Don't pull on prepareTerm result unless needed
---
.../supercompile/Supercompile/Drive/Process3.hs| 10 ++
1 files changed, 6 insertions(+), 4 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs
b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 19e6532..a335986 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -756,10 +756,12 @@ reduceForMatch state | rEDUCE_BEFORE_MATCH = {- second gc
$ -} reduceWithFlag (c
supercompile :: M.Map Var Term - Term - Term
supercompile unfoldings e = fVedTermToTerm $ start (liftM snd . sc)
- where (bvs_unfoldings, (to_bind, state), (preinit_with, preinit_state)) =
prepareTerm unfoldings e
-start k | pREINITALIZE_MEMO_TABLE = run $ preinitalise preinit_with
withScpEnv (\e - e { scpAlreadySpeculated = bvs_unfoldings `S.union`
scpAlreadySpeculated e }) (k preinit_state)
-| otherwise = bindManyMixedLiftedness
fvedTermFreeVars to_bind $ run $ k state
-run = runScpM (tagAnnotations state)
+ where (bvs_unfoldings, no_preinit, preinit) = prepareTerm unfoldings e
+(to_bind, state) = no_preinit -- Delay forcing these to
suppress
+(preinit_with, preinit_state) = preinit-- prepareTerm debug prints
+start k | pREINITALIZE_MEMO_TABLE = run preinit_state $ preinitalise
preinit_with withScpEnv (\e - e { scpAlreadySpeculated = bvs_unfoldings
`S.union` scpAlreadySpeculated e }) (k preinit_state)
+| otherwise = bindManyMixedLiftedness
fvedTermFreeVars to_bind $ run state $ k state
+run tags_state = runScpM (tagAnnotations tags_state)
preinitalise :: [(State, FVedTerm)] - ScpM ()
preinitalise states_fulfils = forM_ states_fulfils $ \(state, e') - do
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix critical bug where FVs of generalised stack tails would not be sucked (64667ed)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/64667edfaf92756b0a9a2c65a688accfb99d8bdd
---
commit 64667edfaf92756b0a9a2c65a688accfb99d8bdd
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 19 12:23:41 2012 +0100
Fix critical bug where FVs of generalised stack tails would not be sucked
---
compiler/supercompile/Supercompile/Drive/MSG.hs |2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs
b/compiler/supercompile/Supercompile/Drive/MSG.hs
index a702cc0..935d48f 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -1152,7 +1152,7 @@ initStack xs i (Car kf_l k_l) (Car kf_r k_r) = do
_ - return (xs, Nothing, Nothing)
let suck = initSuckStackFrame i mb_x kf_l kf_r
liftM (\(mxs, k_lrs, sucks) - (maybe id (:) mb_mx mxs, liftA2 (\kf_lr
(k_avail_lr, k_lr) - (kf_lr `Car` k_avail_lr, k_lr)) (Pair kf_l kf_r) k_lrs,
IM.insert i suck sucks)) $ initStack xs (i + 1) k_l k_r
-initStack _ _ k_l k_r = return ([], Pair (Loco (stackGeneralised k_l), k_l)
(Loco (stackGeneralised k_r), k_r), IM.empty)
+initStack _ i k_l k_r = return ([], Pair (Loco (stackGeneralised k_l), k_l)
(Loco (stackGeneralised k_r), k_r), IM.singleton i (sucks2 $ fmap stackFreeVars
(Pair k_l k_r)))
initSuckStackFrame :: Int - Maybe (Var {- partial loop -}, Pair Var) -
Tagged StackFrame - Tagged StackFrame - MSGU ()
initSuckStackFrame i mb_x (Tagged tg_l kf_l) (Tagged tg_r kf_r) = do
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Lexical marking of SUPERINLINABLEs in current module as well as imported modules (42ef500)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/42ef5005bf56129c8e9e7c511a8077c38b501226
---
commit 42ef5005bf56129c8e9e7c511a8077c38b501226
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 19 16:22:43 2012 +0100
Lexical marking of SUPERINLINABLEs in current module as well as imported
modules
---
compiler/supercompile/Supercompile.hs | 34
1 files changed, 21 insertions(+), 13 deletions(-)
diff --git a/compiler/supercompile/Supercompile.hs
b/compiler/supercompile/Supercompile.hs
index 5e52e96..573c308 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -184,7 +184,7 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] []
DFunUnfolding _ dc es - Right $ runParseM us2 $
coreExprToTerm $ mkLams as $ mkLams xs $ Var (dataConWorkId dc) `mkTyApps`
cls_tys `mkApps` [(e `mkTyApps` map mkTyVarTy as) `mkVarApps` xs | e - es]
where (as, theta, _cls, cls_tys) = tcSplitDFunTy (idType x)
xs = zipWith (mkSysLocal (fsLit x)) bv_uniques theta
- CoreUnfolding { uf_tmpl = e } - Right $ (if super then
markSuperinlinable else id) $ runParseM us2 $ coreExprToTerm e
+ CoreUnfolding { uf_tmpl = e } - Right $ superinlinableLexically
super $ runParseM us2 $ coreExprToTerm e
-- NB: it's OK if the unfolding is a non-value, as the evaluator
won't inline LetBound non-values
primOpUnfolding pop = S.tyLambdas as $ S.lambdas xs $ S.primOp pop (map
mkTyVarTy as) (map S.var xs)
@@ -217,11 +217,14 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] []
-- NB: this is used to deal with SUPERINLINABLE bindings which have locally
bound loops which
-- are *not* marked SUPERINLINABLE
--
+-- NB: for this to work properly, coreExprToTerm must not float
+-- stuff that was lexically within a binding out of that binding!
+--
-- TODO: this is actually useless if we just say that all InternallyBound
things are SUPERINLINABLE
-markSuperinlinable :: S.Term - S.Term
---markSuperinlinable = id
+superinlinableLexically :: Superinlinable - S.Term - S.Term
+--superinlinableLexically = id
{--}
-markSuperinlinable = term
+superinlinableLexically ctxt = term
where
term e = flip fmap e $ \e - case e of
S.Var x - S.Var x
@@ -233,16 +236,19 @@ markSuperinlinable = term
S.CoApp e co - S.CoApp (term e) co
S.App e x - S.App (term e) x
S.PrimOp pop tys es - S.PrimOp pop tys (map term es)
- S.Case e x ty alts - S.Case (term e) x ty (map (second term) alts)
- S.Let x e1 e2 - S.Let (bndr x) (term e1) (term e2)
- S.LetRec xes e - S.LetRec (map (bndr *** term) xes) (term e)
+ S.Case e x ty alts - uncurry (flip S.Case) (pair (x, e)) ty (map
(second term) alts)
+ S.Let x e1 e2 - uncurry S.Let (pair (x, e1)) (term e2)
+ S.LetRec xes e - S.LetRec (map pair xes) (term e)
S.Cast e co - S.Cast (term e) co
-bndr x = x `setInlinePragma` (idInlinePragma x) { inl_inline = case
inl_inline (idInlinePragma x) of
- Inline
- Inline
- Inlinable
_ - Inlinable True
- NoInline
- NoInline
-
EmptyInlineSpec - Inlinable True }
+pair (x, e) | not ctxt = case S.shouldExposeUnfolding x of Right True -
(x, superinlinableLexically True e)
+_ -
(x, term e)
+| otherwise = (x', term e)
+ where x' = x `setInlinePragma` (idInlinePragma x) { inl_inline = case
inl_inline (idInlinePragma x) of
+
Inline - Inline
+
Inlinable _ - Inlinable True
+
NoInline- NoInline
+
EmptyInlineSpec - Inlinable True }
{--}
@@ -252,7 +258,9 @@ supercompile e = -- liftM (termToCoreExpr . snd) $
return $ termToCoreExpr $
S.supercompile (M.fromList unfs) e'
where unfs = termUnfoldings e'
-e' = runParseM anfUniqSupply' (coreExprToTerm e)
+-- NB: ensure we mark any child bindings of bindings marked
SUPERINLINABLE in *this module* as SUPERINLINABLE,
+-- just like we would if we imported a SUPERINLINABLE binding
+e
[commit: ghc] supercompiler: Made pairT lazier (021214f)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/021214f87371dfa1c1e1f65e4b6e494333e37bb9 --- commit 021214f87371dfa1c1e1f65e4b6e494333e37bb9 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Oct 19 12:48:48 2012 +0100 Made pairT lazier --- .../Supercompile/Termination/Combinators.hs|3 ++- 1 files changed, 2 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Termination/Combinators.hs b/compiler/supercompile/Supercompile/Termination/Combinators.hs index 80c8fcb..d7639ac 100644 --- a/compiler/supercompile/Supercompile/Termination/Combinators.hs +++ b/compiler/supercompile/Supercompile/Termination/Combinators.hs @@ -111,9 +111,10 @@ pairT :: TTest a - TTest b - TTest (a, b) pairT (WQO prepare_a embed_a) (WQO prepare_b embed_b) = WQO (prepare_a *** prepare_b) go where go (a1, b1) (a2, b2) = zipPair ((), ()) (a1 `embed_a` a2) (b1 `embed_b` b2) +-- NB: zipPair is lazy in the second pair so that when f/g are () we can doing some evaluation zipPair :: (a - b - c, d - e - f) - (a, d) - (b, e) - (c, f) -zipPair (f, g) (a, d) (b, e) = (f a b, g d e) +zipPair (f, g) (a, d) ~(b, e) = (f a b, g d e) -- | Type class of zippable things. Instances should satisfy the laws: -- ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Slight improvement to power of reduce termination test by using gc, more debug output (6b8c902)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/6b8c90246bcee13f03bdb20352b25d425412b1e7
---
commit 6b8c90246bcee13f03bdb20352b25d425412b1e7
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 19 16:23:21 2012 +0100
Slight improvement to power of reduce termination test by using gc, more
debug output
---
.../supercompile/Supercompile/Drive/Process.hs |4 ++--
1 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs
b/compiler/supercompile/Supercompile/Drive/Process.hs
index 0048c49..e8bcf28 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -891,9 +891,9 @@ reduce' orig_state = go False (mkLinearHistory rEDUCE_WQO)
orig_state
Just (deeds, heap, k, e)
| Just deeds' - if bOUND_STEPS then claimStep deeds else Just deeds
, let state' = (deeds', heap, k, e)
- - case terminate hist state of
+ - case terminate hist (gc state) of
Continue hist' - go True hist' state'
-Stop old_state - pprTrace reduce-stop {- (pPrintFullState
quietStatePrettiness old_state $$ pPrintFullState quietStatePrettiness state)
-} empty
+Stop old_state - pprTrace reduce-stop {--} (pPrintFullState
quietStatePrettiness old_state $$ pPrintFullState quietStatePrettiness state)
{--} -- empty
-- let smmrse s@(_, _, _, qa) = pPrintFullState
s $$ case annee qa of Question _ - text Question; Answer _ - text Answer
in
-- pprPreview2 reduce-stop (smmrse old_state)
(smmrse state) $
(can_step, mempty { stat_reduce_stops = 1 }, if
rEDUCE_ROLLBACK then old_state else state') -- TODO: generalise?
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Show those binders which are SUPERINLINABLE (27195a3)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/27195a3a7caca0228b75e7e5760a937963ecd61c --- commit 27195a3a7caca0228b75e7e5760a937963ecd61c Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Oct 19 16:23:01 2012 +0100 Show those binders which are SUPERINLINABLE --- compiler/supercompile/Supercompile/Core/Syntax.hs |5 +++-- 1 files changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index cc4732f..1bc8fcb 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -16,7 +16,7 @@ import DataCon (DataCon, dataConWorkId) import Var (TyVar, Var, varName, isTyVar, varType) import Name (Name, nameOccName) import OccName (occNameString) -import Id (Id, idType) +import Id (Id, isId, idType, idInlinePragma) import PrimOp (primOpType) import Literal (Literal, literalType) import Type (Type, mkTyVarTy, applyTy, applyTys, mkForAllTy, mkFunTy, splitFunTy_maybe, eqType) @@ -70,10 +70,11 @@ pprPrecDefault prec e = pPrintPrecLam prec xs (PrettyFunction ppr_prec) -- NB: don't use GHC's pprBndr because its way too noisy, printing unfoldings etc pPrintBndr :: BindingSite - Var - SDoc -pPrintBndr bs x = prettyParen needs_parens $ ppr x + text :: + ppr (varType x) +pPrintBndr bs x = prettyParen needs_parens $ ppr x + superinlinable + text :: + ppr (varType x) where needs_parens = case bs of LambdaBind - True CaseBind - True LetBind- False +superinlinable = if isId x then ppr (idInlinePragma x) else empty data AltCon = DataAlt DataCon [TyVar] [CoVar] [Id] | LiteralAlt Literal | DefaultAlt deriving (Eq, Show) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: No sc' tracing (9be06a4)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/9be06a4e824515fd12548ba1ef2af5ae8dc87fd8
---
commit 9be06a4e824515fd12548ba1ef2af5ae8dc87fd8
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 19 16:23:48 2012 +0100
No sc' tracing
---
.../supercompile/Supercompile/Drive/Process3.hs|5 +++--
1 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs
b/compiler/supercompile/Supercompile/Drive/Process3.hs
index b4ab075..1b2bec9 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -284,7 +284,7 @@ sc :: State - ScpM (Deeds, FVedTerm)
sc = memo sc' . gc -- Garbage collection necessary because normalisation might
have made some stuff dead
sc' :: Maybe String - State - ScpM (Bool, (Deeds, FVedTerm)) -- Bool records
whether generalisation occurred, for debug printing
-sc' mb_h state = pprTrace sc' (trce1 state) $ {-# SCC sc' #-} case mb_h of
+sc' mb_h state = {- pprTrace sc' (trce1 state) $ -} {-# SCC sc' #-} case
mb_h of
Nothing - speculateM (reduce state) $ \state - -- traceRenderM !sc
(PrettyDoc (pPrintFullState quietStatePrettiness state))
my_split state
Just h - flip catchM try_generalise $ \rb -
@@ -312,7 +312,8 @@ sc' mb_h state = pprTrace sc' (trce1 state) $ {-# SCC
sc' #-} case mb_h of
-- NB: we could try to generalise against all embedded things in the
history, not just one. This might make a difference in rare cases.
my_generalise splt = liftM ((,) True) $ splt = insertTagsM
-my_split state = liftM ((,) False) $ split sc state = insertTagsM
+my_split state = --pprTrace my_split (pPrintFullState
quietStatePrettiness state) $
+ liftM ((,) False) $ split sc state = insertTagsM
tryTaG, tryMSG :: (State - ScpM (Deeds, Out FVedTerm))
- State - State
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Don't float out of binders that may be marked SUPERINLINABLE when converting from GHC core to preserve lexical structure (15638a4)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/15638a4381e33af35f9375ad5b57d22c52fe4d01
---
commit 15638a4381e33af35f9375ad5b57d22c52fe4d01
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Oct 19 16:24:12 2012 +0100
Don't float out of binders that may be marked SUPERINLINABLE when
converting from GHC core to preserve lexical structure
---
compiler/supercompile/Supercompile/GHC.hs |7 ---
1 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/compiler/supercompile/Supercompile/GHC.hs
b/compiler/supercompile/Supercompile/GHC.hs
index 24e5e97..0c00864 100644
--- a/compiler/supercompile/Supercompile/GHC.hs
+++ b/compiler/supercompile/Supercompile/GHC.hs
@@ -147,6 +147,7 @@ conAppToTerm dc es
fromType_maybe (Type ty) = Just ty
fromType_maybe _ = Nothing
+-- NB: this function must not float stuff out of bindings, so that later
SUPERINLINABLE propagation will work properly
coreExprToTerm :: CoreExpr - ParseM S.Term
coreExprToTerm init_e = {-# SCC coreExprToTerm #-} term init_e
where
@@ -168,9 +169,9 @@ coreExprToTerm init_e = {-# SCC coreExprToTerm #-} term
init_e
term (App e_fun e_arg) = join $ liftM2 appE (term e_fun) (fmap
((,) e_arg) $ maybeUnLiftedTerm (exprType e_arg) e_arg)
term (Lam x e) | isTyVar x = fmap (S.value . S.TyLambda x) (bindFloats
(term e))
| otherwise = fmap (S.value . S.Lambda x) (bindFloats
(term e))
-term (Let (NonRec x e1) e2)= liftM2 (S.let_ x) (maybeUnLiftedTerm
(idType x) e1) (bindFloats (term e2))
-term (Let (Rec xes) e) = bindFloatsWith (liftM2 (,) (mapM (secondM
term) xes) (term e))
-term (Case e x ty alts)= liftM2 (\e alts - S.case_ e x ty alts)
(term e) (mapM alt alts)
+term (Let (NonRec x e1) e2)= liftM2 (S.let_ x) (bindFloats (term e1))
(bindFloats (term e2))
+term (Let (Rec xes) e) = bindFloatsWith (liftM2 (,) (mapM (secondM
(bindFloats . term)) xes) (term e))
+term (Case e x ty alts)= liftM2 (\e alts - S.case_ e x ty alts)
(bindFloats (term e)) (mapM alt alts)
term (Cast e co) = fmap (flip S.cast co) (term e)
term (Tick _ e)= term e -- FIXME: record ticks
term (Type ty) = pprPanic termToCoreExpr (ppr ty)
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix bug in cheap node shortcutting that was pessimising the splitter (8388dd2)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/8388dd29c803ca8800beeea5e00dd5c6e3b398e0 --- commit 8388dd29c803ca8800beeea5e00dd5c6e3b398e0 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Oct 19 16:24:40 2012 +0100 Fix bug in cheap node shortcutting that was pessimising the splitter --- compiler/supercompile/Supercompile/Drive/Split2.hs |7 --- 1 files changed, 4 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs b/compiler/supercompile/Supercompile/Drive/Split2.hs index 51b412e..7a9041b 100644 --- a/compiler/supercompile/Supercompile/Drive/Split2.hs +++ b/compiler/supercompile/Supercompile/Drive/Split2.hs @@ -57,7 +57,7 @@ shortcutEdges :: forall node edge. Ord node = (node - Bool) - (edge - edge - edge) -- Used to join edges if after shortcutting there is more than one path from a node to another one - - (edge - node - edge - edge) -- Used when joining two edges in a contiguous path + - (edge - node - edge - edge) -- Used when joining two edges in a contiguous path (the node always satisfys the predicate) - LGraph node edge - LGraph node edge shortcutEdges should_shortcut combine_edges combine g = State.evalState visit_graph M.empty @@ -464,7 +464,8 @@ type PushedFocus = PushFocus PushedQA State push :: S.Set Context - (Heap, Stack, PushFocus (Anned QA) (In AnnedTerm)) - (PushedHeap, PushedStack, PushedFocus) -push generalised (Heap h ids, k, focus) = (h', k', focus') +push generalised (Heap h ids, k, focus) = -- pprTrace push (ppr verts $$ ppr marked) + (h', k', focus') where -- TODO: arguably I should try to get a QA for the thing in the focus. This will help in cases like where we MSG together: -- H | v | -- and: @@ -498,7 +499,7 @@ push generalised (Heap h ids, k, focus) = (h', k', focus') cheap_marked = S.fromDistinctAscList [HeapContext x' | (x', hb) - M.toAscList h, maybe True (termIsCheap . snd) (heapBindingTerm hb)] S.\\ generalised verts = trimUnreachable FocusContext $ shortcutEdges (`S.member` cheap_marked) - plusEntries (\ent1 _ ent2 - ent1 `plusEntries` ent2) + plusEntries (\ent1 _ _ent2 - ent1) -- NB: we discard ent2. Consider inlining binding (x = Just y) [which marks y as Many] into context (case x of Just y - ...) [which marks x as Once]. We don't want to mark y with Many (i.e. Once+Many) because we can in fact push it down safely. (verts_h `unionDisjoint` (verts_k `unionDisjoint` verts_focus)) extra_marked = solve generalised verts marked = cheap_marked `S.union` extra_marked ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix problems with preinit eta expansion: no gc-destroyed free vars, no dead var occs (4a911d7)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/4a911d725946061ee7765d78d3e9c43e45695b64
---
commit 4a911d725946061ee7765d78d3e9c43e45695b64
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Tue Oct 23 17:59:27 2012 +0100
Fix problems with preinit eta expansion: no gc-destroyed free vars, no dead
var occs
---
.../supercompile/Supercompile/Drive/Process.hs | 51
1 files changed, 30 insertions(+), 21 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs
b/compiler/supercompile/Supercompile/Drive/Process.hs
index e8bcf28..01b0627 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -48,7 +48,7 @@ import Supercompile.StaticFlags
import Supercompile.Utilities hiding (Monad(..))
import Var(isTyVar, isId, tyVarKind, varType, setVarType)
-import Id (idType, zapFragileIdInfo, localiseId, isDictId, isGlobalId)
+import Id (idType, zapIdOccInfo, zapFragileIdInfo, localiseId,
isDictId, isGlobalId)
import MkId (voidArgId, realWorldPrimId, mkPrimOpId)
import Coercion (Coercion(..), isCoVar, mkCoVarCo, mkUnsafeCo, coVarKind)
import TyCon (PrimRep(..))
@@ -402,10 +402,10 @@ prepareTerm unfoldings e = {-# SCC prepareTerm #-}
-- FIXME: update other comments about memocache preinit
-- We can and should do memocache preinit even if we still use
let-bindings in the heap with associated terms
-letty_preinit_with = [(gc (normalise (maxBound, heap', Loco False,
anned_e')), accessor_e)
+letty_preinit_with = [ res
| (x', hb) - M.toList h''_binds_globalid
, Just in_e_def - [heapBindingTerm hb]
- , (heap', accessor_e, anned_e') - eta heap (var
x') in_e_def (annedTerm (annedTag (snd in_e_def)) (Var x'))]
+ , res - eta [] heap (var x') in_e_def (annedTerm
(annedTag (snd in_e_def)) (Var x'))]
-- When doing memocache preinitialization, we don't want to include in
the final heap any binding originating
-- from evaluating the top-level that cannot be proven to be a value,
or else we risk work duplication
@@ -418,9 +418,9 @@ prepareTerm unfoldings e = {-# SCC prepareTerm #-}
preinit_heap = Heap (preinit_h_avail `M.union` h_fvs) ids'
-- NB: we assume that unfoldings are guaranteed to be cheap and hence
duplicatiable. I think this is reasonable.
-preinit_with = [(gc (normalise (maxBound, heap', Loco False,
anned_e')), accessor_e)
+preinit_with = [ res
| (x', in_e_def) - h_unfoldings
- , (heap', accessor_e, anned_e') - eta preinit_heap
(var x') in_e_def (annedTerm (annedTag (snd in_e_def)) (Var x'))]
+ , res - eta [] preinit_heap (var x') in_e_def
(annedTerm (annedTag (snd in_e_def)) (Var x'))]
-- FIXME: instead of adding unfoldings as Let, (in order to sidestep
the bug where Let stuff will be underspecialised)
-- we should add it them as normal bindings but pre-initialise the
memo cache. Of course this will be bad in the case
@@ -455,22 +455,28 @@ prepareTerm unfoldings e = {-# SCC prepareTerm #-}
--
-- NB: given an unfolding (f = \x y - e) will return memo entries for all the
states (\x y - e), (\y - e), e, f, (f x) and (f x y).
-- Because we do not reduce before matching, both are necessary!
-eta :: Heap - FVedTerm - In AnnedTerm - AnnedTerm - [(Heap, FVedTerm, In
AnnedTerm)]
-eta heap tieback_e1 in_e_def e_call = (heap, tieback_e1, in_e_def) : (heap,
tieback_e1, renamedTerm e_call) : case normalise (maxBound, heap, Loco False,
in_e_def) of
- (_, Heap h ids, k, anned_qa)
-| Answer (rn, v) - extract anned_qa
-, Just a_cast - isCastStack_maybe k
-, let tieback_e2 = case a_cast of
-Uncast - tieback_e1
-CastBy co _ - tieback_e1 `cast` mkSymCo ids co
- mb_res@(~(Just (_, x, _, _))) = case v of
- Lambda x e_def_body - Just (tieback_e2 `app` x',
x, e_def_body, annedTerm (annedTag e_def_body) (e_call `App` x'))
- TyLambda a e_def_body - Just (tieback_e2 `tyApp` mkTyVarTy x',
a, e_def_body, annedTerm (annedTag e_def_body) (e_call `TyApp` mkTyVarTy x'))
- _ - Nothing
- (ids', rn', x') = renameNonRecBinder ids rn x
-, Just (tieback_e2, _, e_def_body, e_call_body) - mb_res
-- eta (Heap (M.insert x' lambdaBound h) ids') tieback_e2 (rn',
e_def_body) e_call_body
- _ - []
+eta :: [Var] - Heap - FVedTerm - In AnnedTerm - AnnedTerm - [(State,
FVedTerm)]
+eta xs' heap tieback_e1 in_e_def e_call1 = res in_e_def
[commit: ghc] supercompiler: Fix newtype unfoldings (coercion direction) and prevent data unfoldings with strange tyvar kinds (d54e4c5)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/d54e4c5e73caadb53fe53b5e7a4a71579476746b --- commit d54e4c5e73caadb53fe53b5e7a4a71579476746b Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Oct 23 17:56:26 2012 +0100 Fix newtype unfoldings (coercion direction) and prevent data unfoldings with strange tyvar kinds --- compiler/supercompile/Supercompile.hs | 11 +++ compiler/supercompile/Supercompile/Core/Syntax.hs | 20 compiler/supercompile/Supercompile/Drive/MSG.hs | 19 --- 3 files changed, 27 insertions(+), 23 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index 573c308..e577c62 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -30,9 +30,10 @@ import CoreSyn import CoreFVs(exprFreeVars) import CoreUtils (exprType) import MkCore (mkWildValBinder) -import Coercion (isCoVar, mkCoVarCo, mkAxInstCo) +import Coercion (isCoVar, mkCoVarCo, mkAxInstCo, mkSymCo) import DataCon(dataConAllTyVars, dataConRepArgTys, dataConTyCon, dataConWorkId) import VarSet +import Var(tyVarKind) import Id import MkId (realWorldPrimId) import FastString (fsLit) @@ -175,7 +176,7 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] [] -- which can literall never be used. varUnfolding x | Just pop - isPrimOpId_maybe x = Right $ primOpUnfolding pop - | Just dc - isDataConWorkId_maybe x = Right $ dataUnfolding dc + | Just dc - isDataConWorkId_maybe x = dataUnfolding dc | otherwise = case S.shouldExposeUnfolding x of Left why_not - Left why_not Right super - case realIdUnfolding x of @@ -194,9 +195,11 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] [] dataUnfolding dc | Just co_axiom - newTyConCo_maybe (dataConTyCon dc) , let [x] = xs - = S.tyLambdas as $ S.lambdas [x] $ S.var x `S.cast` mkAxInstCo co_axiom (map mkTyVarTy as) + = Right $ S.tyLambdas as $ S.lambdas [x] $ S.var x `S.cast` mkSymCo (mkAxInstCo co_axiom (map mkTyVarTy as)) -- Axiom LHS = TyCon, RHS = Rep Type + | any (not . S.canAbstractOverTyVarOfKind . tyVarKind) as + = Left some type variable which we cannot abstract over | otherwise - = S.tyLambdas as $ S.lambdas xs $ S.value (S.Data dc (map mkTyVarTy as) (map mkCoVarCo qs) ys) + = Right $ S.tyLambdas as $ S.lambdas xs $ S.value (S.Data dc (map mkTyVarTy as) (map mkCoVarCo qs) ys) where as = dataConAllTyVars dc arg_tys = dataConRepArgTys dc xs = zipWith (mkSysLocal (fsLit x)) bv_uniques arg_tys diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index 1bc8fcb..f818383 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -272,6 +272,26 @@ mkTransCastBy _ cast_by1 Uncast = cast_by1 mkTransCastBy ids (CastBy co1 _tg1) (CastBy co2 tg2) = castBy (mkTransCo ids co1 co2) tg2 +canAbstractOverTyVarOfKind :: Kind - Bool +canAbstractOverTyVarOfKind = ok + where +-- TODO: I'm not 100% sure of the correctness of this check +-- In particular, I don't think we need to check for non-conforming +-- kinds in negative positions since they would only appear if the +-- definition site had erroneously abstracted over a non-conforming +-- kind. For example, this *should* never be allowed: +-- data Foo (a :: * - #) = Bar (a Int) +-- Foo :: (* - #) - * +-- Bar :: forall (a :: * - #). a Int - Foo a +ok k | isOpenTypeKind k || isUbxTupleKind k || isArgTypeKind k || isUnliftedTypeKind k = False +ok (TyVarTy _) = True -- This is OK because kinds dont get generalised, and we assume all incoming kind instantiations satisfy the kind invariant +ok (AppTy k1 k2) = ok k1 ok k2 +ok (TyConApp _ ks) = all ok ks +ok (FunTy k1 k2) = ok k1 ok k2 +ok (ForAllTy _ k) = ok k +ok (LitTy _) = True + + valueType :: Copointed ann = ValueF ann - Type valueType (TyLambda a e) = mkForAllTy a (termType e) valueType (Lambda x e)= idType x `mkFunTy` termType e diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 935d48f..57e4d60 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -828,25 +828,6 @@ msgCoerced _ _ _ _ _ _ = fail msgCoerced msgKind :: RnEnv2 - Kind - Kind - MSG Kind msgKind = msgType -canAbstractOverTyVarOfKind :: Kind - Bool -canAbstractOverTyVarOfKind
[commit: ghc] supercompiler: Fix mkSymCo so it actually creates a symmetric coercion (cfa06bc)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/cfa06bc2a3ea558f0b5eb7636f5fe29ca809542d --- commit cfa06bc2a3ea558f0b5eb7636f5fe29ca809542d Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Oct 23 17:59:58 2012 +0100 Fix mkSymCo so it actually creates a symmetric coercion --- compiler/supercompile/Supercompile/Core/Syntax.hs |5 - 1 files changed, 4 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index f818383..2084c31 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -20,14 +20,17 @@ import Id (Id, isId, idType, idInlinePragma) import PrimOp (primOpType) import Literal (Literal, literalType) import Type (Type, mkTyVarTy, applyTy, applyTys, mkForAllTy, mkFunTy, splitFunTy_maybe, eqType) +import TypeRep (Type(..)) +import Kind import Coercion (CoVar, Coercion, coercionType, coercionKind, mkCvSubst, mkAxInstCo, mkReflCo, isReflCo) +import qualified Coercion as Coercion import PrimOp (PrimOp) import Pair (pSnd) import PprCore () mkSymCo :: InScopeSet - NormalCo - NormalCo -mkSymCo iss co = optCoercion (mkCvSubst iss []) co +mkSymCo iss co = optCoercion (mkCvSubst iss []) (Coercion.mkSymCo co) mkTransCo :: InScopeSet - NormalCo - NormalCo - NormalCo mkTransCo = opt_trans ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Weaken the bugcheck for typegen tieback memo (680f931)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/680f9313ab06eb12f21d7c46d7612d88dfd8b31d
---
commit 680f9313ab06eb12f21d7c46d7612d88dfd8b31d
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Tue Oct 23 18:00:46 2012 +0100
Weaken the bugcheck for typegen tieback memo
---
.../supercompile/Supercompile/Drive/Process3.hs|9 ++---
1 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs
b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 1b2bec9..e23b919 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -661,7 +661,7 @@ memo opt init_state = {-# SCC memo' #-} memo_opt
init_state
-- This means that we preferred to roll back to something
which gives an MSG with the *smallest possible* renaming (i.e. is more
specific).
-- This is the opposite of what I've implemented below
(FIXME).
-- TODO: maybe it actually would be OK (for SC
termination) to roll back to h0 at (*)? Though it would mean dumping any
tiebacks to h2 unnecessarily.
-moreSpecific (RightGivesTypeGen _ _ _rn_l)
(RightGivesTypeGen _ _ _rn_r)
+moreSpecific (RightGivesTypeGen _ _s_l rn_l)
(RightGivesTypeGen _ _s_r rn_r)
-- OK, here is what I have concluded after long thought.
-- As long as we DON'T CREATE A PROMISE when type
generalising, then there will be a always be a maximum of one
-- possible type generalisation. A simple example
demonstrates the principal behind this. Imagine that there were two
@@ -678,12 +678,15 @@ memo opt init_state = {-# SCC memo' #-} memo_opt
init_state
-- type generalise it against the earlier promise (i.e.
f Int Char) and hence would have driven (f alpha beta) without
-- recording (f Float Bool). Now when we come to
supercompile (f Int Bool) we can just tie back to (f alpha beta),
-- which is absolutely what we want.
- = error moreSpecific: two possible type gens, this
should not happen! -- renamingSize rn_r = renamingSize rn_l
+ | pREINITALIZE_MEMO_TABLE
+ = renamingSize rn_r = renamingSize rn_l -- NB: although
the argument above *is* true, we can have two type-genable promises due to
memoiser preinit!
+ | otherwise
+ = pprPanic moreSpecific: two possible type gens, this
should not happen! (ppr rn_l $$ ppr rn_r $$ pPrintFullState
quietStatePrettiness _s_l $$ pPrintFullState quietStatePrettiness _s_r)
-- Prefer instance matches to type generalisation (don't
have a good sense about what is best here):
moreSpecific (RightIsInstance _ _ _) _ = True
moreSpecific _ (RightIsInstance _ _ _) = False
---renamingSize (_, tv_subst, co_subst) = sumMap typeSize
(varEnvElts tv_subst) + sumMap coercionSize (varEnvElts co_subst)
+renamingSize (_, tv_subst, co_subst) = sumMap typeSize
(varEnvElts tv_subst) + sumMap coercionSize (varEnvElts co_subst)
-- TODO: it might be OK to insist the incoming renaming is
invertible, but this should definitely work:
isEmptyRenaming (_, tv_subst, co_subst) = all isTyVarTy
(varEnvElts tv_subst) all isCoVarCo (varEnvElts co_subst)
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix critical bug in msg where we weren't sucking enough (deee68a)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/deee68af1448bcfb41bd4d73d820b549d07e5d75
---
commit deee68af1448bcfb41bd4d73d820b549d07e5d75
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Oct 24 18:44:28 2012 +0100
Fix critical bug in msg where we weren't sucking enough
---
compiler/supercompile/Supercompile/Drive/MSG.hs | 11 ---
1 files changed, 8 insertions(+), 3 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs
b/compiler/supercompile/Supercompile/Drive/MSG.hs
index 57e4d60..e957ecf 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -12,6 +12,7 @@ import Supercompile.Core.Syntax
import Supercompile.Evaluator.Deeds
import Supercompile.Evaluator.FreeVars
import Supercompile.Evaluator.Syntax
+import Supercompile.Evaluator.Residualise
--import qualified Supercompile.GHC as GHC
import Supercompile.Utilities hiding (guard)
@@ -702,7 +703,11 @@ isTypeRenamingNonTrivial :: Renaming - FreeVars - Bool
isTypeRenamingNonTrivial rn fvs = (\f - foldVarSet f False fvs) $ \x rest -
(isTyVar x isNothing (getTyVar_maybe (lookupTyVarSubst rn x))) || rest
msg :: MSGMode - State - State - MSG' MSGResult
-msg = {- pprTrace examples (example1 $$ example2) -} msg'
+msg mm state_l state_r = {- pprTrace examples (example1 $$ example2) -}
+ --(if isEmptyVarSet (stateUncoveredVars state_l) then
id else pprPanic msgl (pPrintFullState fullStatePrettiness state_l $$ ppr
(stateUncoveredVars state_l))) $
+ --(if isEmptyVarSet (stateUncoveredVars state_r) then
id else pprPanic msgr (pPrintFullState fullStatePrettiness state_r $$ ppr
(stateUncoveredVars state_r))) $
+ --(\res - case res of Left _ - res; Right (Pair l
r, common) - let xs = stateFreeVars common; f (_, Heap h _, rn, k) x = let off
= mkVarSet (map (renameId rn) (varSetElems xs)) in if off `subVarSet`
(dataSetToVarSet (M.keysSet h) `unionVarSet` stackBoundVars k) then x else
pprPanic fff (ppr off) in f l $ f r $ res) $
+ msg' mm state_l state_r
msg' mm (deeds_l, heap_l, k_l, qa_l) (deeds_r, heap_r, k_r, qa_r) = -- (\res
- traceRender (msg, M.keysSet h_l, residualiseDriveState (Heap h_l
prettyIdSupply, k_l, in_e_l), M.keysSet h_r, residualiseDriveState (Heap h_r
prettyIdSupply, k_r, in_e_r), res) res) $
liftM (first (liftA2 (\deeds (heap, rn, k) - (deeds, heap, rn, k)) (Pair
deeds_l deeds_r))) $ msgLoop mm (heap_l, heap_r) (qa_l, qa_r) (k_l, k_r)
@@ -1191,7 +1196,7 @@ suck :: (Pair MSGLRState - MSGLRState) - Var - MSGU ()
suck sel x = join $ suck' sel x
suck' :: (Pair MSGLRState - MSGLRState) - Var - MSGU (MSGU ())
-suck' sel x = {- trace (suck': ++ show x) $ -} flip fmap get $ \s -
lookupWithDefaultVarEnv (msgLRSuckVar (sel (msgLR s))) (return ()) x
+suck' sel x = {- trace (suck': ++ show x) $ -} flip fmap get $ \s -
lookupWithDefaultVarEnv (msgLRSuckVar (sel (msgLR s))) (return ()) x -- NB:
don't panic here if lookup fails because we might just have removed the var
from the mapping
suckStack :: Int - MSGU ()
suckStack i = {- trace (suckStack: ++ show i) $ -} join $ flip fmap get $ \s
- IM.findWithDefault (return ()) i (msgSuckStack s)
@@ -1271,7 +1276,7 @@ msgLoop mm (Heap init_h_l init_ids_l, Heap init_h_r
init_ids_r) (qa_l, qa_r) (in
modify_ $ \s - s { msgLR = mdfy_lr (msgLR s) $ \s_lr -
s_lr { msgLRHeap = M.insert x_lr hb_lr (msgLRHeap s_lr)
, msgLRSuckVar = msgLRSuckVar s_lr `delVarEnv` x_lr
, msgLRAvailableHeap = if heapBindingCheap hb_lr then msgLRAvailableHeap
s_lr else M.delete x_lr (msgLRAvailableHeap s_lr) } }
- sucks xtrct_lr (heapBindingFreeVars hb_lr)
+ sucks xtrct_lr (varBndrFreeVars x_lr `unionVarSet`
heapBindingFreeVars hb_lr)
{-
-- NB: I can try to avoid generalisation when e_l or e_r is just a
heap-bound variable. We do this by floating the non-variable into a new heap
binding
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Comments only (a8a1f39)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/a8a1f396f8c9c88240e34a9ab79bdea5b0110769
---
commit a8a1f396f8c9c88240e34a9ab79bdea5b0110769
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Oct 24 18:44:57 2012 +0100
Comments only
---
.../supercompile/Supercompile/Drive/Process3.hs|7 ---
1 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs
b/compiler/supercompile/Supercompile/Drive/Process3.hs
index e23b919..53bd689 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -342,9 +342,9 @@ tryMSG opt = bothWays $ \shallow_state state - do
pprMSGResult :: MSGResult - SDoc
pprMSGResult (Pair (deeds_l, heap_l, rn_l, k_l) (deeds_r, heap_r, rn_r, k_r),
(heap, k, qa))
- = pPrintFullState quietStatePrettiness (emptyDeeds, heap, k, qa) $$
-ppr rn_l $$ pPrintFullState quietStatePrettiness (deeds_l, heap_l, k_l,
fmap Question (annedVar (mkTag 0) nullAddrId)) $$
-ppr rn_r $$ pPrintFullState quietStatePrettiness (deeds_r, heap_r, k_r,
fmap Question (annedVar (mkTag 0) nullAddrId))
+ = {- ppr (case heap of Heap h _ - M.keysSet h) $$ -} pPrintFullState
quietStatePrettiness (emptyDeeds, heap, k, qa) $$
+{- ppr (case heap_l of Heap h_l _ - M.keysSet h_l) $$ -} ppr rn_l $$
pPrintFullState quietStatePrettiness (deeds_l, heap_l, k_l, fmap Question
(annedVar (mkTag 0) nullAddrId)) $$
+{- ppr (case heap_r of Heap h_r _ - M.keysSet h_r) $$ -} ppr rn_r $$
pPrintFullState quietStatePrettiness (deeds_r, heap_r, k_r, fmap Question
(annedVar (mkTag 0) nullAddrId))
renameSCResult :: InScopeSet - In FVedTerm - ScpM (PureHeap, FVedTerm)
renameSCResult ids (rn_r, e) = do
@@ -772,6 +772,7 @@ preinitalise states_fulfils
| not pREINITALIZE_MEMO_TABLE = return () -- If you do this, expect your
output code to grow a lot!
| otherwise = forM_ states_fulfils $ \(state, e') - do
ScpM $ StateT $ \s - do
+--unless (isEmptyVarSet (stateUncoveredVars state)) $ pprPanic
preinitalise (pPrintFullState fullStatePrettiness state $$ ppr e')
let (ms', _p) = promise (scpMemoState s) (state, snd (reduceForMatch
state))
return ((), s { scpMemoState = ms' })
fulfillM (emptyDeeds, e')
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Mark module SUPERINLINABLE by default (otherwise SC is almost an identity transformation) (5c058a0)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/5c058a0fe6364c874ee071c912a3f1a61014a2da --- commit 5c058a0fe6364c874ee071c912a3f1a61014a2da Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Oct 24 18:43:36 2012 +0100 Mark module SUPERINLINABLE by default (otherwise SC is almost an identity transformation) --- compiler/supercompile/Supercompile.hs |3 ++- compiler/supercompile/Supercompile/StaticFlags.hs |3 +++ 2 files changed, 5 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index e577c62..2d416f4 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -17,6 +17,7 @@ module Supercompile (supercompileProgram, supercompileProgramSelective) where -- Probably can't/shouldn't do this if the wildcard binder y is used in the RHS. import Supercompile.GHC +import Supercompile.StaticFlags import Supercompile.Utilities import qualified Supercompile.Core.Syntax as S import qualified Supercompile.Core.FreeVars as S @@ -263,7 +264,7 @@ supercompile e = -- liftM (termToCoreExpr . snd) $ where unfs = termUnfoldings e' -- NB: ensure we mark any child bindings of bindings marked SUPERINLINABLE in *this module* as SUPERINLINABLE, -- just like we would if we imported a SUPERINLINABLE binding -e' = superinlinableLexically False $ runParseM anfUniqSupply' $ coreExprToTerm e +e' = superinlinableLexically mODULE_SUPERINLINABLE $ runParseM anfUniqSupply' $ coreExprToTerm e supercompileProgram :: [CoreBind] - IO [CoreBind] supercompileProgram binds = supercompileProgramSelective selector binds diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs index 7e973db..8e6d3c2 100644 --- a/compiler/supercompile/Supercompile/StaticFlags.hs +++ b/compiler/supercompile/Supercompile/StaticFlags.hs @@ -161,6 +161,9 @@ pOSITIVE_INFORMATION = lookUp $ fsLit -fsupercompiler-positive-information pREINITALIZE_MEMO_TABLE :: Bool pREINITALIZE_MEMO_TABLE = not $ lookUp $ fsLit -fsupercompiler-no-preinitalize +mODULE_SUPERINLINABLE :: Bool +mODULE_SUPERINLINABLE = not $ lookUp $ fsLit -fsupercompiler-no-module-superinlinable + -- FIXME: turning this off is actually broken right now uSE_LET_BINDINGS :: Bool uSE_LET_BINDINGS = not $ lookUp $ fsLit -fsupercompiler-no-let-bindings ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Comment only (26edd7d)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/26edd7d1271a72f6e814e501cc93404a90d018bc --- commit 26edd7d1271a72f6e814e501cc93404a90d018bc Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Nov 1 17:35:14 2012 + Comment only --- compiler/supercompile/Supercompile/Drive/Split2.hs |1 + 1 files changed, 1 insertions(+), 0 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs b/compiler/supercompile/Supercompile/Drive/Split2.hs index 336882c..e529f22 100644 --- a/compiler/supercompile/Supercompile/Drive/Split2.hs +++ b/compiler/supercompile/Supercompile/Drive/Split2.hs @@ -489,6 +489,7 @@ type PushedValue = Tagged (Coerced (ValueG State)) type PushedQA= Tagged (QAG (ValueG State)) type PushedFocus = PushFocus PushedQA State +-- NB: it is not necessary for the traversal order here to match that in recurse, even when doing FCFS traversePushedState :: Applicative t = (State - t State) - (PushedHeap, PushedStack, PushedFocus) - t (PushedHeap, PushedStack, PushedFocus) traversePushedState f (heap, stack, focus) = liftA3 (,,) (traversePushedHeap f heap) (traversePushedStack f stack) (traversePushedFocus f focus) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Checkpoint deeds in splitter (8900089)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/89000899821ac43616eb11792adafeef3883fabd
---
commit 89000899821ac43616eb11792adafeef3883fabd
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Oct 31 11:25:36 2012 +
Checkpoint deeds in splitter
---
compiler/supercompile/Supercompile/Core/Syntax.hs |8 +++
compiler/supercompile/Supercompile/Drive/Split2.hs | 53 +--
.../supercompile/Supercompile/Evaluator/Syntax.hs |4 ++
3 files changed, 59 insertions(+), 6 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs
b/compiler/supercompile/Supercompile/Core/Syntax.hs
index 2084c31..73b2087 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -152,6 +152,14 @@ data ValueG term = Literal Literal | Coercion Coercion
| Data DataCon [Type] [Coercion] [Id] -- NB: includes
universal and existential type arguments, in that order
-- NB: not a newtype
DataCon
+instance Traverseable ValueG where
+traverse f e = case e of
+ Literal l - pure $ Literal l
+ Coercion co- pure $ Coercion co
+ TyLambda a e - fmap (TyLambda a) $ f e
+ Lambda x e - fmap (Lambda x) $ f e
+ Data dc tys cos xs - pure $ Data dc tys cos xs
+
instance Outputable AltCon where
pprPrec prec altcon = case altcon of
DataAlt dc as qs xs - prettyParen (prec = appPrec) $ ppr dc + hsep
(map (pPrintBndr CaseBind) as ++ map (pPrintBndr CaseBind) qs ++ map
(pPrintBndr CaseBind) xs)
diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs
b/compiler/supercompile/Supercompile/Drive/Split2.hs
index 7a9041b..721eb6a 100644
--- a/compiler/supercompile/Supercompile/Drive/Split2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split2.hs
@@ -242,12 +242,12 @@ multEntered = M.unionWith (\_ _ - ManyEntries)
split :: (Applicative m, Monad m)
= (State - m(Deeds, Out FVedTerm))
- State - m (ResidTags, Deeds, Out FVedTerm)
-split opt (_deeds, heap, k, qa) = recurse opt $ push (S.singleton
FocusContext) (heap, k, QAFocus qa)
+split opt (deeds, heap, k, qa) = recurse opt $ push (S.singleton FocusContext)
(deeds, heap, k, QAFocus qa)
instanceSplit :: (Applicative m, Monad m)
= (State - m(Deeds,
Out FVedTerm))
- (Deeds, Heap, Stack, Out FVedTerm) - m (ResidTags, Deeds,
Out FVedTerm)
-instanceSplit opt (_deeds, heap, k, e) = recurse opt $ push (S.singleton
FocusContext) (heap, k, OpaqueFocus e)
+instanceSplit opt (deeds, heap, k, e) = recurse opt $ push (S.singleton
FocusContext) (deeds, heap, k, OpaqueFocus e)
applyGeneraliser :: Generaliser - State - Maybe (S.Set Context)
applyGeneraliser gen (_deeds, Heap h _, k, qa) = fmap (\(gen_kfs, gen_xs) -
S.fromList $ map StackContext (IS.elems gen_kfs) ++ map HeapContext
(varSetElems gen_xs)) $ case gENERALISATION of
@@ -287,7 +287,7 @@ applyGeneraliser gen (_deeds, Heap h _, k, qa) = fmap
(\(gen_kfs, gen_xs) - S.f
generaliseSplit :: (Applicative m, Monad m)
= (State - m (Deeds, Out FVedTerm))
- Generaliser - State - Maybe (m (ResidTags, Deeds, Out
FVedTerm))
-generaliseSplit opt gen state@(_deeds, heap, k, qa) = flip fmap
(applyGeneraliser gen state) $ \generalised - recurse opt $ push generalised
(heap, k, QAFocus qa)
+generaliseSplit opt gen state@(deeds, heap, k, qa) = flip fmap
(applyGeneraliser gen state) $ \generalised - recurse opt $ push generalised
(deeds, heap, k, QAFocus qa)
recurse :: (Applicative m, Monad m)
@@ -449,6 +449,23 @@ test11 = \_ - f () + 1
-}
+newtype DeedsA a = DeedsA { unDeedsA :: (Deeds, [Size], State [Deeds] a) }
+
+instance Functor DeedsA where
+fmap = liftA
+
+instance Applicative DeedsA where
+pure x = DeedsA (emptyDeeds, [], return x)
+DeedsA (deeds1, sizes1, mf) * DeedsA (deeds2, sizes2, mx) = DeedsA
(deeds1 `mappend` deeds, sizes1 ++ sizes2, mf * mx)
+
+one :: Deeds - Size - DeedsA Deeds
+one deeds sz = DeedsA (deeds, [sz], state $ \(deeds:deedss) - (deeds, deedss))
+
+runDeedsA :: DeedsA a - a
+runDeedsA (DeedsA (deeds, sizes, mx)) = x
+ where ([], x) = runState mx (splitDeeds deeds sizes)
+
+
data PushFocus qa term = QAFocus qa
| TermFocus term
| OpaqueFocus FVedTerm
@@ -460,12 +477,36 @@ type PushedValue = Tagged (Coerced (ValueG State))
type PushedQA= Tagged (QAG (ValueG State))
type PushedFocus = PushFocus PushedQA State
+traversePushedState :: Applicative t = (State - t State)
+- (PushedHeap, PushedStack, PushedFocus) - t
(PushedHeap, PushedStack
[commit: ghc] supercompiler: Trace upon rollback (8bb16db)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/8bb16db29609438805c6e541cc3942fc3cd882ee
---
commit 8bb16db29609438805c6e541cc3942fc3cd882ee
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Nov 14 15:14:59 2012 +
Trace upon rollback
---
.../supercompile/Supercompile/Drive/Process3.hs|2 +-
1 files changed, 1 insertions(+), 1 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs
b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 53bd689..1331952 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -271,7 +271,7 @@ terminateM :: String - State - (forall b. RollbackState
- ScpM b) - ScpM a -
terminateM h state rb mcont mstop = ScpM $ StateT $ \s - ReaderT $ \env -
case ({-# SCC terminate #-} terminate (if hISTORY_TREE then
scpProcessHistoryEnv env else scpProcessHistoryState s) (scpNodeKey env, (h,
state, rb))) of
Stop (_, (shallow_h, shallow_state, shallow_rb))
- trace (stops: ++ show (scpStopCount env)) $
- unReaderT (unStateT (unScpM (mstop shallow_h shallow_state
shallow_rb)) s) (env { scpStopCount =
scpStopCount env + 1})
+ unReaderT (unStateT (unScpM (mstop shallow_h shallow_state (\x -
trace (back to ++ show shallow_h) (shallow_rb x s)
(env { scpStopCount = scpStopCount env + 1})
Continue hist'
- unReaderT (unStateT (unScpM mcont)
(s { scpProcessHistoryState = hist' })) (env { scpNodeKey = generatedKey
hist', scpProcessHistoryEnv = hist' })
-- TODO: record the names of the h-functions on the way to the current one
instead of a Int depth
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Small tweaks including turning on positive info by default (6bdefd8)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6bdefd8d7b17bb61980e39f31656c6ce18e93876 --- commit 6bdefd8d7b17bb61980e39f31656c6ce18e93876 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Nov 15 11:12:40 2012 + Small tweaks including turning on positive info by default compiler/supercompile/Supercompile.hs | 46 --- compiler/supercompile/Supercompile/Core/Syntax.hs | 24 ++- .../supercompile/Supercompile/Drive/Process.hs | 18 +--- .../supercompile/Supercompile/Drive/Process3.hs| 29 ++--- .../Supercompile/Evaluator/Evaluate.hs |6 +++ compiler/supercompile/Supercompile/StaticFlags.hs |2 +- 6 files changed, 92 insertions(+), 33 deletions(-) Diff suppressed because of size. To see it, use: git show 6bdefd8d7b17bb61980e39f31656c6ce18e93876 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix a small but critcal error in MSG (6d30d1c)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6d30d1c064f8220b18c629bbba84e204458e9acc --- commit 6d30d1c064f8220b18c629bbba84e204458e9acc Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Oct 31 11:24:48 2012 + Fix a small but critcal error in MSG compiler/supercompile/Supercompile/Drive/MSG.hs | 60 ++- 1 files changed, 37 insertions(+), 23 deletions(-) Diff suppressed because of size. To see it, use: git show 6d30d1c064f8220b18c629bbba84e204458e9acc ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Make the speculation flag work properly (f2b4a3f)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/f2b4a3f7bfbbb51d927b61ec7251ba387132e385 --- commit f2b4a3f7bfbbb51d927b61ec7251ba387132e385 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Nov 16 14:10:56 2012 + Make the speculation flag work properly --- .../supercompile/Supercompile/Drive/Process.hs |3 ++- .../supercompile/Supercompile/Drive/Process1.hs|2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index 5f9dcbd..c7727b0 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -696,7 +696,8 @@ nothingSpeculated = S.empty -- FIXME: if I speculate roughly in dependency order then GHCs inlining heuristics will have more information -- to work with in the reduce invocations speculate :: AlreadySpeculated - (SCStats, State) - (AlreadySpeculated, (SCStats, State)) -speculate speculated (stats, (deeds, heap, k, in_e)) = (speculated', (stats', (deeds', heap', k, in_e))) +speculate speculated (stats, state) | not sPECULATION = (speculated, (stats, state)) +speculate speculated (stats, (deeds, heap, k, in_e)) = (speculated', (stats', (deeds', heap', k, in_e))) where (speculated', (stats', deeds', heap')) = speculateHeap speculated (stats, deeds, heap) --type SpecRB = SpecHistory - SpecM (SpecHistory, Deeds, Heap) diff --git a/compiler/supercompile/Supercompile/Drive/Process1.hs b/compiler/supercompile/Supercompile/Drive/Process1.hs index 09cb6b2..323b0ae 100644 --- a/compiler/supercompile/Supercompile/Drive/Process1.hs +++ b/compiler/supercompile/Supercompile/Drive/Process1.hs @@ -454,7 +454,7 @@ sc' hist speculated state = handlePrint $ (\raise - check raise) `catchScpM` \g continue hist = do traceRenderScpM reduce end (continue) (PrettyDoc (pPrintFullState quietStatePrettiness state')) addStats stats liftM (\(_, deeds, e') - (deeds, e')) $ split state' (liftPB . sc hist speculated') - where (speculated', (stats, state')) = (if sPECULATION then speculate speculated else ((,) speculated)) $ reduceWithStats state -- TODO: experiment with doing admissability-generalisation on reduced terms. My suspicion is that it won't help, though (such terms are already stuck or non-stuck but loopy: throwing stuff away does not necessarily remove loopiness). + where (speculated', (stats, state')) = speculate speculated $ reduceWithStats state -- TODO: experiment with doing admissability-generalisation on reduced terms. My suspicion is that it won't help, though (such terms are already stuck or non-stuck but loopy: throwing stuff away does not necessarily remove loopiness). memo :: (AlreadySpeculated - State - ScpBM (Deeds, Out FVedTerm)) - AlreadySpeculated - State - ScpPM (Deeds, Out FVedTerm) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] branch 'supercompiler' created
Repository : ssh://darcs.haskell.org//srv/darcs/nofib New branch : supercompiler Referencing: 270c8d8ae5c349c7c2fe35d861346c5c77535a91 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Ignore common OS junk (d77043e)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/d77043e57f3c2a6e738df300b4e8aab1757a0a0b --- commit d77043e57f3c2a6e738df300b4e8aab1757a0a0b Author: Max Bolingbroke batterseapo...@hotmail.com Date: Sun Mar 11 20:08:06 2012 + Ignore common OS junk --- .gitignore |4 1 files changed, 4 insertions(+), 0 deletions(-) diff --git a/.gitignore b/.gitignore index 694c606..34a69a4 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,7 @@ +# OS junk +Thumbs.db +.DS_Store + # Generated file patterns *.o *.hi ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Allow MSG to generalise occurrence info (5ff6887)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/5ff68875f73bd52faa3fe94631aab4cb2c05a70b
---
commit 5ff68875f73bd52faa3fe94631aab4cb2c05a70b
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Nov 16 14:11:36 2012 +
Allow MSG to generalise occurrence info
---
.../supercompile/Supercompile/Drive/Process3.hs| 44 +--
1 files changed, 39 insertions(+), 5 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs
b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 2a902bb..7ceef75 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -287,7 +287,7 @@ sc' :: Maybe String - State - ScpM (Bool, (Deeds,
FVedTerm)) -- Bool records w
sc' mb_h state = {- pprTrace sc' (trce1 state) $ -} {-# SCC sc' #-} case
mb_h of
Nothing - speculateM (reduce state) $ \state - -- traceRenderM !sc
(PrettyDoc (pPrintFullState quietStatePrettiness state))
my_split state
- Just h - flip catchM try_generalise $ \rb -
+ Just h - flip catchM my_generalise $ \rb -
terminateM h state rb
(speculateM (reduce state) $ \state - my_split state)
(\shallow_h shallow_state shallow_rb - trce shallow_h
shallow_state $ do
@@ -296,11 +296,9 @@ sc' mb_h state = {- pprTrace sc' (trce1 state) $ -} {-#
SCC sc' #-} case mb_
case mb_shallow_gen
of
Just shallow_gen
| sC_ROLLBACK - trace sc-stop(rb,gen) $ shallow_rb shallow_gen
Nothing |
sC_ROLLBACK, Nothing - mb_gen - trace sc-stop(rb,split) $ shallow_rb (split
sc shallow_state)
- _ - case mb_gen
of Just gen - trace sc-stop(gen) $ try_generalise gen
-
Nothing - trace sc-stop(split)$ try_generalise (split sc
state))
+ _ - case mb_gen
of Just gen - trace sc-stop(gen) $ my_generalise gen
+
Nothing - trace sc-stop(split)$ my_generalise (split sc
state))
where
-try_generalise gen = my_generalise gen
-
-- FIXME: the could have tied back case is reachable (e.g. exp3_8 with
unfoldings as internal bindings), and it doesn't appear to be
-- because of dumped promises (no dumped in output). I'm reasonably sure
this should not happen :(
trce shallow_h shallow_state = pprTraceSC (Embedding: ++ shallow_h)
@@ -325,6 +323,41 @@ tryTaG opt shallow_state state = bothWays (\_ -
generaliseSplit opt gen) shallo
where gen = mK_GENERALISER shallow_state state
-- NB: this cannot return (Just, Nothing)
+tryMSG opt shallow_state state = case msgMaybe mode shallow_state state of
+-- If we fail this way round, we should certainly fail the other way round
too
+Nothing - (Nothing, Nothing)
+Just msg_result@(Pair l r, _)
+ | let Just msg_result_sym = msgMaybe mode state shallow_state -- Will
certainly succeed, but with tags of shallow_state
+ - pprTrace MSG success (pprMSGResult msg_result) $ -- NB: pretty
print MSG the correct way around even if we roll back
+ case (trivialMSG l, trivialMSG r) of
+ -- Both trivial: we have certainly discovered a variable
generalisation (not an instance match, or we would have tied back)
+ -- Perhaps ideally we would just SC our deep state normally, but
that is awkward. Instead we will rollback and generalise,
+ -- but it might be unsafe to generalise without rolling back (we
might not be throwing any info away)
+ (True, True) - (Just (genFrom msg_result_sym), Nothing)
+ -- Trivial on the LHS only: probably an instance match. Unsafe to
roll back because we might not throw any info away.
+ (True, False) - (Nothing, Just (genFrom
msg_result))
+ -- Trivial on the RHS only: kind of weird. Perhaps ideally we would
just reduce+split our deep state normally, but it's a bit
+ -- awkward to arrange that. Instead we will accept generalising the
earlier state.
+ (False, True) - (Just (genFrom msg_result_sym), Nothing)
+ -- Non-trivial on both sides: can either rollback or not, doesn't
matter. We throw away info either way.
+ (False, False) - (Just (genFrom msg_result_sym), Just (genFrom
msg_result))
+
+ where
[commit: ghc] supercompiler: Last bug fixes and flag additions. (08e33ed)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/08e33edf20e2274b1266b4809ecea5678014b0a3 --- commit 08e33edf20e2274b1266b4809ecea5678014b0a3 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Dec 6 16:31:49 2012 + Last bug fixes and flag additions. compiler/supercompile/Supercompile/Drive/MSG.hs| 13 +- .../supercompile/Supercompile/Drive/Process.hs |4 +- .../supercompile/Supercompile/Drive/Process3.hs| 23 +-- compiler/supercompile/Supercompile/Drive/Split.hs |2 +- compiler/supercompile/Supercompile/Drive/Split2.hs |2 +- .../Supercompile/Evaluator/Evaluate.hs | 19 +++- compiler/supercompile/Supercompile/GHC.hs |2 +- compiler/supercompile/Supercompile/StaticFlags.hs | 15 ++-- 8 files changed, 62 insertions(+), 18 deletions(-) Diff suppressed because of size. To see it, use: git show 08e33edf20e2274b1266b4809ecea5678014b0a3 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Add module size to nofib output (6f57cbc)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6f57cbc98bd84ecc8addd16923c58b28ac8f0f9d --- commit 6f57cbc98bd84ecc8addd16923c58b28ac8f0f9d Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Nov 15 11:10:14 2012 + Add module size to nofib output --- nofib-analyse/Main.hs | 19 --- nofib-analyse/Slurp.hs |8 +++- 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/nofib-analyse/Main.hs b/nofib-analyse/Main.hs index ed9234b..4e87ac1 100644 --- a/nofib-analyse/Main.hs +++ b/nofib-analyse/Main.hs @@ -27,6 +27,9 @@ import Data.List - -- Top level stuff +mAX_PROG_NAME_LENGTH :: Int +mAX_PROG_NAME_LENGTH = 20 + die :: String - IO a die s = hPutStr stderr s exitWith (ExitFailure 1) @@ -114,12 +117,13 @@ data PerModuleTableSpec = (a - Bool) -- Result within reasonable limits? -- The various per-program aspects of execution that we can generate results for. -size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, +size_spec, modsize_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec, gcelap_spec, gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec, gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec, balance_spec, totmem_spec :: PerProgTableSpec size_spec= SpecP Binary Sizes Size binary-sizes binary_size compile_status always_ok +modsize_spec = SpecP Module Sizes ModSize module-sizes total_module_size compile_status always_ok alloc_spec = SpecP Allocations Allocs allocations (meanInt allocs) run_status always_ok runtime_spec = SpecP Run Time Runtime run-times (mean run_time) run_status mean_time_ok elapsedtime_spec = SpecP Elapsed Time Elapsed elapsed-times (mean elapsed_time) run_status mean_time_ok @@ -144,6 +148,7 @@ totmem_spec = SpecP Total Memory in use TotalMem total-mem (meanInt tota all_specs :: [PerProgTableSpec] all_specs = [ size_spec, + modsize_spec, alloc_spec, runtime_spec, elapsedtime_spec, @@ -211,7 +216,7 @@ checkTimes prog results = do -- These are the per-prog tables we want to generate per_prog_result_tab :: [PerProgTableSpec] per_prog_result_tab = -[ size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec, +[ size_spec, modsize_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec, gcelap_spec, gc0count_spec, gc0time_spec, gc0elap_spec, gc1count_spec, gc1time_spec, gc1elap_spec, gcwork_spec, balance_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec, totmem_spec] @@ -219,11 +224,11 @@ per_prog_result_tab = -- aspects, each in its own column. Only works when comparing two runs. normal_summary_specs :: [PerProgTableSpec] normal_summary_specs = -[ size_spec, alloc_spec, runtime_spec, elapsedtime_spec, totmem_spec ] +[ size_spec, modsize_spec, alloc_spec, runtime_spec, elapsedtime_spec, totmem_spec ] cachegrind_summary_specs :: [PerProgTableSpec] cachegrind_summary_specs = -[ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ] +[ size_spec, modsize_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ] -- Pick an appropriate summary table: if we're cachegrinding, then -- we're probably not interested in the runtime, but we are interested @@ -517,7 +522,7 @@ asciiGenModTable results args (SpecM long_name _ get_result result_ok) ascii_header :: Int - [String] - ShowS ascii_header w ss = str \n---\n -. str (rjustify 15 Program) +. str (rjustify mAX_PROG_NAME_LENGTH Program) . str (space 5) . foldr (.) id (map (str . rjustify w) ss) . str \n---\n @@ -617,7 +622,7 @@ mungeForLaTeX = map transrow table_layout :: Int - Int - Layout table_layout n w boxes = foldr (.) id $ zipWith ($) fns boxes - where fns = (str . rjustify 15 . show ) : + where fns = (str . rjustify mAX_PROG_NAME_LENGTH . show ) : (\s - str (space 5) . str (rjustify w (show s))) : replicate (n-1) (str . rjustify w . show) @@ -678,7 +683,7 @@ show_per_prog_results = show_per_prog_results_width fIELD_WIDTH show_per_prog_results_width :: Int - (String, [BoxValue]) - ShowS show_per_prog_results_width w (prog,results) -= str (rjustify 15 prog) += str (rjustify mAX_PROG_NAME_LENGTH prog) . str (space 5) . foldr (.) id (map (str . rjustify w . showBox) results
[commit: ghc] supercompiler: Correct top-level renaming in MSG to prevent loop (5fa43dc)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/5fa43dc8cf6a2aef566b6c51780ada1ec4ebc32e --- commit 5fa43dc8cf6a2aef566b6c51780ada1ec4ebc32e Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Nov 14 15:14:50 2012 + Correct top-level renaming in MSG to prevent loop compiler/supercompile/Supercompile/Drive/MSG.hs | 46 --- 1 files changed, 32 insertions(+), 14 deletions(-) Diff suppressed because of size. To see it, use: git show 5fa43dc8cf6a2aef566b6c51780ada1ec4ebc32e ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Change how default supercompliation options are setup (9812ada)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/9812ada23b048da81416daf08494b75ae0bf48d2 --- commit 9812ada23b048da81416daf08494b75ae0bf48d2 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Mar 15 09:01:07 2012 + Change how default supercompliation options are setup --- mk/ghc-opts.mk |2 -- 1 files changed, 0 insertions(+), 2 deletions(-) diff --git a/mk/ghc-opts.mk b/mk/ghc-opts.mk index 15ab620..6aa2ffd 100644 --- a/mk/ghc-opts.mk +++ b/mk/ghc-opts.mk @@ -59,9 +59,7 @@ endif # All the standard gluing together, as in the comment right at the front -ifeq $(SRC_SUPERCOMP_HC_OPTS SRC_SUPERCOMP_HC_OPTS = -fsupercompiler-bound-steps -endif HC_OPTS= $(BOOTSTRAPPING_PACKAGE_CONF_HC_OPTS) $(SRC_HC_OPTS) $(WAY$(_way)_HC_OPTS) $($*_HC_OPTS) $(EXTRA_HC_OPTS) ifeq $(HC_VERSION_GE_6_13) YES ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Complete Deeds threading in Split2 (08b7320)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/08b73205fd3b06deffe9994131ae5d8bf7b4e1a8 --- commit 08b73205fd3b06deffe9994131ae5d8bf7b4e1a8 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Nov 1 17:22:34 2012 + Complete Deeds threading in Split2 compiler/supercompile/Supercompile/Core/Syntax.hs | 10 ++- compiler/supercompile/Supercompile/Drive/Split2.hs | 95 .../supercompile/Supercompile/Evaluator/Syntax.hs |7 ++ compiler/supercompile/Supercompile/Utilities.hs|8 ++ 4 files changed, 83 insertions(+), 37 deletions(-) Diff suppressed because of size. To see it, use: git show 08b73205fd3b06deffe9994131ae5d8bf7b4e1a8 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Tweaks to benchmarks, more benchmarks (ddc87cc)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/ddc87ccb2620e7588c2c26f260963536bef8427e --- commit ddc87ccb2620e7588c2c26f260963536bef8427e Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Nov 15 11:11:53 2012 + Tweaks to benchmarks, more benchmarks imaginary/tak/Makefile |3 +- supercompile/neil/Makefile |2 +- supercompile/neil/SumSquare-Explicit/Main.hs | 22 .../Makefile |0 .../SumSquare-Explicit.stdout} |0 supercompile/peter/Append/Main.hs |7 - supercompile/peter/Raytracer/Main.hs |7 - supercompile/peter/ZipMaps/Main.hs |7 - supercompile/toys/AccumulatingParam/Main.hs|6 supercompile/toys/Makefile |2 +- supercompile/toys/MapMapFusion/Main.hs |7 - supercompile/toys/queens-explicit/Main.hs | 27 .../toys/queens-explicit}/Makefile |2 +- .../queens-explicit/queens-explicit.slowstdout |0 .../toys/queens-explicit/queens-explicit.stdout|0 15 files changed, 84 insertions(+), 8 deletions(-) Diff suppressed because of size. To see it, use: git show ddc87ccb2620e7588c2c26f260963536bef8427e ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Playing with Bernouilli (b65222f)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/b65222fb4962b04f0827ed89e498ad44a5e15671
---
commit b65222fb4962b04f0827ed89e498ad44a5e15671
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Thu Mar 15 09:58:43 2012 +
Playing with Bernouilli
---
imaginary/bernouilli/Main.hs |1 +
imaginary/bernouilli/Makefile |2 ++
2 files changed, 3 insertions(+), 0 deletions(-)
diff --git a/imaginary/bernouilli/Main.hs b/imaginary/bernouilli/Main.hs
index 5886c67..dde0756 100644
--- a/imaginary/bernouilli/Main.hs
+++ b/imaginary/bernouilli/Main.hs
@@ -22,6 +22,7 @@ neg_powers =
pascal:: [[Integer]]
pascal = [1,2,1] : map (\line - zipWith (+) (line++[0]) (0:line)) pascal
+{-# SUPERCOMPILE bernoulli #-}
bernoulli 0 = 1
bernoulli 1 = -(1%2)
bernoulli n | odd n = 0
diff --git a/imaginary/bernouilli/Makefile b/imaginary/bernouilli/Makefile
index 56dd57c..cf5295a 100644
--- a/imaginary/bernouilli/Makefile
+++ b/imaginary/bernouilli/Makefile
@@ -6,5 +6,7 @@ include $(TOP)/mk/boilerplate.mk
SRCS=Main.hs
PROG_ARGS += 500
+SRC_SUPERCOMP_HC_OPTS =
+
include $(TOP)/mk/target.mk
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Considerable benchmark tweaking (6f01206)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6f01206bd1036ec0f5b7a7d8cf46d73d2f375d94 --- commit 6f01206bd1036ec0f5b7a7d8cf46d73d2f375d94 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Nov 14 12:57:36 2012 + Considerable benchmark tweaking Makefile |2 +- imaginary/wheel-sieve1/Makefile|3 +- supercompile/neil/Makefile |5 +++- supercompile/neil/SumSquare-LazySum/Makefile |2 + supercompile/neil/SumSquare/Makefile |2 + supercompile/peter/Append/Makefile |4 ++- supercompile/peter/Factorial/Main.hs | 10 supercompile/peter/Factorial/Makefile |8 -- supercompile/peter/Makefile|2 +- supercompile/peter/Raytracer/Main.hs | 10 +++ supercompile/peter/Raytracer/Makefile |4 ++- supercompile/peter/SumTree/Makefile|4 ++- supercompile/peter/TreeFlip/Makefile |4 ++- supercompile/peter/ZipMaps/Main.hs | 10 +-- supercompile/peter/ZipMaps/Makefile|6 supercompile/peter/ZipMaps/ZipMaps.stdout |2 +- supercompile/peter/ZipTreeMaps/Main.hs | 22 ++-- supercompile/peter/ZipTreeMaps/Makefile|6 supercompile/peter/ZipTreeMaps/ZipTreeMaps.stdout |2 +- .../AccumulatingParam-Peano.stdout |2 +- supercompile/toys/AccumulatingParam-Peano/Makefile |8 -- .../AccumulatingParam/AccumulatingParam.stdout |2 +- supercompile/toys/AccumulatingParam/Main.hs|6 - supercompile/toys/AccumulatingParam/Makefile |6 supercompile/toys/Ackermann/Ackermann.stdout |2 +- supercompile/toys/Ackermann/Main.hs|4 ++- supercompile/toys/Ackermann/Makefile |6 .../toys/AckermannPeano-1/AckermannPeano-1.stdout |2 +- supercompile/toys/AckermannPeano-1/Main.hs | 14 ++- supercompile/toys/AckermannPeano-1/Makefile|6 supercompile/toys/AckermannPeano-2/Main.hs | 14 ++- supercompile/toys/AckermannPeano-2/Makefile|6 supercompile/toys/AppendAssociativity/Makefile |2 + supercompile/toys/AppendRightUnit/Makefile |2 + supercompile/toys/EvenDouble/Main.hs | 10 +++- supercompile/toys/EvenDouble/Makefile |6 supercompile/toys/EvenDoubleGenerator/Main.hs | 10 +++- supercompile/toys/EvenDoubleGenerator/Makefile |6 supercompile/toys/FoldlSpecialisation/Makefile |2 + supercompile/toys/Generalisation-Lazy/Makefile |2 + .../toys/Generalisation-Literals-Lazy/Makefile |2 + supercompile/toys/Generalisation-Literals/Makefile |2 + .../toys/Generalisation/Generalisation.stdout |2 +- supercompile/toys/Generalisation/Main.hs | 10 +++- supercompile/toys/Generalisation/Makefile |6 supercompile/toys/KMP/Main.hs |6 - supercompile/toys/KMP/Makefile |6 supercompile/toys/LetRec/LetRec.stdout |2 +- supercompile/toys/LetRec/Main.hs | 26 +++ supercompile/toys/LetRec/Makefile |6 supercompile/toys/Makefile | 11 +++- supercompile/toys/MapMapFusion/Main.hs | 14 +++--- supercompile/toys/MapMapFusion/Makefile|6 supercompile/toys/MapMapFusion/MapMapFusion.stdout |2 +- supercompile/toys/ReverseReverse/Main.hs |6 - supercompile/toys/ReverseReverse/Makefile |6 .../toys/ReverseReverse/ReverseReverse.stdout |2 +- supercompile/toys/SpeculationWorstCase/Makefile|2 + .../toys/StrictFoldlSpecialisation/Makefile|2 + 59 files changed, 290 insertions(+), 55 deletions(-) Diff suppressed because of size. To see it, use: git show 6f01206bd1036ec0f5b7a7d8cf46d73d2f375d94 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Make subset of supercompile-folder benchmarks compile and run correctly, fix SC opts for other benchmarks (87c35a0)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/87c35a015f8adb7c0ae4d5329d115d7b994e2250 --- commit 87c35a015f8adb7c0ae4d5329d115d7b994e2250 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Nov 9 15:04:09 2012 + Make subset of supercompile-folder benchmarks compile and run correctly, fix SC opts for other benchmarks imaginary/bernouilli/Main.hs |3 ++- imaginary/digits-of-e1/Makefile|2 ++ imaginary/digits-of-e2/Makefile|2 ++ imaginary/exp3_8/Makefile |2 ++ imaginary/gen_regexps/Makefile |3 +++ imaginary/integrate/Makefile |2 ++ imaginary/paraffins/Makefile |3 +++ imaginary/primes/Makefile |2 ++ imaginary/queens/Makefile |2 ++ imaginary/rfib/Makefile|2 ++ imaginary/tak/Makefile |2 ++ imaginary/wheel-sieve1/Makefile|2 ++ imaginary/wheel-sieve2/Makefile|3 +++ imaginary/x2n1/Makefile|2 ++ mk/target.mk |2 +- supercompile/Makefile |4 +++- supercompile/neil/SumSquare-LazySum/Main.hs|3 +-- supercompile/neil/SumSquare/Main.hs|7 ++- supercompile/neil/SumSquare/SumSquare.stdout |2 +- supercompile/peter/Append/Main.hs |2 +- supercompile/peter/Factorial/Factorial.stdout |2 +- supercompile/peter/Factorial/Makefile |2 ++ supercompile/peter/Raytracer/Main.hs |4 ++-- supercompile/peter/TreeFlip/Main.hs|2 ++ supercompile/peter/ZipMaps/Main.hs |3 ++- supercompile/peter/ZipMaps/ZipMaps.stdout |2 +- supercompile/peter/ZipTreeMaps/Main.hs |3 ++- supercompile/peter/ZipTreeMaps/ZipTreeMaps.stdout |2 +- supercompile/toys/AccumulatingParam-Peano/Main.hs | 13 - supercompile/toys/AccumulatingParam/Main.hs|2 +- supercompile/toys/Ackermann/Ackermann.stdout |2 +- supercompile/toys/Ackermann/Main.hs|4 +--- supercompile/toys/Ackermann/Makefile |4 supercompile/toys/AckermannPeano-1/Main.hs |2 +- supercompile/toys/AckermannPeano-2/Main.hs |3 ++- supercompile/toys/EvenDouble/Main.hs |2 ++ supercompile/toys/EvenDoubleGenerator/Main.hs |2 ++ .../FoldlSpecialisation/FoldlSpecialisation.stdout |2 +- supercompile/toys/FoldlSpecialisation/Main.hs |2 ++ supercompile/toys/Generalisation-Literals/Main.hs |4 ++-- supercompile/toys/Generalisation/Main.hs |4 ++-- supercompile/toys/LetRec/LetRec.stdout |2 +- supercompile/toys/MapMapFusion/Main.hs |2 +- supercompile/toys/MapMapFusion/MapMapFusion.stdout |2 +- .../toys/ReverseReverse/ReverseReverse.stdout |2 +- .../toys/StrictFoldlSpecialisation/Main.hs |2 -- 46 files changed, 90 insertions(+), 38 deletions(-) Diff suppressed because of size. To see it, use: git show 87c35a015f8adb7c0ae4d5329d115d7b994e2250 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Ensure wrappers are SUPERINLINABLE (61f74db)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/61f74db90cba9d4e5b9d9a9207f1cba6311dc0ff
---
commit 61f74db90cba9d4e5b9d9a9207f1cba6311dc0ff
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Nov 16 14:11:22 2012 +
Ensure wrappers are SUPERINLINABLE
---
compiler/supercompile/Supercompile.hs |1 +
.../Supercompile/Evaluator/Evaluate.hs |3 +++
2 files changed, 4 insertions(+), 0 deletions(-)
diff --git a/compiler/supercompile/Supercompile.hs
b/compiler/supercompile/Supercompile.hs
index 4dad93c..ae08183 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -191,6 +191,7 @@ termUnfoldings {-mod_finder-} e = go (S.termFreeVars e)
emptyVarSet [] []
-- We still do check shouldExposeUnfolding here because we can avoid
parsing+tagging those unfoldings
-- which can literall never be used.
varUnfolding x
+ -- NB: probably want to ensure these are all considered superinlinable
by shouldExposeUnfolding for the evaluator
| Just pop - isPrimOpId_maybe x = Right $ primOpUnfolding pop
| Just dc - isDataConWorkId_maybe x = dataUnfolding dc
| otherwise = case S.shouldExposeUnfolding x of
diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index fe196cf..d3556bf 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -562,6 +562,9 @@ shouldExposeUnfolding x = case inl_inline inl_prag of
_ | Just mod - nameModule_maybe (idName x)
, moduleName mod `elem` map mkModuleName [Data.Complex, GHC.List]
- Right True
+-- These get wrappers generated for them: be very eager to inline the
wrappers
+ | isPrimOpId x || isDataConWorkId x
+ - Right True
-- NB: we don't check the activation on INLINE things because so many
activations
-- are used to ensure that e.g. RULE-based fusion works properly, and
NOINLINE will
-- generally impede supercompiler-directed fusion.
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: Ad-hoc nofib-analyse changes and SUPERCOMP_HC_OPTS (270c8d8)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/270c8d8ae5c349c7c2fe35d861346c5c77535a91 --- commit 270c8d8ae5c349c7c2fe35d861346c5c77535a91 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Dec 6 16:33:09 2012 + Ad-hoc nofib-analyse changes and SUPERCOMP_HC_OPTS imaginary/Makefile |4 +--- nofib-analyse/Main.hs | 24 ++-- nofib-analyse/Slurp.hs |7 ++- spectral/ansi/Makefile |2 ++ spectral/atom/Makefile |2 ++ spectral/awards/Makefile|1 + spectral/awards/QSort.hs|1 + spectral/banner/Makefile|2 ++ spectral/boyer/Makefile |2 ++ spectral/boyer2/Makefile|2 ++ spectral/calendar/Makefile |2 ++ spectral/cichelli/Makefile |2 ++ spectral/circsim/Makefile |2 ++ spectral/clausify/Makefile |2 ++ spectral/constraints/Makefile |2 ++ spectral/cryptarithm1/Makefile |2 ++ spectral/cryptarithm2/Makefile |2 ++ spectral/cse/Makefile |2 ++ spectral/eliza/Makefile |2 ++ spectral/expert/Makefile|2 ++ spectral/fft2/Makefile |2 ++ spectral/fibheaps/Makefile |2 ++ spectral/fish/Makefile |2 ++ spectral/gcd/Makefile |2 ++ spectral/hartel/comp_lab_zift/Makefile |2 ++ spectral/hartel/event/Makefile |2 ++ spectral/hartel/fft/Makefile|2 ++ spectral/hartel/genfft/Makefile |2 ++ spectral/hartel/ida/Makefile|2 ++ spectral/hartel/listcompr/Makefile |2 ++ spectral/hartel/listcopy/Makefile |2 ++ spectral/hartel/nucleic2/Makefile |2 ++ spectral/hartel/parstof/Makefile|2 ++ spectral/hartel/sched/Makefile |2 ++ spectral/hartel/solid/Makefile |2 ++ spectral/hartel/transform/Makefile |2 ++ spectral/hartel/typecheck/Makefile |2 ++ spectral/hartel/wang/Makefile |2 ++ spectral/hartel/wave4main/Makefile |2 ++ spectral/integer/Makefile |2 ++ spectral/knights/Makefile |2 ++ spectral/lambda/Makefile|2 ++ spectral/lcss/Makefile |2 ++ spectral/life/Makefile |2 ++ spectral/mandel/Makefile|2 ++ spectral/mandel2/Makefile |2 ++ spectral/mate/Makefile |2 ++ spectral/minimax/Makefile |2 ++ spectral/multiplier/Makefile|2 ++ spectral/para/Makefile |2 ++ spectral/power/Makefile |2 ++ spectral/pretty/Makefile|2 ++ spectral/primetest/Makefile |2 ++ spectral/puzzle/Makefile|2 ++ spectral/rewrite/Makefile |2 ++ spectral/scc/Makefile |2 ++ spectral/secretary/Makefile |2 ++ spectral/simple/Makefile|2 ++ spectral/sorting/Makefile |2 ++ spectral/sphere/Makefile|2 ++ spectral/treejoin/Makefile |2 ++ spectral/triangle/Makefile |2 ++ supercompile/neil/Makefile |6 -- supercompile/toys/AccumulatingParam/Main.hs |2 +- supercompile/toys/Makefile |4 +++- 65 files changed, 149 insertions(+), 14 deletions(-) Diff suppressed because of size. To see it, use: git show 270c8d8ae5c349c7c2fe35d861346c5c77535a91 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: nofib] supercompiler: First draft of supercompilation nofib tests (5d0863d)
Repository : ssh://darcs.haskell.org//srv/darcs/nofib On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/5d0863d4afd518853e6c80b55112038fb12627c3 --- commit 5d0863d4afd518853e6c80b55112038fb12627c3 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Sun Mar 11 20:07:37 2012 + First draft of supercompilation nofib tests mk/ghc-opts.mk |6 + supercompile/Makefile |5 + supercompile/compile-time/ConcatMapSpec/Main.hs| 30 supercompile/compile-time/ConcatMapSpec/Makefile |6 + supercompile/compile-time/Makefile |5 + supercompile/compile-time/SimonSpec/Main.hs| 30 supercompile/compile-time/SimonSpec/Makefile |6 + supercompile/contracts/Head-Contract/Main.hs | 12 ++ supercompile/contracts/Head-Contract/Makefile |6 + .../contracts/IdList-SameLength-Koen/Main.hs | 166 .../contracts/IdList-SameLength-Koen/Makefile |6 + supercompile/contracts/IdList-SameLength/Main.hs | 71 + supercompile/contracts/IdList-SameLength/Makefile |6 + supercompile/contracts/Last-Contract/Main.hs | 22 +++ supercompile/contracts/Last-Contract/Makefile |6 + supercompile/contracts/Makefile|5 + supercompile/contracts/Zip-Contract/Main.hs| 103 supercompile/contracts/Zip-Contract/Makefile |6 + .../FilterMap-MapFilterCompose.stdout |1 + .../ilya/FilterMap-MapFilterCompose/Main.hs| 15 ++ .../ilya/FilterMap-MapFilterCompose/Makefile |6 + .../Iterate-MapIterate/Iterate-MapIterate.stdout |1 + supercompile/ilya/Iterate-MapIterate/Main.hs | 13 ++ supercompile/ilya/Iterate-MapIterate/Makefile |6 + .../LengthConcat-SumMapLength.stdout |1 + .../ilya/LengthConcat-SumMapLength/Main.hs | 20 +++ .../ilya/LengthConcat-SumMapLength/Makefile|6 + supercompile/ilya/Makefile |5 + supercompile/ilya/Map-JoinComposeReturn/Main.hs| 16 ++ supercompile/ilya/Map-JoinComposeReturn/Makefile |6 + .../Map-JoinComposeReturn.stdout |1 + supercompile/ilya/MapAppend-AppendMapMap/Main.hs | 13 ++ supercompile/ilya/MapAppend-AppendMapMap/Makefile |6 + .../MapAppend-AppendMapMap.stdout |1 + supercompile/ilya/MapCompose-ComposeMapMap/Main.hs | 13 ++ .../ilya/MapCompose-ComposeMapMap/Makefile |6 + .../MapCompose-ComposeMapMap.stdout|1 + supercompile/ilya/MapConcat-ConcatMapMap/Main.hs | 14 ++ supercompile/ilya/MapConcat-ConcatMapMap/Makefile |6 + .../MapConcat-ConcatMapMap.stdout |1 + supercompile/jason/Explode/Explode.stdout |1 + supercompile/jason/Explode/Main.hs | 11 ++ supercompile/jason/Explode/Makefile|6 + supercompile/jason/Makefile|5 + supercompile/neil/Makefile |5 + supercompile/neil/SumSquare-LazySum/Main.hs| 11 ++ supercompile/neil/SumSquare-LazySum/Makefile |6 + .../SumSquare-LazySum/SumSquare-LazySum.stdout |1 + supercompile/neil/SumSquare/Main.hs|8 + supercompile/neil/SumSquare/Makefile |6 + supercompile/neil/SumSquare/SumSquare.stdout |1 + supercompile/peter/Append/Append.stdout|1 + supercompile/peter/Append/Main.hs | 12 ++ supercompile/peter/Append/Makefile | 10 ++ supercompile/peter/Factorial/Factorial.stdout |1 + supercompile/peter/Factorial/Main.hs | 15 ++ supercompile/peter/Factorial/Makefile | 10 ++ supercompile/peter/Makefile|5 + supercompile/peter/Raytracer/Main.hs | 12 ++ supercompile/peter/Raytracer/Makefile | 10 ++ supercompile/peter/Raytracer/Raytracer.stdout |1 + supercompile/peter/SumTree/Main.hs | 30 supercompile/peter/SumTree/Makefile| 10 ++ supercompile/peter/SumTree/SumTree.stdout |1 + supercompile/peter/TreeFlip/Main.hs| 26 +++ supercompile/peter/TreeFlip/Makefile | 10 ++ supercompile/peter/TreeFlip/TreeFlip.stdout|1 + supercompile/peter/ZipMaps/Main.hs |7 + supercompile/peter/ZipMaps/Makefile|6 + supercompile/peter/ZipMaps/ZipMaps.stdout |1 + supercompile/peter/ZipTreeMaps/Main.hs | 17 ++ supercompile/peter/ZipTreeMaps/Makefile|6 + supercompile/peter/ZipTreeMaps/ZipTreeMaps.stdout |1 + .../AccumulatingParam-Peano.stdout
[commit: ghc] supercompiler: Initial supercompiler commit (50c0681)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/50c068116804df3556bee1fb2e4a50f6a0925fa1 --- commit 50c068116804df3556bee1fb2e4a50f6a0925fa1 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Apr 7 07:49:30 2011 +0100 Initial supercompiler commit compiler/ghc.cabal.in |7 + compiler/main/GHC.hs |2 + compiler/supercompile/Supercompile.hs | 17 ++ .../supercompile/Supercompile/Core/FreeVars.hs | 126 ++ .../supercompile/Supercompile/Core/Renaming.hs | 123 ++ compiler/supercompile/Supercompile/Core/Size.hs| 91 +++ compiler/supercompile/Supercompile/Core/Syntax.hs | 245 +++ .../supercompile/Supercompile/Evaluator/Syntax.hs | 199 +++ compiler/supercompile/Supercompile/StaticFlags.hs | 13 + compiler/supercompile/Supercompile/Utilities.hs| 255 10 files changed, 1078 insertions(+), 0 deletions(-) Diff suppressed because of size. To see it, use: git show 50c068116804df3556bee1fb2e4a50f6a0925fa1 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Small fixes (13ed44c)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/13ed44cecf8a9aeec43307f27e3ba602e8bda3bd --- commit 13ed44cecf8a9aeec43307f27e3ba602e8bda3bd Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed May 11 14:12:57 2011 +0100 Small fixes .../Supercompile/Evaluator/Evaluate.hs | 32 .../supercompile/Supercompile/Evaluator/Syntax.hs |5 +++ 2 files changed, 24 insertions(+), 13 deletions(-) Diff suppressed because of size. To see it, use: git show 13ed44cecf8a9aeec43307f27e3ba602e8bda3bd ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Misc fixes to supercompiler, moving it forward (89091c1)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/89091c119df744ae94065036038a4a2409d64bad --- commit 89091c119df744ae94065036038a4a2409d64bad Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Apr 12 20:37:24 2011 +0100 Misc fixes to supercompiler, moving it forward compiler/ghc.cabal.in |2 + .../supercompile/Supercompile/Core/FreeVars.hs |2 +- .../supercompile/Supercompile/Core/Renaming.hs | 21 ++- compiler/supercompile/Supercompile/Core/Size.hs|4 +- compiler/supercompile/Supercompile/Core/Syntax.hs | 19 +- compiler/supercompile/Supercompile/Core/Tag.hs |6 +- .../supercompile/Supercompile/Evaluator/Deeds.hs | 20 ++ .../Supercompile/Evaluator/Evaluate.hs | 214 .../Supercompile/Evaluator/FreeVars.hs |2 + .../supercompile/Supercompile/Evaluator/Syntax.hs | 31 +++- compiler/supercompile/Supercompile/StaticFlags.hs |2 + 11 files changed, 294 insertions(+), 29 deletions(-) Diff suppressed because of size. To see it, use: git show 89091c119df744ae94065036038a4a2409d64bad ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Port stuff over up until the evaluator itself (infrastructure is in place) (1ea7885)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/1ea7885a05d0326e52f667db4ff5385126e5bb4b --- commit 1ea7885a05d0326e52f667db4ff5385126e5bb4b Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Apr 7 11:55:55 2011 +0100 Port stuff over up until the evaluator itself (infrastructure is in place) compiler/ghc.cabal.in |3 + compiler/supercompile/Supercompile.hs |3 + .../supercompile/Supercompile/Core/FreeVars.hs | 11 ++- .../supercompile/Supercompile/Core/Renaming.hs | 40 +--- compiler/supercompile/Supercompile/Core/Size.hs| 22 ++-- compiler/supercompile/Supercompile/Core/Syntax.hs | 50 ++ compiler/supercompile/Supercompile/Core/Tag.hs | 89 .../Supercompile/Evaluator/FreeVars.hs | 85 .../supercompile/Supercompile/Evaluator/Syntax.hs | 107 compiler/supercompile/Supercompile/Utilities.hs| 61 +++- 10 files changed, 358 insertions(+), 113 deletions(-) Diff suppressed because of size. To see it, use: git show 1ea7885a05d0326e52f667db4ff5385126e5bb4b ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Commit more work on the porting (86909c0)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/86909c048af2255341c309b25727bd4aaf7ad45c --- commit 86909c048af2255341c309b25727bd4aaf7ad45c Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu May 5 07:33:26 2011 +0100 Commit more work on the porting compiler/ghc.cabal.in |1 + compiler/supercompile/Supercompile.hs |1 + .../supercompile/Supercompile/Core/FreeVars.hs | 17 +-- .../supercompile/Supercompile/Core/Renaming.hs | 12 +- compiler/supercompile/Supercompile/Core/Size.hs|2 +- compiler/supercompile/Supercompile/Core/Syntax.hs | 23 ++-- compiler/supercompile/Supercompile/Core/Tag.hs | 27 ++-- .../Supercompile/Evaluator/Evaluate.hs | 165 ++-- .../Supercompile/Evaluator/FreeVars.hs |7 +- .../Supercompile/Evaluator/Residualise.hs | 64 .../supercompile/Supercompile/Evaluator/Syntax.hs | 68 ++-- compiler/supercompile/Supercompile/StaticFlags.hs | 10 ++ compiler/supercompile/Supercompile/Utilities.hs| 19 +++ 13 files changed, 267 insertions(+), 149 deletions(-) Diff suppressed because of size. To see it, use: git show 86909c048af2255341c309b25727bd4aaf7ad45c ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Eliminate tabs (a444857)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/a444857998a9caa87cfe21b1b73cfce99d541431 --- commit a444857998a9caa87cfe21b1b73cfce99d541431 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Jun 14 18:02:00 2011 +0100 Eliminate tabs --- compiler/ghc.cabal.in |2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index e760d4f..1e8c5b9 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -450,7 +450,7 @@ Library Supercompile.Core.Tag Supercompile.Core.FreeVars Supercompile.Drive.Match - Supercompile.Evaluator.Deeds +Supercompile.Evaluator.Deeds Supercompile.Evaluator.Evaluate Supercompile.Evaluator.FreeVars Supercompile.Evaluator.Residualise ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: The evaluator finally compiles (5b88481)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/5b88481f1a9c489c2f01ea60a8f72111d8ede872 --- commit 5b88481f1a9c489c2f01ea60a8f72111d8ede872 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu May 12 08:22:15 2011 +0100 The evaluator finally compiles compiler/basicTypes/VarSet.lhs |2 - .../supercompile/Supercompile/Core/FreeVars.hs | 10 +- .../supercompile/Supercompile/Core/Renaming.hs | 27 +++-- compiler/supercompile/Supercompile/Core/Size.hs|2 +- compiler/supercompile/Supercompile/Core/Syntax.hs | 26 +++--- compiler/supercompile/Supercompile/Core/Tag.hs | 20 ++-- .../Supercompile/Evaluator/Evaluate.hs | 112 +++- .../Supercompile/Evaluator/FreeVars.hs | 27 +++-- .../supercompile/Supercompile/Evaluator/Syntax.hs |7 +- compiler/supercompile/Supercompile/Utilities.hs|8 ++ compiler/utils/UniqFM.lhs |3 - compiler/utils/UniqSet.lhs |3 - 12 files changed, 157 insertions(+), 90 deletions(-) Diff suppressed because of size. To see it, use: git show 5b88481f1a9c489c2f01ea60a8f72111d8ede872 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Matching compiles and should handle new syntax (bf8fae9)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/bf8fae98c628ea45f9865e9f4162b5ae54139151 --- commit bf8fae98c628ea45f9865e9f4162b5ae54139151 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 15 16:40:03 2011 +0100 Matching compiles and should handle new syntax compiler/supercompile/Supercompile/Drive/Match.hs | 135 +++- compiler/supercompile/Supercompile/Utilities.hs |3 + compiler/utils/Outputable.lhs | 10 ++ 3 files changed, 114 insertions(+), 34 deletions(-) Diff suppressed because of size. To see it, use: git show bf8fae98c628ea45f9865e9f4162b5ae54139151 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: A more plausible checkpoint, but still broken overall (bf2ba32)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/bf2ba324734364675b49d43b88e4d427c967c8b4
---
commit bf2ba324734364675b49d43b88e4d427c967c8b4
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed May 11 20:45:39 2011 +0100
A more plausible checkpoint, but still broken overall
---
.../supercompile/Supercompile/Core/FreeVars.hs |4 +-
.../supercompile/Supercompile/Core/Renaming.hs | 21 ++--
compiler/supercompile/Supercompile/Core/Syntax.hs |2 +-
.../Supercompile/Evaluator/Evaluate.hs | 25 +--
4 files changed, 28 insertions(+), 24 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Core/FreeVars.hs
b/compiler/supercompile/Supercompile/Core/FreeVars.hs
index 4b80d0c..0efa454 100644
--- a/compiler/supercompile/Supercompile/Core/FreeVars.hs
+++ b/compiler/supercompile/Supercompile/Core/FreeVars.hs
@@ -76,8 +76,8 @@ altConFreeVars DefaultAlt = id
coercedFreeVars :: (a - FreeVars) - Coerced a - FreeVars
-coercedFreeVars f (Nothing, x) = f x
-coercedFreeVars f (Just co, x) = f x `unionVarSet` tyCoVarsOfCo co
+coercedFreeVars f (Nothing, x) = f x
+coercedFreeVars f (Just (co, _), x) = f x `unionVarSet` tyCoVarsOfCo co
data FVed a = FVed { freeVars :: !FreeVars, fvee :: !a }
diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs
b/compiler/supercompile/Supercompile/Core/Renaming.hs
index 6011efe..860db7a 100644
--- a/compiler/supercompile/Supercompile/Core/Renaming.hs
+++ b/compiler/supercompile/Supercompile/Core/Renaming.hs
@@ -17,10 +17,6 @@ import Var (CoVar, TyVar, isTyVar)
import VarEnv
-isTyCoVar :: Var - Bool
-isTyCoVar x = isTyVar x || isCoVar x
-
-
-- We are going to use GHC's substitution type in a rather stylised way, and
only
-- ever substitute variables for variables. The reasons for this are twofold:
--
@@ -39,11 +35,12 @@ isTyCoVar x = isTyVar x || isCoVar x
--
-- gam = (F Int - F Int ~ Bool - Bool)
--
--- We need to reduce to:
+-- We need to reduce to something like:
--
-- e[(y | sym (nth 1 gam))/x] | (nth 2 gam)
--
--- We record this information as an optional Cast around the Vars in the
IdSubstEnv.
+-- We deal with this problem in the evaluator by introducing an intermediate
let binding for
+-- such redexes.
type Renaming = (IdSubstEnv, TvSubstEnv, CvSubstEnv)
@@ -62,14 +59,12 @@ mkIdentityRenaming fvs = (mkVarEnv [(x, CoreSyn.Var x) | x
- id_list], mkVarEnv
where (tv_list, coid_list) = partition isTyVar (varSetElems fvs)
(co_list, id_list) = partition isCoVar coid_list
-coercedVarToCoreSyn :: Coerced (Out Var) - CoreSyn.Expr
-coercedVarToCoreSyn (Nothing, x') = CoreSyn.Var x'
-coercedVarToCoreSyn (Just co', x') = CoreSyn.Var x' `CoreSyn.Cast` co'
+coercedVarToCoreSyn :: Var - CoreSyn.Expr
+coercedVarToCoreSyn x' = CoreSyn.Var x'
-coreSynToCoercedVar :: CoreSyn.Expr - Coerced (Out Var)
-coreSynToCoercedVar (CoreSyn.Var x')= (Nothing, x')
-coreSynToCoercedVar (CoreSyn.Cast (CoreSyn.Var x') co') = (Just co', x')
-coreSynToCoercedVar e = panic renome (ppr
e)
+coreSynToCoercedVar :: CoreSyn.Expr - Var
+coreSynToCoercedVar (CoreSyn.Var x') = x'
+coreSynToCoercedVar e= panic renome (ppr e)
insertRenaming :: Renaming - Var - Var - Renaming
insertRenaming (id_subst, tv_subst, co_subst) x x' = (extendVarEnv id_subst x
(coercedVarToCoreSyn x'), tv_subst, co_subst)
diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs
b/compiler/supercompile/Supercompile/Core/Syntax.hs
index 6439e95..ed731e2 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -165,7 +165,7 @@ termToVar e = case extract e of
_ - Nothing -- FIXME: cast things as well
-type Coerced a = (Maybe (Out Coercion), a)
+type Coerced a = (Maybe (Out Coercion, Tag), a)
class Functor ann = Symantics ann where
diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index 399eabb..c4c6391 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -137,7 +137,7 @@ step' normalising state =
unwind :: Deeds - Heap - Stack - Tag - Answer - Maybe
UnnormalisedState
unwind deeds h k tg_v in_v = uncons k = \(kf, k) - case tagee kf of
TyApply ty' - tyApply(deeds + 1) h k
in_v ty'
-Apply x2' - apply (deeds + 1) h k
in_v x2'
+Apply x2' - apply deeds (tag kf) h k
in_v x2'
Scrutinise x' ty' in_alts - scrutinise (deeds + 1
[commit: ghc] supercompiler: Checkpoint (broken) (e51b461)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/e51b46175e49bf1049933ff6a6bfd4a9769691bb --- commit e51b46175e49bf1049933ff6a6bfd4a9769691bb Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed May 11 20:00:13 2011 +0100 Checkpoint (broken) compiler/basicTypes/VarSet.lhs |2 + .../supercompile/Supercompile/Core/FreeVars.hs | 10 ++- .../supercompile/Supercompile/Core/Renaming.hs | 73 ++-- compiler/supercompile/Supercompile/Core/Syntax.hs |9 ++- .../Supercompile/Evaluator/Evaluate.hs | 10 ++-- .../Supercompile/Evaluator/FreeVars.hs |2 +- .../supercompile/Supercompile/Evaluator/Syntax.hs |4 +- compiler/utils/UniqFM.lhs |3 + compiler/utils/UniqSet.lhs |3 + 9 files changed, 83 insertions(+), 33 deletions(-) Diff suppressed because of size. To see it, use: git show e51b46175e49bf1049933ff6a6bfd4a9769691bb ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Checkpoint work on matcher (b1011f2)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/b1011f2fbc7fb6f1c5b1e6449e7072ca685bc539 --- commit b1011f2fbc7fb6f1c5b1e6449e7072ca685bc539 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu May 12 09:56:26 2011 +0100 Checkpoint work on matcher compiler/ghc.cabal.in |3 +- compiler/supercompile/Supercompile.hs |2 + .../supercompile/Supercompile/Core/Renaming.hs |5 + compiler/supercompile/Supercompile/Drive/Match.hs | 292 .../Supercompile/Evaluator/FreeVars.hs |7 +- compiler/supercompile/Supercompile/Utilities.hs|6 + 6 files changed, 313 insertions(+), 2 deletions(-) Diff suppressed because of size. To see it, use: git show b1011f2fbc7fb6f1c5b1e6449e7072ca685bc539 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: More small fixes (e416886)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/e4168865dc202aa5e9a3bf2e8a553100759d28fa --- commit e4168865dc202aa5e9a3bf2e8a553100759d28fa Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed May 11 14:51:59 2011 +0100 More small fixes --- .../Supercompile/Evaluator/Evaluate.hs | 16 compiler/supercompile/Supercompile/Utilities.hs|3 +++ 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index 3cd5341..6c81a87 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -78,7 +78,7 @@ step' normalising state = where go :: (Deeds, Heap, Stack, In AnnedTerm) - (Bool, State) go (deeds, h@(Heap _ ids), k, (rn, e)) - | Just anned_a - termToAnswer iss (rn, e) = go_answer (deeds, h, k, anned_a) + | Just anned_a - termToAnswer ids (rn, e) = go_answer (deeds, h, k, anned_a) | otherwise = case annee e of Var x - go_question (deeds, h, k, fmap (const (rename rn x)) e) TyApp e ty- go (deeds, h, Tagged tg (TyApply (renameType ids rn ty)) : k, (rn, e)) @@ -87,7 +87,7 @@ step' normalising state = Case e x ty alts - go (deeds, h, Tagged tg (Scrutinise (rename rn x) (renameType ids rn ty) (rn, alts)) : k, (rn, e)) Cast e co - go (deeds, h, Tagged tg (CastIt (renameType ids rn co)) : k, (rn, e)) LetRec xes e - go (allocate (deeds + 1) h k (rn, (xes, e))) -_ - panic reduced (text Impossible expression $ ppr e) +_ - panic reduced (text Impossible expression $$ ppr1 e) where tg = annedTag e go_question (deeds, h, k, anned_x) = maybe (False, (deeds, h, k, fmap Question anned_x)) (\s - (True, normalise s)) $ force deeds h k (annedTag anned_x) (annee anned_x) @@ -165,14 +165,14 @@ step' normalising state = | otherwise = Just (dereference h a) tyApply :: Deeds - Heap - Stack - Answer - Out Type - Maybe UnnormalisedState -tyApply deeds h k in_v@(_, v) ty' = do -(rn, TyLambda x e_body) - deferenceLambdaish h in_v -fmap (\deeds - (deeds, h, k, (insertTypeSubst x ty' rn, e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) +tyApply deeds h k in_v@(_, (_, v)) ty' = do +(mb_co, (rn, TyLambda x e_body)) - deferenceLambdaish h in_v +fmap (\deeds - (deeds, h, k, (insertTypeSubst rn x ty', e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) -- FIXME: deeds in mb_co? apply :: Deeds - Heap - Stack - Answer - Out Var - Maybe UnnormalisedState -apply deeds h k in_v@(_, v) x' = do -(rn, Lambda x e_body) - deferenceLambdaish h in_v -fmap (\deeds - (deeds, h, k, (insertRenaming x x' rn, e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) +apply deeds h k in_v@(_, (_, v)) x' = do +(mb_co, (rn, Lambda x e_body)) - deferenceLambdaish h in_v +fmap (\deeds - (deeds, h, k, (insertRenaming rn x x', e_body))) $ claimDeeds (deeds + annedValueSize' v) (annedSize e_body) -- FIXME: deeds in mb_co? scrutinise :: Deeds - Heap - Stack - Tag - Answer - Out Var - Out Type - In [AnnedAlt] - Maybe UnnormalisedState scrutinise deeds (Heap h ids) k tg_v (rn_v, v) x' ty' (rn_alts, alts) diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index dc9f457..786fe76 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -72,6 +72,9 @@ instance (Ord1 f, Ord a) = Ord (Wrapper1 f a) where class Outputable1 f where pprPrec1 :: Outputable a = Rational - f a - SDoc +ppr1 :: Outputable a = f a - SDoc +ppr1 = pprPrec1 noPrec + instance (Outputable1 f, Outputable a) = Outputable (Wrapper1 f a) where pprPrec prec = pprPrec1 prec . unWrapper1 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Port over the splitter (ca76f32)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/ca76f32fd341cf1fd119bfa5e5f864e151dca7b7 --- commit ca76f32fd341cf1fd119bfa5e5f864e151dca7b7 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 15 23:41:26 2011 +0100 Port over the splitter compiler/basicTypes/VarEnv.lhs | 27 +- compiler/ghc.cabal.in |2 + compiler/supercompile/Supercompile.hs |3 + .../supercompile/Supercompile/Core/FreeVars.hs |2 +- compiler/supercompile/Supercompile/Core/Size.hs|2 +- compiler/supercompile/Supercompile/Core/Syntax.hs |2 +- compiler/supercompile/Supercompile/Drive/Match.hs |1 - compiler/supercompile/Supercompile/Drive/Split.hs | 986 .../Supercompile/Evaluator/Evaluate.hs |1 - .../Supercompile/Evaluator/FreeVars.hs | 10 +- .../supercompile/Supercompile/Evaluator/Syntax.hs |2 +- compiler/supercompile/Supercompile/StaticFlags.hs | 32 +- .../Supercompile/Termination/Generaliser.hs| 40 + compiler/supercompile/Supercompile/Utilities.hs| 73 ++- compiler/utils/Outputable.lhs | 10 - 15 files changed, 1160 insertions(+), 33 deletions(-) Diff suppressed because of size. To see it, use: git show ca76f32fd341cf1fd119bfa5e5f864e151dca7b7 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Implement wrappers properly, give PrimOps type arguments (fce2c40)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/fce2c403e847aae7c4febe4f7943f26ee2c49197 --- commit fce2c403e847aae7c4febe4f7943f26ee2c49197 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 22 15:47:41 2011 +0100 Implement wrappers properly, give PrimOps type arguments compiler/supercompile/Supercompile.hs | 174 ++-- .../supercompile/Supercompile/Core/FreeVars.hs |4 +- .../supercompile/Supercompile/Core/Renaming.hs |2 +- compiler/supercompile/Supercompile/Core/Size.hs| 17 +-- compiler/supercompile/Supercompile/Core/Syntax.hs | 33 ++-- compiler/supercompile/Supercompile/Core/Tag.hs | 36 ++-- compiler/supercompile/Supercompile/Drive/Match.hs | 16 +- .../supercompile/Supercompile/Drive/Process.hs | 17 ++- compiler/supercompile/Supercompile/Drive/Split.hs |2 +- .../Supercompile/Evaluator/Evaluate.hs | 46 +++--- .../Supercompile/Evaluator/FreeVars.hs |2 +- .../Supercompile/Evaluator/Residualise.hs | 14 +- .../supercompile/Supercompile/Evaluator/Syntax.hs | 53 +++--- 13 files changed, 211 insertions(+), 205 deletions(-) Diff suppressed because of size. To see it, use: git show fce2c403e847aae7c4febe4f7943f26ee2c49197 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Support strict lets, coercions as values, write term-CoreSyn conversion (a6778cb)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/a6778cbf16b4d16661a82763a8909ffe80f34d6d --- commit a6778cbf16b4d16661a82763a8909ffe80f34d6d Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Jun 21 17:55:26 2011 +0100 Support strict lets, coercions as values, write term-CoreSyn conversion compiler/ghc.cabal.in |5 +- compiler/main/DynFlags.hs |4 + compiler/simplCore/CoreMonad.lhs |3 + compiler/simplCore/SimplCore.lhs |7 + compiler/supercompile/Supercompile.hs | 187 +-- .../supercompile/Supercompile/Core/FreeVars.hs |3 + .../supercompile/Supercompile/Core/Renaming.hs | 36 +++-- compiler/supercompile/Supercompile/Core/Size.hs|3 + compiler/supercompile/Supercompile/Core/Syntax.hs | 23 +++- compiler/supercompile/Supercompile/Core/Tag.hs |5 + compiler/supercompile/Supercompile/Drive/Match.hs | 25 ++- .../supercompile/Supercompile/Drive/Process.hs |8 +- compiler/supercompile/Supercompile/Drive/Split.hs | 17 ++- .../Supercompile/Evaluator/Evaluate.hs | 42 +++-- .../Supercompile/Evaluator/FreeVars.hs |1 + .../Supercompile/Evaluator/Residualise.hs |1 + .../supercompile/Supercompile/Evaluator/Syntax.hs | 42 +++-- .../Supercompile/Termination/Combinators.hs| 10 +- compiler/supercompile/Supercompile/Utilities.hs|5 +- 19 files changed, 332 insertions(+), 95 deletions(-) Diff suppressed because of size. To see it, use: git show a6778cbf16b4d16661a82763a8909ffe80f34d6d ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: The Process module now compiles (6b1a46e)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6b1a46e1c149cd5c475bcebf7e36ef1b02d952f2 --- commit 6b1a46e1c149cd5c475bcebf7e36ef1b02d952f2 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Mon Jun 20 23:31:55 2011 +0100 The Process module now compiles compiler/ghc.cabal.in |3 + compiler/supercompile/Supercompile.hs |1 + .../supercompile/Supercompile/Core/FreeVars.hs |4 + .../supercompile/Supercompile/Core/Renaming.hs |3 +- compiler/supercompile/Supercompile/Core/Size.hs|1 + compiler/supercompile/Supercompile/Core/Syntax.hs |8 +- compiler/supercompile/Supercompile/Core/Tag.hs |1 + .../supercompile/Supercompile/Drive/Process.hs | 570 .../supercompile/Supercompile/Evaluator/Syntax.hs | 69 +++ compiler/supercompile/Supercompile/StaticFlags.hs | 43 ++ .../Supercompile/Termination/Combinators.hs| 199 +++ .../Supercompile/Termination/Generaliser.hs|6 +- .../Supercompile/Termination/TagBag.hs | 52 ++ compiler/supercompile/Supercompile/Utilities.hs| 61 ++- 14 files changed, 1012 insertions(+), 9 deletions(-) Diff suppressed because of size. To see it, use: git show 6b1a46e1c149cd5c475bcebf7e36ef1b02d952f2 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix lots of lurking badness in Renaming. InScopeSets are still wrong (cd931d0)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/cd931d04127bc6c589dfc44e2c8d05bcebe0665e --- commit cd931d04127bc6c589dfc44e2c8d05bcebe0665e Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Jun 23 11:10:52 2011 +0100 Fix lots of lurking badness in Renaming. InScopeSets are still wrong .../supercompile/Supercompile/Core/Renaming.hs | 81 ++-- compiler/supercompile/Supercompile/Drive/Match.hs | 34 + .../supercompile/Supercompile/Drive/Process.hs | 12 ++- compiler/supercompile/Supercompile/Drive/Split.hs | 14 ++- .../Supercompile/Evaluator/Evaluate.hs | 17 ++-- .../supercompile/Supercompile/Evaluator/Syntax.hs | 12 ++-- 6 files changed, 108 insertions(+), 62 deletions(-) Diff suppressed because of size. To see it, use: git show cd931d04127bc6c589dfc44e2c8d05bcebe0665e ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Fix lurking bugs in free variable of Bracketed code, fix splitting of type lambdas (559784a)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/559784ab81c6ff649a8df2e068e17b7dc47ba017 --- commit 559784ab81c6ff649a8df2e068e17b7dc47ba017 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 22 22:08:58 2011 +0100 Fix lurking bugs in free variable of Bracketed code, fix splitting of type lambdas .../supercompile/Supercompile/Core/FreeVars.hs | 20 compiler/supercompile/Supercompile/Core/Syntax.hs | 24 +++--- .../supercompile/Supercompile/Drive/Process.hs | 10 ++-- compiler/supercompile/Supercompile/Drive/Split.hs | 49 ++- .../supercompile/Supercompile/Evaluator/Syntax.hs |1 + 5 files changed, 60 insertions(+), 44 deletions(-) Diff suppressed because of size. To see it, use: git show 559784ab81c6ff649a8df2e068e17b7dc47ba017 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Deal with [CoreBind] by going via CoreExpr (fa91c6f)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/fa91c6f169bd58b6cc523b9c48ff9c536daa4bdb
---
commit fa91c6f169bd58b6cc523b9c48ff9c536daa4bdb
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Tue Jun 21 19:51:15 2011 +0100
Deal with [CoreBind] by going via CoreExpr
---
compiler/supercompile/Supercompile.hs | 23 ---
compiler/supercompile/Supercompile/Utilities.hs |4 ++--
2 files changed, 18 insertions(+), 9 deletions(-)
diff --git a/compiler/supercompile/Supercompile.hs
b/compiler/supercompile/Supercompile.hs
index ee45aa6..a69cdc5 100644
--- a/compiler/supercompile/Supercompile.hs
+++ b/compiler/supercompile/Supercompile.hs
@@ -6,10 +6,12 @@ import qualified Supercompile.Evaluator.Syntax as S
import qualified Supercompile.Drive.Process as S
import CoreSyn
+import CoreUtils (exprType)
import DataCon(DataCon, dataConWorkId, dataConName)
import Var(isTyVar)
import Id (mkSysLocalM, idType)
import MkId (mkPrimOpId)
+import MkCore (mkBigCoreVarTup, mkTupleSelector, mkWildValBinder)
import FastString (mkFastString)
import PrimOp (PrimOp, primOpType)
import Type (Type)
@@ -54,7 +56,7 @@ data ParseState = ParseState {
initParseState :: ParseState
initParseState = ParseState {
-uniqSupply = parseUniqSupply,
+uniqSupply = anfUniqSupply,
dcWrappers = M.empty,
primWrappers = M.empty
}
@@ -118,8 +120,8 @@ appE e1 e2 = nameIt (argOf (desc e1)) e2 = \x2 - return
(e1 `S.app` x2)
-termToCoreExpr :: CoreExpr - S.Term
-termToCoreExpr = uncurry S.letRecSmart . runParseM . term
+coreExprToTerm :: CoreExpr - S.Term
+coreExprToTerm = uncurry S.letRecSmart . runParseM . term
where
term (Var x) -- | Just pop - isPrimOpId_maybe x = primWrapper pop
-- | Just dc - isDataConWorkId_maybe x = dataConWrapper dc
@@ -142,8 +144,8 @@ termToCoreExpr = uncurry S.letRecSmart . runParseM . term
alt (DataAlt dc, xs, e) = fmap ((,) (S.DataAlt dc xs)) $ term e
alt it = pprPanic termToCoreExpr (ppr it)
-coreExprToTerm :: S.Term - CoreExpr
-coreExprToTerm = term
+termToCoreExpr :: S.Term - CoreExpr
+termToCoreExpr = term
where
term e = case unI e of
S.Var x- Var x
@@ -167,8 +169,15 @@ coreExprToTerm = term
alt (S.LiteralAlt l, e) = (LitAlt l, [], term e)
alt (S.DefaultAlt,e) = (DEFAULT,[], term e)
+coreBindsToCoreTerm :: [CoreBind] - (CoreExpr, CoreExpr - [CoreBind])
+coreBindsToCoreTerm binds
+ = (mkLets binds (mkBigCoreVarTup xs),
+ \e - let wild_id = mkWildValBinder (exprType e) in [NonRec x
(mkTupleSelector xs x wild_id e) | x - xs])
+ where xs = bindersOfBinds binds
+
supercompile :: CoreExpr - CoreExpr
-supercompile = coreExprToTerm . snd . S.supercompile . termToCoreExpr
+supercompile = termToCoreExpr . snd . S.supercompile . coreExprToTerm
supercompileProgram :: DynFlags - [CoreBind] - [CoreBind]
-supercompileProgram _dflags = undefined -- FIXME
+supercompileProgram _dflags binds = rebuild (supercompile e)
+ where (e, rebuild) = coreBindsToCoreTerm binds
diff --git a/compiler/supercompile/Supercompile/Utilities.hs
b/compiler/supercompile/Supercompile/Utilities.hs
index 7247489..508413c 100644
--- a/compiler/supercompile/Supercompile/Utilities.hs
+++ b/compiler/supercompile/Supercompile/Utilities.hs
@@ -479,6 +479,6 @@ apportion orig_n weighting
{-# NOINLINE prettyUniqSupply #-}
-hFunctionsUniqSupply, supercompileUniqSupply, parseUniqSupply,
expandUniqSupply, reduceUniqSupply, tagUniqSupply, prettyUniqSupply,
matchUniqSupply, splitterUniqSupply :: UniqSupply
+hFunctionsUniqSupply, supercompileUniqSupply, anfUniqSupply, expandUniqSupply,
reduceUniqSupply, tagUniqSupply, prettyUniqSupply, matchUniqSupply,
splitterUniqSupply :: UniqSupply
supercompileUniqSupply = unsafePerformIO $ mkSplitUniqSupply 'p'
-(hFunctionsUniqSupply:parseUniqSupply:expandUniqSupply:reduceUniqSupply:tagUniqSupply:prettyUniqSupply:matchUniqSupply:splitterUniqSupply:_)
= listSplitUniqSupply supercompileUniqSupply
+(hFunctionsUniqSupply:anfUniqSupply:expandUniqSupply:reduceUniqSupply:tagUniqSupply:prettyUniqSupply:matchUniqSupply:splitterUniqSupply:_)
= listSplitUniqSupply supercompileUniqSupply
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Use InScopeSet as a real InScopeSet, not an InScopeMap (6c138f5)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6c138f517e2c730c84b2be346632ed85f7510e96 --- commit 6c138f517e2c730c84b2be346632ed85f7510e96 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Jun 23 11:45:25 2011 +0100 Use InScopeSet as a real InScopeSet, not an InScopeMap --- .../supercompile/Supercompile/Core/Renaming.hs | 33 --- 1 files changed, 27 insertions(+), 6 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs b/compiler/supercompile/Supercompile/Core/Renaming.hs index 734be92..d79d7b4 100644 --- a/compiler/supercompile/Supercompile/Core/Renaming.hs +++ b/compiler/supercompile/Supercompile/Core/Renaming.hs @@ -73,8 +73,27 @@ type Renaming = (IdSubstEnv, TvSubstEnv, CvSubstEnv) joinSubst :: InScopeSet - Renaming - Subst joinSubst iss (id_subst, tv_subst, co_subst) = mkSubst iss tv_subst co_subst id_subst -splitSubst :: Subst - (InScopeSet, Renaming) -splitSubst (Subst iss id_subst tv_subst co_subst) = (iss, (id_subst, tv_subst, co_subst)) +-- GHC's binder-renaming stuff does this awful thing where a var-var renaming +-- will always be added to the InScopeSet (which is really an InScopeMap) but +-- will only be added to the IdSubstEnv *if the unique changes*. +-- +-- This is a problem for us because we only store the Renaming with each In thing, +-- not the full Subst. So we might lose some renamings recorded only in the InScopeSet. +-- +-- The solution is either: +-- 1) Rewrite the rest of the supercompiler so it stores a Subst with each binding. +-- Given the behaviour of GHCs binder-renamer, this is probably cleaner (and matches +-- what the GHC does), but I'm not really interested in doing that work right now. +-- +-- It also means you have te be very careful to join together InScopeSets if you +-- pull one of those Subst-paired things down into a strictly deeper context. This +-- is easy to get wrong. +-- +-- 2) Ensure that we always extend the IdSubstEnv, regardless of whether the unique changed. +-- This is the solution I've adopted, and it is implemented here in splitSubst: +splitSubst :: Subst - [(Var, Var)] - (InScopeSet, Renaming) +splitSubst (Subst iss id_subst tv_subst co_subst) xs_extend + = (iss, (id_subst `extendVarEnvList` [(x, varToCoreSyn x') | (x, x') - xs_extend], tv_subst, co_subst)) splitVarList :: [Var] - ([Id], [TyVar], [CoVar]) @@ -86,7 +105,7 @@ emptyRenaming :: Renaming emptyRenaming = (emptyVarEnv, emptyVarEnv, emptyVarEnv) mkIdentityRenaming :: FreeVars - Renaming -mkIdentityRenaming fvs = (mkVarEnv [(x, CoreSyn.Var x) | x - id_list], mkVarEnv [(x, mkTyVarTy x) | x - tv_list], mkVarEnv [(x, mkCoVarCo x) | x - co_list]) +mkIdentityRenaming fvs = (mkVarEnv [(x, varToCoreSyn x) | x - id_list], mkVarEnv [(x, mkTyVarTy x) | x - tv_list], mkVarEnv [(x, mkCoVarCo x) | x - co_list]) where (id_list, tv_list, co_list) = splitVarList (varSetElems fvs) varToCoreSyn :: Var - CoreSyn.CoreExpr @@ -111,6 +130,8 @@ insertTypeSubsts (id_subst, tv_subst, co_subst) xtys = (id_subst, extendVarEnvLi insertCoercionSubst :: Renaming - CoVar - Out Coercion - Renaming insertCoercionSubst (id_subst, tv_subst, co_subst) x co' = (id_subst, tv_subst, extendVarEnv co_subst x co') +-- NB: these three function can supply emptyInScopeSet because of what I do in splitSubst + renameId :: Renaming - Id - Out Id renameId rn = coreSynToVar . lookupIdSubst (text renameId) (joinSubst emptyInScopeSet rn) @@ -148,17 +169,17 @@ renameIn f (rn, x) = f rn x renameBinders :: InScopeSet - Renaming - [Var] - (InScopeSet, Renaming, [Var]) renameBinders iss rn xs = (iss', rn', xs') where (subst', xs') = substRecBndrs (joinSubst iss rn) xs -(iss', rn') = splitSubst subst' +(iss', rn') = splitSubst subst' (xs `zip` xs') renameNonRecBinder :: InScopeSet - Renaming - Var - (InScopeSet, Renaming, Var) renameNonRecBinder iss rn x = (iss', rn', x') where (subst', x') = substBndr (joinSubst iss rn) x -(iss', rn') = splitSubst subst' +(iss', rn') = splitSubst subst' [(x, x')] renameNonRecBinders :: InScopeSet - Renaming - [Var] - (InScopeSet, Renaming, [Var]) renameNonRecBinders iss rn xs = (iss', rn', xs') where (subst', xs') = substBndrs (joinSubst iss rn) xs -(iss', rn') = splitSubst subst' +(iss', rn') = splitSubst subst' (xs `zip` xs') renameBounds :: InScopeSet - Renaming - [(Var, a)] - (InScopeSet, Renaming, [(Var, In a)]) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Split DataAlt binder list, fix FV calculation, fix code generation for binder-term embedding (0bbb48c)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/0bbb48c2b0df6e694a2ecd5b6317495e4127c428 --- commit 0bbb48c2b0df6e694a2ecd5b6317495e4127c428 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 22 18:51:22 2011 +0100 Split DataAlt binder list, fix FV calculation, fix code generation for binder-term embedding compiler/supercompile/Supercompile.hs | 39 +- .../supercompile/Supercompile/Core/FreeVars.hs | 42 +-- .../supercompile/Supercompile/Core/Renaming.hs |7 ++- compiler/supercompile/Supercompile/Core/Syntax.hs | 31 ++ compiler/supercompile/Supercompile/Drive/Match.hs |6 +- .../supercompile/Supercompile/Drive/Process.hs | 15 +-- compiler/supercompile/Supercompile/Drive/Split.hs | 11 ++--- .../Supercompile/Evaluator/Evaluate.hs |8 +-- 8 files changed, 86 insertions(+), 73 deletions(-) Diff suppressed because of size. To see it, use: git show 0bbb48c2b0df6e694a2ecd5b6317495e4127c428 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Add comment about unfoldings (c43b42d)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/c43b42db0d47eca3ebc98954d8ada3870566f29e --- commit c43b42db0d47eca3ebc98954d8ada3870566f29e Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 15 23:42:27 2011 +0100 Add comment about unfoldings --- .../Supercompile/Evaluator/Evaluate.hs |1 + 1 files changed, 1 insertions(+), 0 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index 0882d9e..8396207 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -125,6 +125,7 @@ step' normalising state = -- Deal with a variable at the top of the stack -- Might have to claim deeds if inlining a non-value non-internally-bound thing here +-- FIXME: look inside unfoldings force :: Deeds - Heap - Stack - Tag - Out Var - Maybe UnnormalisedState force deeds (Heap h ids) k tg x' -- NB: inlining values is non-normalising if dUPLICATE_VALUES_EVALUATOR is on (since doing things the long way would involve executing an update frame) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Checkpoint better FV calculation in splitter (ce15491)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/ce1549153f8a8726143f50cc813816e7d945133d --- commit ce1549153f8a8726143f50cc813816e7d945133d Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 22 21:34:01 2011 +0100 Checkpoint better FV calculation in splitter .../supercompile/Supercompile/Core/FreeVars.hs | 22 --- .../supercompile/Supercompile/Drive/Process.hs |4 +- compiler/supercompile/Supercompile/Drive/Split.hs | 14 +++- 3 files changed, 24 insertions(+), 16 deletions(-) Diff suppressed because of size. To see it, use: git show ce1549153f8a8726143f50cc813816e7d945133d ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix positive information propagation (931de9f)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/931de9fd9d57302f6137e459903702076c8794fe
---
commit 931de9fd9d57302f6137e459903702076c8794fe
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Mon Jun 27 14:41:15 2011 +0100
Fix positive information propagation
---
compiler/supercompile/Supercompile/Drive/Split.hs |9 ++---
1 files changed, 6 insertions(+), 3 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs
b/compiler/supercompile/Supercompile/Drive/Split.hs
index dfb9e1d..ea0d788 100644
--- a/compiler/supercompile/Supercompile/Drive/Split.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split.hs
@@ -148,13 +148,16 @@ mkEnteredEnv ent = mapVarEnv (const ent)
-- This fixed point ensures we bind those h-functions that have as free
variables any h-functions we are about to bind.
+qaScruts :: Anned QA - [Out Var]
+qaScruts qa = case annee qa of Question x' - [x']; Answer _ - []
+
{-# INLINE split #-}
split :: MonadStatics m
= State
- (State - m (Deeds, Out FVedTerm))
- m (Deeds, Out FVedTerm)
split (deeds, Heap h ids, k, qa) opt
- = generaliseSplit opt splitterUniqSupply (IS.empty, emptyVarSet) deeds (Heap
h ids, [0..] `zip` k, \ids - (case annee qa of Question x' - [x']; Answer _
- [], splitQA ids (annee qa)))
+ = generaliseSplit opt splitterUniqSupply (IS.empty, emptyVarSet) deeds (Heap
h ids, [0..] `zip` k, \ids - (qaScruts qa, splitQA ids (annee qa)))
{-# INLINE generalise #-}
generalise :: MonadStatics m
@@ -202,7 +205,7 @@ generalise gen (deeds, Heap h ids, k, qa) = do
pprTrace generalise (ppr (gen_kfs, gen_kfs, gen_xs', gen_xs')) $
return ()
let (ctxt_id, ctxt_ids) = takeUniqFromSupply splitterUniqSupply
-return $ \opt - generaliseSplit opt ctxt_ids (gen_kfs, gen_xs') deeds
(Heap h ids, named_k, \ids - ([], oneBracketed (Once ctxt_id, denormalise (0,
Heap M.empty ids, [], qa
+return $ \opt - generaliseSplit opt ctxt_ids (gen_kfs, gen_xs') deeds
(Heap h ids, named_k, \ids - (qaScruts qa, oneBracketed (Once ctxt_id,
denormalise (0, Heap M.empty ids, [], qa
{-# INLINE generaliseSplit #-}
generaliseSplit :: MonadStatics m
@@ -949,7 +952,7 @@ splitStackFrame ctxt_ids ids kf scruts bracketed_hole
-- ===
-- case x of C - let unk = C; z = C in ...
alt_in_es = alt_rns `zip` alt_es
-alt_hs = zipWith4 (\alt_rn alt_con alt_bvs alt_tg - M.fromList
[(x, lambdaBound) | x - x':alt_bvs] `M.union` M.fromList (do { Just scrut_v -
[altConToValue alt_con]; scrut_e - [annedTerm alt_tg (Value scrut_v)]; scrut
- scruts; return (scrut, HB (howToBindCheap scrut_e) (Right (alt_rn,
scrut_e))) })) alt_rns alt_cons alt_bvss (map annedTag alt_es) -- NB: don't
need to grab deeds for these just yet, due to the funny contract for
transitiveInline
+alt_hs = zipWith4 (\alt_rn alt_con alt_bvs alt_tg - M.fromList
[(x, lambdaBound) | x - alt_bvs] `M.union` M.fromList (do { Just scrut_v -
[altConToValue alt_con]; scrut_e - [annedTerm alt_tg (Value scrut_v)]; scrut
- (x':scruts); return (scrut, HB (howToBindCheap scrut_e) (Right (alt_rn,
scrut_e))) })) alt_rns alt_cons alt_bvss (map annedTag alt_es) -- NB: don't
need to grab deeds for these just yet, due to the funny contract for
transitiveInline
alt_bvss = map altConBoundVars alt_cons'
bracketed_alts = zipWith3 (\alt_h alt_ids alt_in_e - oneBracketed
(Once ctxt_id, (0, Heap alt_h alt_ids, [], alt_in_e))) alt_hs alt_idss alt_in_es
StrictLet x' in_e - zipBracketeds (\[e_hole, e_body] - let_ x' e_hole
e_body) (\[fvs_hole, fvs_body] - fvs_hole `unionVarSet` fvs_body) [[], [x']]
(\[_tails_hole, tails_body] - tails_body) [bracketed_hole, oneBracketed (Once
ctxt_id, (0, Heap (M.singleton x' lambdaBound) ids, [], in_e))]
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Match types whenever we match Ids: SC now loops because we don't type-abstract enough (f500206)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/f5002061d63e7d4815adc3add5cdd74d398da209 --- commit f5002061d63e7d4815adc3add5cdd74d398da209 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 22 22:38:34 2011 +0100 Match types whenever we match Ids: SC now loops because we don't type-abstract enough compiler/supercompile/Supercompile/Drive/Match.hs | 36 +++- 1 files changed, 20 insertions(+), 16 deletions(-) Diff suppressed because of size. To see it, use: git show f5002061d63e7d4815adc3add5cdd74d398da209 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fixed some missed type renaming in the evaluator primop case (93be0d5)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/93be0d5f8a94bebe11166b944107ee955f4c0248
---
commit 93be0d5f8a94bebe11166b944107ee955f4c0248
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Thu Jun 23 11:45:03 2011 +0100
Fixed some missed type renaming in the evaluator primop case
---
.../Supercompile/Evaluator/Evaluate.hs | 12 ++--
1 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index a66b892..ccd8d86 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -25,8 +25,8 @@ import DataCon
import Pair
-evaluatePrim :: Tag - PrimOp - [Type] - [Answer] - Maybe (Anned Answer)
-evaluatePrim tg pop tys args = do
+evaluatePrim :: InScopeSet - Tag - PrimOp - [Type] - [Answer] - Maybe
(Anned Answer)
+evaluatePrim iss tg pop tys args = do
args' - fmap (map CoreSyn.Type tys ++) $ mapM to args
(res:_) - return [res | CoreSyn.BuiltinRule { CoreSyn.ru_nargs = nargs,
CoreSyn.ru_try = f }
- primOpRules pop (error evaluatePrim: dummy
primop name)
@@ -38,7 +38,7 @@ evaluatePrim tg pop tys args = do
to (mb_co, (rn, v)) = fmap (maybe id (flip CoreSyn.Cast . fst) mb_co) $
case v of
Literal l - Just (CoreSyn.Lit l)
Coercion co- Just (CoreSyn.Coercion co)
-Data dc tys xs - Just (CoreSyn.Var (dataConWrapId dc)
`CoreSyn.mkTyApps` tys `CoreSyn.mkVarApps` map (renameId rn) xs)
+Data dc tys xs - Just (CoreSyn.Var (dataConWrapId dc)
`CoreSyn.mkTyApps` map (renameType iss rn) tys `CoreSyn.mkVarApps` map
(renameId rn) xs)
_ - Nothing
fro :: CoreSyn.CoreExpr - Maybe Answer
@@ -262,14 +262,14 @@ step' normalising state =
-- NB: we add the *non-dereferenced* value to
the heap for a case wildcard, because anything else may duplicate allocation
primop :: Deeds - Tag - Heap - Stack - Tag - PrimOp - [Out Type]
- [Anned Answer] - Answer - [In AnnedTerm] - Maybe UnnormalisedState
-primop deeds tg_kf h k tg_a pop tys' anned_as a [] = do
+primop deeds tg_kf heap@(Heap _ ids) k tg_a pop tys' anned_as a [] = do
guard eVALUATE_PRIMOPS -- NB: this is not faithful to paper 1
because we still turn primop expressions into
-- stack frames.. this is bad because it
will impede good specilations (without smart generalisation)
let as' = map (dereference h) $ map annee anned_as ++ [a]
tg_kf' = tg_kf { tagOccurrences = if oCCURRENCE_GENERALISATION
then tagOccurrences tg_kf + sum (map tagOccurrences (tg_a : map annedTag
anned_as)) else 1 }
-a' - evaluatePrim tg_kf' pop tys' as'
+a' - evaluatePrim ids tg_kf' pop tys' as'
deeds - claimDeeds (deeds + sum (map annedSize anned_as) +
answerSize' a + 1) (annedSize a') -- I don't think this can ever fail
-return (denormalise (deeds, h, k, fmap Answer a'))
+return (denormalise (deeds, heap, k, fmap Answer a'))
primop deeds tg_kf h k tg_a pop tys' anned_as a in_es = case in_es of
(in_e:in_es) - Just (deeds, h, Tagged tg_kf (PrimApply pop tys'
(anned_as ++ [annedAnswer tg_a a]) in_es) : k, in_e)
[] - Nothing
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Comment only (498cb10)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/498cb10a411da0a1224f18018bf3ed0053180dab --- commit 498cb10a411da0a1224f18018bf3ed0053180dab Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 11:30:54 2011 +0100 Comment only --- compiler/supercompile/Supercompile/Utilities.hs |2 ++ 1 files changed, 2 insertions(+), 0 deletions(-) diff --git a/compiler/supercompile/Supercompile/Utilities.hs b/compiler/supercompile/Supercompile/Utilities.hs index a02b5ca..a8f02df 100644 --- a/compiler/supercompile/Supercompile/Utilities.hs +++ b/compiler/supercompile/Supercompile/Utilities.hs @@ -75,6 +75,8 @@ instance (Ord1 f, Ord a) = Ord (Wrapper1 f a) where compare = compare1 `on` unWrapper1 +-- Because we have this class, we can define Outputable for +-- Supercompile.Core.Syntax.TermF without UndecidableInstances class Outputable1 f where pprPrec1 :: Outputable a = Rational - f a - SDoc ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Only bind exported things into the big tuple (6f6463a)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/6f6463a2c34435ab8a5630a19381555bade10c9e --- commit 6f6463a2c34435ab8a5630a19381555bade10c9e Author: Max Bolingbroke batterseapo...@hotmail.com Date: Mon Jun 27 14:54:53 2011 +0100 Only bind exported things into the big tuple --- compiler/supercompile/Supercompile.hs | 10 +++--- 1 files changed, 7 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index a4fa494..d40b412 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -12,7 +12,7 @@ import DataCon(dataConWorkId, dataConAllTyVars, dataConRepArgTys) import VarSet import Name (localiseName) import Var(Var, isTyVar, varName, setVarName) -import Id (mkSysLocal, mkSysLocalM, realIdUnfolding, isPrimOpId_maybe, isDataConWorkId_maybe, setIdNotExported) +import Id (mkSysLocal, mkSysLocalM, realIdUnfolding, isPrimOpId_maybe, isDataConWorkId_maybe, setIdNotExported, isExportedId) import MkId (mkPrimOpId) import MkCore (mkBigCoreVarTup, mkTupleSelector, mkWildValBinder) import FastString (mkFastString, fsLit) @@ -144,7 +144,7 @@ termToCoreExpr = term coreBindsToCoreTerm :: [CoreBind] - (CoreExpr, CoreExpr - [CoreBind]) coreBindsToCoreTerm binds = (mkLets internal_binds (mkBigCoreVarTup internal_xs), - \e - let wild_id = mkWildValBinder (exprType e) in [NonRec x (mkTupleSelector internal_xs internal_x wild_id e) | (x, internal_x) - xs `zip` internal_xs]) + \e - let wild_id = mkWildValBinder (exprType e) in [NonRec x (mkTupleSelector internal_xs internal_x wild_id e) | (x, internal_x) - xs_internal_xs]) where -- This is a sweet hack. Most of the top-level binders will be External names. It is a Bad Idea to locally-bind -- an External name, because several Externals with the same name but different uniques will generate clashing @@ -154,11 +154,15 @@ coreBindsToCoreTerm binds -- Note that we leave the *use sites* totally intact: we rely on the fact that a) variables are compared only by -- unique and b) the internality of these names will be carried down on the next simplifier run, so this works. -- The ice is thin, though! +-- +-- As an added twist, we only need to put *exported* Ids into the tuple we construct/deconstruct as part of this +-- transformation. This allows the supercompiler to determine that more things are used linearly. xs = bindersOfBinds binds internal_binds = [case bind of NonRec x e - NonRec (localiseVar x) e Rec xes- Rec (map (first localiseVar) xes) | bind - binds] -internal_xs = bindersOfBinds internal_binds +xs_internal_xs = filter (\(x, _) - isExportedId x) (xs `zip` bindersOfBinds internal_binds) +internal_xs = map snd xs_internal_xs localiseVar x = setIdNotExported (x `setVarName` localiseName (varName x)) -- If we don't mark these Ids as not exported then we get lots of residual top-level bindings of the form x = y ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Remove my generalisation of VarEn (0bbe9d7)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/0bbe9d73619425cbe40c1737d21bf23e01ab7591
---
commit 0bbe9d73619425cbe40c1737d21bf23e01ab7591
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Jun 29 17:19:31 2011 +0100
Remove my generalisation of VarEn
---
compiler/basicTypes/VarEnv.lhs | 27 +++
1 files changed, 11 insertions(+), 16 deletions(-)
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index 0529e86..cdd79f5 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -36,7 +36,7 @@ module VarEnv (
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, lookupInScope_Directly,
-unionInScope, elemInScopeSet, uniqAway, uniqAwayByKey,
+unionInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type
RnEnv2,
@@ -141,32 +141,27 @@ unionInScope (InScope s1 _) (InScope s2 n2)
-- | @uniqAway in_scope v@ finds a unique that is not used in the
-- in-scope set, and gives that to v.
uniqAway :: InScopeSet - Var - Var
-uniqAway iss var = setVarUnique var (uniqAwayByKey iss (getUnique var))
-
-uniqAway' :: InScopeSet - Var - Var
-uniqAway' iss var = setVarUnique var (uniqAwayByKey' iss (getUnique var))
-
-uniqAwayByKey :: InScopeSet - Unique - Unique
-- It starts with v's current unique, of course, in the hope that it won't
-- have to change, and thereafter uses a combination of that and the hash-code
-- found in the in-scope set
-uniqAwayByKey in_scope@(InScope set _n) var
- | var `elemVarSetByKey` set = uniqAwayByKey' in_scope var -- Make a new one
- | otherwise = var -- Nothing to do
+uniqAway in_scope var
+ | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new
one
+ | otherwise= var -- Nothing to do
-uniqAwayByKey' :: InScopeSet - Unique - Unique
+uniqAway' :: InScopeSet - Var - Var
-- This one *always* makes up a new variable
-uniqAwayByKey' (InScope set n) orig_unique
+uniqAway' (InScope set n) var
= try (_ILIT(1))
where
+orig_unique = getUnique var
try k
| debugIsOn (k # _ILIT(1000))
- = pprPanic uniqAway loop: (ppr (iBox k) + text tries + ppr
orig_unique + int (iBox n))
+ = pprPanic uniqAway loop: (ppr (iBox k) + text tries + ppr
var + int (iBox n))
| uniq `elemVarSetByKey` set = try (k +# _ILIT(1))
| debugIsOn opt_PprStyle_Debug (k # _ILIT(3))
- = pprTrace uniqAway: (ppr (iBox k) + text tries + ppr
orig_unique + int (iBox n))
- uniq
- | otherwise = uniq
+ = pprTrace uniqAway: (ppr (iBox k) + text tries + ppr var +
int (iBox n))
+ setVarUnique var uniq
+ | otherwise = setVarUnique var uniq
where
uniq = deriveUnique orig_unique (iBox (n *# k))
\end{code}
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Only expose unfoldings visible in phase 2 (a4658d9)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/a4658d9a841d3bd891c15addfc3e2dfa29382f81 --- commit a4658d9a841d3bd891c15addfc3e2dfa29382f81 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 10:58:36 2011 +0100 Only expose unfoldings visible in phase 2 --- compiler/supercompile/Supercompile.hs | 13 - 1 files changed, 12 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index d40b412..cc74204 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -6,13 +6,14 @@ import qualified Supercompile.Core.FreeVars as S import qualified Supercompile.Evaluator.Syntax as S import qualified Supercompile.Drive.Process as S +import BasicTypes (InlinePragma(..), InlineSpec(..), isActiveIn) import CoreSyn import CoreUtils (exprType) import DataCon(dataConWorkId, dataConAllTyVars, dataConRepArgTys) import VarSet import Name (localiseName) import Var(Var, isTyVar, varName, setVarName) -import Id (mkSysLocal, mkSysLocalM, realIdUnfolding, isPrimOpId_maybe, isDataConWorkId_maybe, setIdNotExported, isExportedId) +import Id (mkSysLocal, mkSysLocalM, realIdUnfolding, idInlinePragma, isPrimOpId_maybe, isDataConWorkId_maybe, setIdNotExported, isExportedId) import MkId (mkPrimOpId) import MkCore (mkBigCoreVarTup, mkTupleSelector, mkWildValBinder) import FastString (mkFastString, fsLit) @@ -178,11 +179,21 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] , Just e - [varUnfolding x]] varUnfolding x + | not (shouldExposeUnfolding x) = Nothing | Just pop - isPrimOpId_maybe x = Just $ primOpUnfolding pop | Just dc - isDataConWorkId_maybe x = Just $ dataUnfolding dc | otherwise = fmap coreExprToTerm $ maybeUnfoldingTemplate (realIdUnfolding x) -- NB: it's OK if the unfolding is a non-value, as the evaluator won't inline LetBound non-values +-- We don't want to expose an unfoldingif it would not be inlineable in the initial phase. +-- This gives normal RULES more of a chance to fire. +shouldExposeUnfolding x = case inl_inline inl_prag of +Inline - True +Inlinable - True +NoInline- isActiveIn 2 (inl_act inl_prag) +EmptyInlineSpec - True + where inl_prag = idInlinePragma x + primOpUnfolding pop = S.tyLambdas as $ S.lambdas xs $ S.primOp pop (map mkTyVarTy as) (map S.var xs) where (as, arg_tys, _res_ty, _arity, _strictness) = primOpSig pop xs = zipWith (mkSysLocal (fsLit x)) bv_uniques arg_tys ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Cleanup code outside supercompiler directory (88b7f83)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/88b7f83f42bab191d17024fc90890e3c9183c33c --- commit 88b7f83f42bab191d17024fc90890e3c9183c33c Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 11:06:44 2011 +0100 Cleanup code outside supercompiler directory --- compiler/main/GHC.hs |2 -- 1 files changed, 0 insertions(+), 2 deletions(-) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 6ed..92ee0f4 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -257,8 +257,6 @@ import BreakArray import InteractiveEval #endif -import Supercompile () -- FIXME: remove this. Just used to pull it in - import HscMain import GhcMake import DriverPipeline ( compile' ) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Totally rewrite matcher: detect rigid binder inequality earlier (f209ed7)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/f209ed7ac7b40ca448d3e1d9f689d49393bb47c5 --- commit f209ed7ac7b40ca448d3e1d9f689d49393bb47c5 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Tue Jun 28 23:35:17 2011 +0100 Totally rewrite matcher: detect rigid binder inequality earlier compiler/supercompile/Supercompile/Drive/Match.hs | 444 +++-- compiler/supercompile/Supercompile/Utilities.hs |5 + 2 files changed, 228 insertions(+), 221 deletions(-) Diff suppressed because of size. To see it, use: git show f209ed7ac7b40ca448d3e1d9f689d49393bb47c5 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Initial cut of plugin functionality. Plugin likely won't build (7ccd6ea)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/7ccd6ea82257d734246e67cb1825ec9dba5cd1d1 --- commit 7ccd6ea82257d734246e67cb1825ec9dba5cd1d1 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 18:38:37 2011 +0100 Initial cut of plugin functionality. Plugin likely won't build compiler/simplCore/SimplCore.lhs|2 +- compiler/supercompile/CHSC.hs | 42 +++ compiler/supercompile/Supercompile.hs | 67 ++- compiler/supercompile/chsc-plugin.cabal | 40 ++ 4 files changed, 131 insertions(+), 20 deletions(-) Diff suppressed because of size. To see it, use: git show 7ccd6ea82257d734246e67cb1825ec9dba5cd1d1 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Stop building a ridiculous loop in the matcher (7bff7ac)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/7bff7ac4a077f43460d9c32a1a94e02555a2faab --- commit 7bff7ac4a077f43460d9c32a1a94e02555a2faab Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 00:12:35 2011 +0100 Stop building a ridiculous loop in the matcher --- compiler/supercompile/Supercompile/Drive/Match.hs | 29 +++-- 1 files changed, 15 insertions(+), 14 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Match.hs b/compiler/supercompile/Supercompile/Drive/Match.hs index 05043cf..5dc9bb0 100644 --- a/compiler/supercompile/Supercompile/Drive/Match.hs +++ b/compiler/supercompile/Supercompile/Drive/Match.hs @@ -64,9 +64,10 @@ match :: State -- ^ Tieback semantics match s_l@(_deeds_l, Heap h_l _, k_l, qa_l) s_r@(_deeds_r, Heap h_r _, k_r, qa_r) = -- (\res - traceRender (match, M.keysSet h_l, residualiseDriveState (Heap h_l prettyIdSupply, k_l, in_e_l), M.keysSet h_r, residualiseDriveState (Heap h_r prettyIdSupply, k_r, in_e_r), res) res) $ runMatch $ do let init_rn2 = matchRnEnv2 stateFreeVars s_l s_r -(rn2, free_eqs2) - mfix $ \(~(rn2, _)) - matchEC init_rn2 rn2 k_l k_r -free_eqs1 - matchAnned (matchQA rn2) qa_l qa_r -matchPureHeap rn2 (free_eqs1 ++ free_eqs2) h_l h_r = safeMkMatchResult +(rn2, mfree_eqs2) - mfix $ \(~(rn2, _)) - matchEC init_rn2 rn2 k_l k_r +free_eqs1 - pprTrace match0 (rn2 `seq` empty) $ matchAnned (matchQA rn2) qa_l qa_r +free_eqs2 - pprTrace match1 empty $ mfree_eqs2 +pprTrace match2 (ppr free_eqs1) $ matchPureHeap rn2 (free_eqs1 ++ free_eqs2) h_l h_r = safeMkMatchResult matchAnned :: (a - a - b) - Anned a - Anned a - b @@ -205,20 +206,20 @@ matchIn :: (InScopeSet - Renaming - a - a) matchIn rnm mtch rn2 (rn_l, x_l) (rn_r, x_r) = mtch rn2 (rnm iss rn_l x_l) (rnm iss rn_r x_r) where iss = rnInScopeSet rn2 -- NB: this line is the only thing that relies on the RnEnv2 InScopeSet being correct -matchEC :: RnEnv2 - RnEnv2 - Stack - Stack - Match (RnEnv2, [(Var, Var)]) -matchEC init_rn2 rn2 k_l k_r = foldZipEqualM (\(init_rn2', eqs) kf_l kf_r - fmap (\(init_rn2'', extra_eqs) - (init_rn2'', extra_eqs ++ eqs)) $ matchECFrame init_rn2' rn2 kf_l kf_r) (init_rn2, []) k_l k_r +matchEC :: RnEnv2 - RnEnv2 - Stack - Stack - Match (RnEnv2, Match [(Var, Var)]) +matchEC init_rn2 rn2 k_l k_r = foldZipEqualM (\(init_rn2', meqs) kf_l kf_r - fmap (second (liftM2 (++) meqs)) $ matchECFrame init_rn2' rn2 kf_l kf_r) (init_rn2, return []) k_l k_r -matchECFrame :: RnEnv2 - RnEnv2 - Tagged StackFrame - Tagged StackFrame - Match (RnEnv2, [(Var, Var)]) +matchECFrame :: RnEnv2 - RnEnv2 - Tagged StackFrame - Tagged StackFrame - Match (RnEnv2, Match [(Var, Var)]) matchECFrame init_rn2 rn2 kf_l kf_r = go (tagee kf_l) (tagee kf_r) where -go :: StackFrame - StackFrame - Match (RnEnv2, [(Var, Var)]) -go (Apply x_l') (Apply x_r') = fmap ((,) init_rn2) $ matchVar rn2 x_l' x_r' -go (TyApply ty_l') (TyApply ty_r') = fmap ((,) init_rn2) $ matchType rn2 ty_l' ty_r' -go (Scrutinise x_l' ty_l' in_alts_l) (Scrutinise x_r' ty_r' in_alts_r) = fmap ((,) init_rn2) $ liftM2 (++) (matchType rn2 ty_l' ty_r') (matchIdCoVarBndr rn2 x_l' x_r' $ \rn2 - matchIn renameAnnedAlts matchAlts rn2 in_alts_l in_alts_r) -go (PrimApply pop_l tys_l' as_l in_es_l) (PrimApply pop_r tys_r' as_r in_es_r) = fmap ((,) init_rn2) $ guard matchECFrame: primop (pop_l == pop_r) liftM3 (\x y z - x ++ y ++ z) (matchList (matchType rn2) tys_l' tys_r') (matchList (matchAnned (matchAnswer rn2)) as_l as_r) (matchList (matchIn renameAnnedTerm matchTerm rn2) in_es_l in_es_r) -go (StrictLet x_l' in_e_l) (StrictLet x_r' in_e_r) = fmap ((,) init_rn2) $ matchIdCoVarBndr rn2 x_l' x_r' $ \rn2 - matchIn renameAnnedTerm matchTerm rn2 in_e_l in_e_r -go (CastIt co_l')(CastIt co_r') = fmap ((,) init_rn2) $ matchCoercion rn2 co_l' co_r' -go (Update x_l') (Update x_r') = fmap ((,) (rnBndr2 rn2 x_l' x_r')) $ matchType rn2 (idType x_l') (idType x_r') +go :: StackFrame - StackFrame - Match (RnEnv2, Match [(Var, Var)]) +go (Apply x_l') (Apply x_r') = return (init_rn2, matchVar rn2 x_l' x_r') +go (TyApply ty_l') (TyApply ty_r') = return (init_rn2, matchType rn2 ty_l' ty_r') +go (Scrutinise x_l' ty_l' in_alts_l) (Scrutinise x_r' ty_r' in_alts_r) = return (init_rn2, liftM2 (++) (matchType rn2 ty_l' ty_r') (matchIdCoVarBndr rn2 x_l' x_r' $ \rn2 - matchIn renameAnnedAlts matchAlts
[commit: ghc] supercompiler: Add instances for non-1 variants derived from 1 variants, remove some uses of PrettyFunction and Wrapper1 (192e207)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/192e207857c0fdd4731089f4413ce4d122e023ff --- commit 192e207857c0fdd4731089f4413ce4d122e023ff Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 11:29:58 2011 +0100 Add instances for non-1 variants derived from 1 variants, remove some uses of PrettyFunction and Wrapper1 .../supercompile/Supercompile/Core/FreeVars.hs |9 compiler/supercompile/Supercompile/Core/Syntax.hs |5 +-- .../Supercompile/Evaluator/Residualise.hs |6 +- .../supercompile/Supercompile/Evaluator/Syntax.hs | 14 +++--- compiler/supercompile/Supercompile/Utilities.hs| 48 5 files changed, 68 insertions(+), 14 deletions(-) Diff suppressed because of size. To see it, use: git show 192e207857c0fdd4731089f4413ce4d122e023ff ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Don't lose deeds when the evaluator builds a term from a bare Var (ffa5c71)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ffa5c713527084a208ac254b0a7e067170bc68a5
---
commit ffa5c713527084a208ac254b0a7e067170bc68a5
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Jul 27 19:19:52 2011 +0100
Don't lose deeds when the evaluator builds a term from a bare Var
---
compiler/supercompile/Supercompile/Core/Size.hs| 24 +++
.../Supercompile/Evaluator/Evaluate.hs |2 +-
.../supercompile/Supercompile/Evaluator/Syntax.hs |4 ---
3 files changed, 10 insertions(+), 20 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Core/Size.hs
b/compiler/supercompile/Supercompile/Core/Size.hs
index 3b2d050..a2e1ba4 100644
--- a/compiler/supercompile/Supercompile/Core/Size.hs
+++ b/compiler/supercompile/Supercompile/Core/Size.hs
@@ -19,30 +19,27 @@ type TaggedSizedFVedAlt = AltF (O Tagged (O Sized FVed))
type TaggedSizedFVedValue = ValueF (O Tagged (O Sized FVed))
-(varSize',termSize,termSize',
altsSize,valueSize,valueSize')=
mkSize (\f (I e) - f e)
-(fvedVarSize',fvedTermSize,fvedTermSize',
fvedAltsSize,fvedValueSize,fvedValueSize')=
mkSize (\f (FVed _ e) - f e)
-(sizedVarSize', sizedTermSize, sizedTermSize',
sizedAltsSize, sizedValueSize, sizedValueSize') =
mkSize (\_ (Sized sz _) - sz)
-(sizedFVedVarSize', sizedFVedTermSize, sizedFVedTermSize',
sizedFVedAltsSize, sizedFVedValueSize, sizedFVedValueSize') =
mkSize (\_ (Comp (Sized sz (FVed _ _))) - sz)
-(taggedSizedFVedVarSize', taggedSizedFVedTermSize, taggedSizedFVedTermSize',
taggedSizedFVedAltsSize, taggedSizedFVedValueSize, taggedSizedFVedValueSize') =
mkSize (\_ (Comp (Tagged _ (Comp (Sized sz (FVed _ _) - sz)
+(termSize,termSize',altsSize,
valueSize,valueSize')= mkSize (\f (I e) - f e)
+(fvedTermSize,fvedTermSize',fvedAltsSize,
fvedValueSize,fvedValueSize')= mkSize (\f (FVed _ e) -
f e)
+(sizedTermSize, sizedTermSize', sizedAltsSize,
sizedValueSize, sizedValueSize') = mkSize (\_ (Sized sz _)
- sz)
+(sizedFVedTermSize, sizedFVedTermSize', sizedFVedAltsSize,
sizedFVedValueSize, sizedFVedValueSize') = mkSize (\_ (Comp (Sized
sz (FVed _ _))) - sz)
+(taggedSizedFVedTermSize, taggedSizedFVedTermSize', taggedSizedFVedAltsSize,
taggedSizedFVedValueSize, taggedSizedFVedValueSize') = mkSize (\_ (Comp (Tagged
_ (Comp (Sized sz (FVed _ _) - sz)
{-# INLINE mkSize #-}
mkSize :: (forall a. (a - Size) - ann a - Size)
- - (Var - Size,
- ann (TermF ann) - Size,
+ - (ann (TermF ann) - Size,
TermF ann- Size,
[AltF ann] - Size,
ann (ValueF ann) - Size,
ValueF ann - Size)
-mkSize rec = (var', term, term', alternatives, value, value')
+mkSize rec = (term, term', alternatives, value, value')
where
-var' = const 0
-
term = rec term'
term' e = 1 + case e of
-Var x - var' x
+Var _ - 0
Value v - value' v - 1 -- Slight hack here so that we don't
get +2 size on values
TyApp e _ - term e
-App e x - term e + var' x
+App e _ - term e
PrimOp _ _ es - sum (map term es)
Case e _ _ alts - term e + alternatives alts
Let _ e1 e2 - term e1 + term e2
@@ -74,9 +71,6 @@ instance Symantics (O Sized FVed) where
letRec xes = sizedFVedTerm . LetRec xes
cast e = sizedFVedTerm . Cast e
-sizedFVedVar :: Var - (O Sized FVed) Var
-sizedFVedVar x = Comp (Sized (sizedFVedVarSize' x) (FVed
(sizedFVedVarFreeVars' x) x))
-
sizedFVedValue :: SizedFVedValue - (O Sized FVed) SizedFVedValue
sizedFVedValue v = Comp (Sized (sizedFVedValueSize' v) (FVed
(sizedFVedValueFreeVars' v) v))
diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
index 5583ae3..77c8301 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -89,7 +89,7 @@ step' normalising state =
go (deeds, heap@(Heap h ids), k, (rn, e))
| Just anned_a - termToAnswer ids (rn, e) = go_answer (deeds, heap, k,
anned_a)
| otherwise = case annee e of
-Var x- go_question (deeds, heap, k, annedVar (annedTag e
[commit: ghc] : Fix construction of the initial heap from the unfoldings: FVs of unfoldings were not bound (71462ae)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/71462ae6b17b6fdd5ed87390894c0e5fb30c73a6 --- commit 71462ae6b17b6fdd5ed87390894c0e5fb30c73a6 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Jul 1 13:32:55 2011 +0100 Fix construction of the initial heap from the unfoldings: FVs of unfoldings were not bound --- .../supercompile/Supercompile/Drive/Process.hs | 31 +++ 1 files changed, 18 insertions(+), 13 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index e56c40b..2ea0870 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -89,19 +89,24 @@ instance Monoid SCStats where supercompile :: M.Map Var Term - Term - (SCStats, Term) -supercompile unfoldings e = pprTraceSC all input FVs (ppr input_fvs) $ second fVedTermToTerm $ runScpM $ liftM snd $ sc (mkHistory (cofmap fst wQO)) S.empty state - where anned_e = toAnnedTerm tag_ids e -input_fvs = annedTermFreeVars anned_e -state = normalise ((bLOAT_FACTOR - 1) * annedSize anned_e, Heap (M.fromDistinctAscList anned_h_kvs) (mkInScopeSet input_fvs), [], (mkIdentityRenaming input_fvs, anned_e)) - -(tag_ids, anned_h_kvs) = mapAccumL add_one_heap_binding tagUniqSupply (varSetElems input_fvs) - where add_one_heap_binding tag_ids0 x' = (tag_ids2, (x', hb)) - where (hb, tag_ids2) = case M.lookup x' unfoldings of -Nothing | let (i, tag_ids1) = takeUniqFromSupply tag_ids0 -- (environmentallyBound (mkTag (getKey i)), tag_ids1) -Just e | let (tag_unf_ids, tag_ids1) = splitUniqSupply tag_ids0 - anned_e = toAnnedTerm tag_unf_ids e -- (letBound (mkIdentityRenaming (annedFreeVars anned_e), anned_e), tag_ids1) +supercompile unfoldings e = pprTraceSC unfoldings (ppr (M.keys unfoldings)) $ +pprTraceSC all input FVs (ppr input_fvs) $ +second fVedTermToTerm $ runScpM $ liftM snd $ sc (mkHistory (cofmap fst wQO)) S.empty state + where (tag_ids0, tag_ids1) = splitUniqSupply tagUniqSupply +anned_e = toAnnedTerm tag_ids0 e + +((input_fvs, tag_ids2), h_unfoldings) = mapAccumL add_one_unfolding (annedTermFreeVars anned_e, tag_ids1) (M.toList unfoldings) + where add_one_unfolding (input_fvs', tag_ids1) (x', e) = ((input_fvs'', tag_ids2), (x', letBound (mkIdentityRenaming (annedFreeVars anned_e), anned_e))) +where (tag_unf_ids, tag_ids2) = splitUniqSupply tag_ids1 + anned_e = toAnnedTerm tag_unf_ids e + input_fvs'' = input_fvs' `unionVarSet` annedFreeVars anned_e + +(_, h_fvs) = mapAccumL add_one_fv tag_ids2 (varSetElems input_fvs) + where add_one_fv tag_ids2 x' = (tag_ids3, (x', environmentallyBound (mkTag (getKey i +where (i, tag_ids3) = takeUniqFromSupply tag_ids2 + +-- NB: h_fvs might contain bindings for things also in h_unfoldings, so union them in the right order +state = normalise ((bLOAT_FACTOR - 1) * annedSize anned_e, Heap (M.fromList h_unfoldings `M.union` M.fromList h_fvs) (mkInScopeSet input_fvs), [], (mkIdentityRenaming input_fvs, anned_e)) -- -- == Bounded multi-step reduction == ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Eliminate strings from assertions, since they pretty print like lists (6d92f39)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch :
http://hackage.haskell.org/trac/ghc/changeset/6d92f39fbfd2bb744160a82750433485290bad19
---
commit 6d92f39fbfd2bb744160a82750433485290bad19
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Fri Jul 1 13:33:13 2011 +0100
Eliminate strings from assertions, since they pretty print like lists
---
.../supercompile/Supercompile/Drive/Process.hs |4 ++--
compiler/supercompile/Supercompile/Drive/Split.hs | 12 ++--
2 files changed, 8 insertions(+), 8 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs
b/compiler/supercompile/Supercompile/Drive/Process.hs
index 2ea0870..64e6764 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -140,7 +140,7 @@ supercompile unfoldings e = pprTraceSC unfoldings (ppr
(M.keys unfoldings)) $
--
-- TODO: have the garbage collector collapse (let x = True in x) to (True) --
but note that this requires onceness analysis
gc :: State - (PureHeap, State)
-gc _state@(deeds0, Heap h ids, k, in_e) = ASSERT2(isEmptyVarSet
(stateUncoveredVars gced_state), ppr (gc, stateUncoveredVars gced_state,
PrettyDoc (pPrintFullState _state), PrettyDoc (pPrintFullState gced_state)))
+gc _state@(deeds0, Heap h ids, k, in_e) = ASSERT2(isEmptyVarSet
(stateUncoveredVars gced_state), ppr (stateUncoveredVars gced_state, PrettyDoc
(pPrintFullState _state), PrettyDoc (pPrintFullState gced_state)))
(h_dead, gced_state)
where
gced_state = (deeds2, Heap h' ids, k', in_e)
@@ -443,7 +443,7 @@ promise p x' opt = ScpM $ \e s k - {- traceRender
(promise, fun p, abstracted
in k () (s { fulfilments = fs' })
fmap (((abstracted_set `unionVarSet` stateLetBounders (unI (meaning p)))
`unionVarSet`) . mkVarSet) getPromiseNames =
-\fvs - ASSERT2(optimised_fvs `subVarSet` fvs, ppr (sc: FVs, fun p,
optimised_fvs `minusVarSet` fvs, fvs, optimised_e)) return ()
+\fvs - ASSERT2(optimised_fvs `subVarSet` fvs, ppr (fun p,
optimised_fvs `minusVarSet` fvs, fvs, optimised_e)) return ()
return (a, var (fun p) `tyVarIdApps` abstracted p)
diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs
b/compiler/supercompile/Supercompile/Drive/Split.hs
index ea0d788..f29aacc 100644
--- a/compiler/supercompile/Supercompile/Drive/Split.hs
+++ b/compiler/supercompile/Supercompile/Drive/Split.hs
@@ -171,11 +171,11 @@ generalise gen (deeds, Heap h ids, k, qa) = do
NoGeneralisation - Nothing
AllEligible - guard (not (IS.null gen_kfs) || not (isEmptyVarSet
gen_xs'')) return (gen_kfs, gen_xs'')
where gen_kfs = IS.fromList [i | (i, kf) - named_k,
generaliseStackFrame gen kf]
-gen_xs'' = mkVarSet [x'' | (x'', hb) - M.toList h,
generaliseHeapBinding gen x'' hb, ASSERT2(not (howBound hb == LambdaBound
isNothing (heapBindingTerm hb)), ppr (Bad generalisation, x'', hb,
heapBindingTag hb)) True]
+gen_xs'' = mkVarSet [x'' | (x'', hb) - M.toList h,
generaliseHeapBinding gen x'' hb, ASSERT2(not (howBound hb == LambdaBound
isNothing (heapBindingTerm hb)), ppr (x'', hb, heapBindingTag hb)) True]
StackFirst - (guard (not (IS.null gen_kfs)) return (gen_kfs,
emptyVarSet)) `mplus`
(guard (not (isEmptyVarSet gen_xs'')) return
(IS.empty, gen_xs''))
where gen_kfs = IS.fromList [i | (i, kf) - named_k,
generaliseStackFrame gen kf]
-gen_xs'' = mkVarSet [x'' | (x'', hb) - M.toList h,
generaliseHeapBinding gen x'' hb, ASSERT2(not (howBound hb == LambdaBound
isNothing (heapBindingTerm hb)), ppr (Bad generalisation, x'', hb,
heapBindingTag hb)) True]
+gen_xs'' = mkVarSet [x'' | (x'', hb) - M.toList h,
generaliseHeapBinding gen x'' hb, ASSERT2(not (howBound hb == LambdaBound
isNothing (heapBindingTerm hb)), ppr (x'', hb, heapBindingTag hb)) True]
DependencyOrder want_first - listToMaybe ((if want_first then id else
reverse) possibilities)
where -- We consider possibilities starting from the root of the
term -- i.e. the bottom of the stack.
-- This is motivated by how the interaction with subgraph
generalisation for TreeFlip/TreeSum.
@@ -195,14 +195,14 @@ generalise gen (deeds, Heap h ids, k, qa) = do
(pending_hbs, unreached_hbs') = M.partitionWithKey (\x'
_hb - x' `elemVarSet` (pending_xs' `unionVarSet` extra_pending_xs'))
unreached_hbs
gen_kf_is = IS.fromList [i | (i, kf) - pending_kfs,
generaliseStackFrame gen kf]
-gen_xs'' = mkVarSet [x'' | (x'', hb) - M.toList
pending_hbs, generaliseHeapBinding gen x'' hb, ASSERT2(not (howBound hb
[commit: ghc] : Fix build of plugin code, write script for installing it inplace (for testing) (8db5e67)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/8db5e6781ce9c0138a399e84abe57ced7152f24c --- commit 8db5e6781ce9c0138a399e84abe57ced7152f24c Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jun 29 19:03:21 2011 +0100 Fix build of plugin code, write script for installing it inplace (for testing) --- compiler/supercompile/.gitignore |2 ++ compiler/supercompile/CHSC.hs|6 -- compiler/supercompile/chsc-plugin.cabal | 13 +++-- compiler/supercompile/install-plugin-inplace |8 4 files changed, 25 insertions(+), 4 deletions(-) diff --git a/compiler/supercompile/.gitignore b/compiler/supercompile/.gitignore new file mode 100644 index 000..1c20c83 --- /dev/null +++ b/compiler/supercompile/.gitignore @@ -0,0 +1,2 @@ +# Ignore directory created by install-plugin-inplace +dist/ diff --git a/compiler/supercompile/CHSC.hs b/compiler/supercompile/CHSC.hs index 1063c4d..c617de8 100644 --- a/compiler/supercompile/CHSC.hs +++ b/compiler/supercompile/CHSC.hs @@ -3,7 +3,9 @@ module CHSC (Supercompile(..), plugin) where import Supercompile import GhcPlugins -import Data.List (nub) +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.List (nub) -- The supercomplier behaves as follows: @@ -33,7 +35,7 @@ pass unconditional guts = do should_sc - case unconditional of True - return (const True) False - do -anns - getFirstAnnotations deserializeWithData guts +anns :: UniqFM Supercompile - getFirstAnnotations deserializeWithData guts mod - getModule return $ if mod `elemUFM` anns then const True diff --git a/compiler/supercompile/chsc-plugin.cabal b/compiler/supercompile/chsc-plugin.cabal index a8b5a53..752a33b 100644 --- a/compiler/supercompile/chsc-plugin.cabal +++ b/compiler/supercompile/chsc-plugin.cabal @@ -35,6 +35,15 @@ Library Supercompile.Termination.TagBag Supercompile.Utilities Supercompile +Extensions: +CPP, +PatternGuards, +ExistentialQuantification, +ScopedTypeVariables, +FlexibleInstances, +RankNTypes, +DeriveDataTypeable Build-Depends: -base = 4, -ghc = 7.1 +base = 4.3 4.4, +containers = 0.4 0.5, +ghc = 7.1 7.2 diff --git a/compiler/supercompile/install-plugin-inplace b/compiler/supercompile/install-plugin-inplace new file mode 100755 index 000..d226fec --- /dev/null +++ b/compiler/supercompile/install-plugin-inplace @@ -0,0 +1,8 @@ +#!/bin/sh + +SCRIPT_DIR=$(cd $(dirname $0); pwd) +INPLACE_DIR=$SCRIPT_DIR/../../inplace + +# NB: this script relies on the installed Cabal (presumably from the bootstrapping compiler) +# actually understanding the package metadata used by the in-tree Cabal. Risky, but works for now. +cabal install --disable-library-profiling --user --with-ghc=$INPLACE_DIR/bin/ghc-stage2 --with-ghc-pkg=$INPLACE_DIR/bin/ghc-pkg --package-db=$INPLACE_DIR/lib/package.conf.d ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Rename free variables in annotation correctly in termToAnswer (e2b3fa1)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/e2b3fa1166ce440d426e7ebc6180df3a2bb30bdf --- commit e2b3fa1166ce440d426e7ebc6180df3a2bb30bdf Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jul 27 18:34:37 2011 +0100 Rename free variables in annotation correctly in termToAnswer --- .../supercompile/Supercompile/Evaluator/Syntax.hs | 12 +--- 1 files changed, 5 insertions(+), 7 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 466e7a0..515e8ca 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -42,6 +42,10 @@ annedFreeVars = freeVars . sizee . unComp . tagee . unComp annedTag :: Anned a - Tag annedTag = tag . unComp +renameAnned :: In (Anned a) - Anned (In a) +renameAnned (rn, Comp (Tagged tg (Comp (Sized sz (FVed fvs x) + = Comp (Tagged tg (Comp (Sized sz (FVed (renameFreeVars rn fvs) (rn, x) + annedVarFreeVars' = taggedSizedFVedVarFreeVars' annedTermFreeVars = taggedSizedFVedTermFreeVars @@ -95,7 +99,7 @@ answerFreeVars' :: Answer - FreeVars answerFreeVars' = annedTermFreeVars' . answerToAnnedTerm' emptyInScopeSet termToAnswer :: InScopeSet - In AnnedTerm - Maybe (Anned Answer) -termToAnswer iss (rn, anned_e) = flip traverse anned_e $ \e - case e of +termToAnswer iss in_anned_e = flip traverse (renameAnned in_anned_e) $ \(rn, e) - case e of Value v - Just (Nothing, (rn, v)) Cast anned_e' co - case extract anned_e' of Value v - Just (Just (renameCoercion iss rn co, annedTag anned_e'), (rn, v)) @@ -217,12 +221,6 @@ instance Outputable StackFrame where CastIt co' - pPrintPrecCast prec (PrettyDoc $ text [_]) co' -renameAnned :: (InScopeSet - Renaming - a - a) -- Anned (In a) - a -renameAnned rename in_x = x' - where (rn, x) = annee in_x -x' = rename (mkInScopeSet (annedFreeVars in_x)) rn x - stateType :: State - Type stateType (_, _, k, qa) = stackType k (qaType qa) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Fix subtle bug where annotated variable free variables would not be renamed (eb54295)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/eb54295530edb521ceca81dc06a0dce212010433 --- commit eb54295530edb521ceca81dc06a0dce212010433 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Jul 1 13:52:21 2011 +0100 Fix subtle bug where annotated variable free variables would not be renamed --- .../Supercompile/Evaluator/Evaluate.hs |2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index ed88d68..5583ae3 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -89,7 +89,7 @@ step' normalising state = go (deeds, heap@(Heap h ids), k, (rn, e)) | Just anned_a - termToAnswer ids (rn, e) = go_answer (deeds, heap, k, anned_a) | otherwise = case annee e of -Var x- go_question (deeds, heap, k, fmap (const (renameId rn x)) e) +Var x- go_question (deeds, heap, k, annedVar (annedTag e) (renameId rn x)) Value v - pprPanic step': values are always answers (ppr v) TyApp e ty - go (deeds, heap,Tagged tg (TyApply (renameType ids rn ty)) : k, (rn, e)) App e x - go (deeds, heap,Tagged tg (Apply (renameId rn x)): k, (rn, e)) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Just in case, unconditionally export primop/dc unfoldings even if we shouldn't (6585d45)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/6585d4547f88669f9aa231d43cbdc056d3c825e6 --- commit 6585d4547f88669f9aa231d43cbdc056d3c825e6 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Jul 1 13:32:02 2011 +0100 Just in case, unconditionally export primop/dc unfoldings even if we shouldn't --- compiler/supercompile/Supercompile.hs |2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index 67873ed..e29575f 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -205,9 +205,9 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] , Just e - [varUnfolding x]] varUnfolding x - | not (shouldExposeUnfolding x) = Nothing | Just pop - isPrimOpId_maybe x = Just $ primOpUnfolding pop | Just dc - isDataConWorkId_maybe x = Just $ dataUnfolding dc + | not (shouldExposeUnfolding x) = Nothing | otherwise = fmap coreExprToTerm $ maybeUnfoldingTemplate (realIdUnfolding x) -- NB: it's OK if the unfolding is a non-value, as the evaluator won't inline LetBound non-values ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Comment only (ddfbcbe)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/ddfbcbe4a7291abd9f488a908e8b5706b3f26ec6 --- commit ddfbcbe4a7291abd9f488a908e8b5706b3f26ec6 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Jul 29 17:43:31 2011 +0100 Comment only --- .../supercompile/Supercompile/Core/FreeVars.hs |1 + 1 files changed, 1 insertions(+), 0 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/FreeVars.hs b/compiler/supercompile/Supercompile/Core/FreeVars.hs index d439840..3b28621 100644 --- a/compiler/supercompile/Supercompile/Core/FreeVars.hs +++ b/compiler/supercompile/Supercompile/Core/FreeVars.hs @@ -74,6 +74,7 @@ nonRecBinderFreeVars x fvs | isTyVar x = fvs `delVarSet` x nonRecBindersFreeVars :: [Var] - FreeVars - FreeVars nonRecBindersFreeVars xs = flip (foldr nonRecBinderFreeVars) xs +-- Returns the most tightly binding variable last altConBoundVars :: AltCon - [Var] altConBoundVars (DataAlt _ as qs xs) = as ++ qs ++ xs altConBoundVars (LiteralAlt _) = [] ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Remove some redundant insertion operations on Renaming (113770f)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/113770f45993956c3b2ea5af0b98a898cabc1f55 --- commit 113770f45993956c3b2ea5af0b98a898cabc1f55 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Fri Jul 29 17:57:24 2011 +0100 Remove some redundant insertion operations on Renaming --- .../supercompile/Supercompile/Core/Renaming.hs |9 - .../Supercompile/Evaluator/Evaluate.hs |4 ++-- 2 files changed, 2 insertions(+), 11 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs b/compiler/supercompile/Supercompile/Core/Renaming.hs index 1258f28..ab6a87a 100644 --- a/compiler/supercompile/Supercompile/Core/Renaming.hs +++ b/compiler/supercompile/Supercompile/Core/Renaming.hs @@ -7,7 +7,6 @@ module Supercompile.Core.Renaming ( -- | Extending the renaming insertIdRenaming, insertIdRenamings, -insertIdCoVarRenaming, insertIdCoVarRenamings, insertTypeSubst, insertTypeSubsts, insertCoercionSubst, insertCoercionSubsts, @@ -123,14 +122,6 @@ insertIdRenaming (id_subst, tv_subst, co_subst) x x' insertIdRenamings :: Renaming - [(Id, Out Id)] - Renaming insertIdRenamings = foldr (\(x, x') rn - insertIdRenaming rn x x') -insertIdCoVarRenaming :: Renaming - Id - Out Id - Renaming -insertIdCoVarRenaming rn x x' - | isCoVar x = insertCoercionSubst rn x (mkCoVarCo x') - | otherwise = insertIdRenaming rn x x' - -insertIdCoVarRenamings :: Renaming - [(Id, Out Id)] - Renaming -insertIdCoVarRenamings = foldr (\(x, x') rn - insertIdCoVarRenaming rn x x') - insertTypeSubst :: Renaming - TyVar - Out Type - Renaming insertTypeSubst (id_subst, tv_subst, co_subst) x ty' = (id_subst, extendVarEnv tv_subst x ty', co_subst) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index 458694f..c18b163 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -211,7 +211,7 @@ step' normalising state = apply deeds tg_v (Heap h ids) k in_v@(_, (_, v)) x' = do (mb_co, (rn, Lambda x e_body)) - deferenceLambdaish (Heap h ids) in_v case mb_co of - Nothing - fmap (\deeds - (deeds, Heap h ids, k, (insertIdCoVarRenaming rn x x', e_body))) $ + Nothing - fmap (\deeds - (deeds, Heap h ids, k, (insertIdRenaming rn x x', e_body))) $ claimDeeds (deeds + 1 + annedValueSize' v) (annedSize e_body) Just (co', tg_co) - fmap (\deeds - (deeds, Heap (M.insert y' (internallyBound (mkIdentityRenaming (annedTermFreeVars e_arg), e_arg)) h) ids', Tagged tg_co (CastIt res_co') : k, (rn', e_body))) $ claimDeeds (deeds + 1 + annedValueSize' v) (annedSize e_arg + annedSize e_body) @@ -261,7 +261,7 @@ step' normalising state = rn_alts' = insertTypeSubsts rn_alts (alt_as `zip` tys') deeds2 = deeds1 + annedAltsSize rest , Just res - [do (deeds3, h', ids', rn_alts') - case mb_dc_cos of - Nothing - return (deeds2, h1, ids, insertIdCoVarRenamings (insertCoercionSubsts rn_alts' (alt_qs `zip` cos')) (alt_xs `zip` xs')) + Nothing - return (deeds2, h1, ids, insertIdRenamings (insertCoercionSubsts rn_alts' (alt_qs `zip` cos')) (alt_xs `zip` xs')) Just dc_cos - foldM (\(deeds, h, ids, rn_alts) (uncast_e_arg', alt_y, (dc_co, tg_co)) - let Pair _dc_co_from_ty' dc_co_to_ty' = coercionKind dc_co -- TODO: use to_tc_arg_tys' from above? (ids', rn_alts', y') = renameNonRecBinder ids rn_alts (alt_y `setIdType` dc_co_to_ty') ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Fix scrutination of cast data with Simon's new dealWithCoercion function (80a02e5)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/80a02e5d68affe1e5b090761225b9be597bc3c99 --- commit 80a02e5d68affe1e5b090761225b9be597bc3c99 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jul 27 15:40:58 2011 +0100 Fix scrutination of cast data with Simon's new dealWithCoercion function --- .../Supercompile/Evaluator/Evaluate.hs |6 +++--- 1 files changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index ccd8d86..ed88d68 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -226,9 +226,9 @@ step' normalising state = -- Make the theta from Fig 3 of the paper gammas = decomposeCo tc_arity co' -theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars) -(gammas ++ map mkReflCo tys) -in map (\arg_ty - (liftCoSubst theta arg_ty, tg_co)) arg_tys -- Use tag from the original coercion everywhere +theta_subst = liftCoSubstWith (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ map mkReflCo tys) +in map (\arg_ty - (theta_subst arg_ty, tg_co)) arg_tys -- Use tag from the original coercion everywhere -- b) Identify the first appropriate branch of the case and reduce -- apply the discovered coercions if necessary , (deeds3, h', ids', alt_e):_ - [ res | ((DataAlt alt_dc alt_as alt_xs, alt_e), rest) - bagContexts alts ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Improve assertion formatting in step' (3774d47)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/3774d4751dca50b4f7a833d2556bbe80feb3daf2 --- commit 3774d4751dca50b4f7a833d2556bbe80feb3daf2 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jul 27 22:39:47 2011 +0100 Improve assertion formatting in step' --- .../Supercompile/Evaluator/Evaluate.hs |3 ++- 1 files changed, 2 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index 77c8301..8ba977c 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -80,7 +80,8 @@ step' normalising state = (\res@(_reduced, stepped_state) - ASSERT2(noChange (releaseUnnormalisedStateDeed state) (releaseStateDeed stepped_state), hang (text step': deeds lost or gained:) 2 (pPrintFullUnnormalisedState state $$ pPrintFullState stepped_state)) ASSERT2(subVarSet (stateFreeVars stepped_state) (unnormalisedStateFreeVars state), - text step': FVs $$ pPrint (unnormalisedStateFreeVars state) $$ pPrintFullUnnormalisedState state $$ pPrint (stateFreeVars stepped_state) $$ pPrintFullState stepped_state) + text step': FVs $$ hang (text Before:) 2 (pPrint (unnormalisedStateFreeVars state) $$ pPrintFullUnnormalisedState state) $$ +hang (text After:) 2 (pPrint (stateFreeVars stepped_state) $$ pPrintFullState stepped_state)) -- traceRender (text normalising $$ nest 2 (pPrintFullUnnormalisedState state) $$ text to $$ nest 2 (pPrintFullState stepped_state)) $ res) $ go state ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Must abstract over type varibles as well when refining fulfilment FVs (f71dfb7)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch :
http://hackage.haskell.org/trac/ghc/changeset/f71dfb7e5e985c7a92a8a73a5e8d5637486dbbc7
---
commit f71dfb7e5e985c7a92a8a73a5e8d5637486dbbc7
Author: Max Bolingbroke batterseapo...@hotmail.com
Date: Wed Jul 27 22:36:52 2011 +0100
Must abstract over type varibles as well when refining fulfilment FVs
---
.../supercompile/Supercompile/Core/FreeVars.hs |4 ++--
.../supercompile/Supercompile/Drive/Process.hs | 10 +++---
2 files changed, 9 insertions(+), 5 deletions(-)
diff --git a/compiler/supercompile/Supercompile/Core/FreeVars.hs
b/compiler/supercompile/Supercompile/Core/FreeVars.hs
index edef8b7..6711c5f 100644
--- a/compiler/supercompile/Supercompile/Core/FreeVars.hs
+++ b/compiler/supercompile/Supercompile/Core/FreeVars.hs
@@ -3,7 +3,7 @@
module Supercompile.Core.FreeVars (
module Supercompile.Core.FreeVars,
module VarSet,
-tyVarsOfType, tyCoVarsOfCo
+tyVarsOfType, tyVarsOfTypes, tyCoVarsOfCo
) where
import Supercompile.Core.Syntax
@@ -17,7 +17,7 @@ import CoreFVs
import VarSet
import Coercion (tyCoVarsOfCo)
import Var (isTyVar)
-import Type (tyVarsOfType)
+import Type (tyVarsOfType, tyVarsOfTypes)
type FreeVars = VarSet
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs
b/compiler/supercompile/Supercompile/Drive/Process.hs
index f542560..5fcfba2 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -30,7 +30,7 @@ import Supercompile.StaticFlags
import Supercompile.Utilities
import Var(isTyVar, varType)
-import Id (mkLocalId)
+import Id (idType, mkLocalId)
import Name (Name, mkSystemVarName)
import FastString (mkFastString)
import CoreUtils (mkPiTypes)
@@ -428,13 +428,17 @@ promise p x' opt = ScpM $ \e s k - {- traceRender
(promise, fun p, abstracted
-- actually need. We aren't able to do anything about the stuff they
spuriously allocate as a result, but we can make generate a little wrapper that
just discards
-- those arguments. With luck, GHC will inline it and good things will
happen.
--
+ -- We have to be careful when generating the wrapper: the *type
variables* of the optimised_fvs must also be abstracted over!
+ --
-- TODO: we can generate the wrappers in a smarter way now that we can
always see all possible fulfilments?
- let optimised_fvs = fvedTermFreeVars optimised_e
+ let optimised_fvs_incomplete = fvedTermFreeVars optimised_e
+ optimised_fvs = optimised_fvs_incomplete `unionVarSet` tyVarsOfTypes
(map idType (varSetElems optimised_fvs_incomplete))
abstracted_set = mkVarSet (abstracted p)
abstracted'_set = optimised_fvs `intersectVarSet` abstracted_set --
We still don't want to abstract over e.g. phantom bindings
abstracted'_list = sortLambdaBounds $ varSetElems abstracted'_set
fun' = mkLocalId x' (abstracted'_list `mkPiTypes` stateType (unI
(meaning p)))
- ScpM $ \_e s k - let fs' | abstracted_set == abstracted'_set || not
rEFINE_FULFILMENT_FVS
+ pprTrace promise (ppr optimised_fvs $$ ppr optimised_e) $
+ ScpM $ \_e s k - let fs' | abstracted_set == abstracted'_set || not
rEFINE_FULFILMENT_FVS
-- If the free variables are totally
unchanged, there is nothing to be gained from clever fiddling
= (P { fun = fun p, abstracted = abstracted p,
meaning = Just (unI (meaning p)) }, tyVarIdLambdas (abstracted p) optimised_e)
: fulfilments s
| otherwise
___
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Try to handle coercion variable substitutions properly (0130952)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/0130952aa355cc67124be9107d9c0a338f5ed27a --- commit 0130952aa355cc67124be9107d9c0a338f5ed27a Author: Max Bolingbroke batterseapo...@hotmail.com Date: Thu Jul 28 09:35:49 2011 +0100 Try to handle coercion variable substitutions properly compiler/supercompile/Supercompile.hs |2 +- .../supercompile/Supercompile/Core/Renaming.hs | 43 +--- compiler/supercompile/Supercompile/Core/Syntax.hs |8 ++- .../Supercompile/Evaluator/Evaluate.hs | 10 ++-- 4 files changed, 39 insertions(+), 24 deletions(-) Diff suppressed because of size. To see it, use: git show 0130952aa355cc67124be9107d9c0a338f5ed27a ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : The case wildcard binding was totally bogus, and also triggered a deeds assertion (e1cf97d)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/e1cf97d2c641b62ee57a3bcb421790eb550cd3a4 --- commit e1cf97d2c641b62ee57a3bcb421790eb550cd3a4 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Mon Aug 1 11:54:47 2011 +0100 The case wildcard binding was totally bogus, and also triggered a deeds assertion .../supercompile/Supercompile/Drive/Process.hs |4 +- .../Supercompile/Evaluator/Evaluate.hs | 21 +++ .../supercompile/Supercompile/Evaluator/Syntax.hs | 21 --- 3 files changed, 27 insertions(+), 19 deletions(-) Diff suppressed because of size. To see it, use: git show e1cf97d2c641b62ee57a3bcb421790eb550cd3a4 ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: Improve splitSubst hack to ensure we don't lose CoVar-CoVar and TyVar-TyVar renamings (89175e0)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/89175e0e64e9326471066356009ea66de41560b5 --- commit 89175e0e64e9326471066356009ea66de41560b5 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Sun Jul 31 22:18:43 2011 +0100 Improve splitSubst hack to ensure we don't lose CoVar-CoVar and TyVar-TyVar renamings --- .../supercompile/Supercompile/Core/Renaming.hs | 15 ++- 1 files changed, 10 insertions(+), 5 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Renaming.hs b/compiler/supercompile/Supercompile/Core/Renaming.hs index ab6a87a..c71ab33 100644 --- a/compiler/supercompile/Supercompile/Core/Renaming.hs +++ b/compiler/supercompile/Supercompile/Core/Renaming.hs @@ -92,14 +92,19 @@ joinSubst iss (id_subst, tv_subst, co_subst) = mkSubst iss tv_subst co_subst id_ -- 2) Ensure that we always extend the IdSubstEnv, regardless of whether the unique changed. -- This is the solution I've adopted, and it is implemented here in splitSubst: splitSubst :: Subst - [(Var, Var)] - (InScopeSet, Renaming) -splitSubst (Subst iss id_subst tv_subst co_subst) xs_extend - = (iss, (id_subst `extendVarEnvList` [(x, varToCoreSyn x') | (x, x') - xs_extend], tv_subst, co_subst)) +splitSubst (Subst iss id_subst tv_subst co_subst) extend + = (iss, (id_subst `extendVarEnvList` [(x, varToCoreSyn x') | (x, x') - ids_extend], + tv_subst `extendVarEnvList` [(a, mkTyVarTy a')| (a, a') - tvs_extend], + co_subst `extendVarEnvList` [(q, mkCoVarCo q')| (q, q') - cos_extend])) + where (ids_extend, tvs_extend, cos_extend) = splitVarLikeList fst extend +splitVarLikeList :: (a - Var) - [a] - ([a], [a], [a]) +splitVarLikeList f xs = (id_list, tv_list, co_list) + where (tv_list, coid_list) = partition (isTyVar . f) xs +(co_list, id_list) = partition (isCoVar . f) coid_list splitVarList :: [Var] - ([Id], [TyVar], [CoVar]) -splitVarList xs = (id_list, tv_list, co_list) - where (tv_list, coid_list) = partition isTyVar xs -(co_list, id_list) = partition isCoVar coid_list +splitVarList = splitVarLikeList id emptyRenaming :: Renaming emptyRenaming = (emptyVarEnv, emptyVarEnv, emptyVarEnv) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] supercompiler: I was accidentally duplicating coercions on indirections (d981ac3)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/d981ac3b9d4e8708f124a2297a1c6b4a4063ffd9 --- commit d981ac3b9d4e8708f124a2297a1c6b4a4063ffd9 Author: Max Bolingbroke batterseapo...@hotmail.com Date: Mon Aug 1 16:34:09 2011 +0100 I was accidentally duplicating coercions on indirections --- .../Supercompile/Evaluator/Evaluate.hs |8 +--- 1 files changed, 5 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs index ddc1c32..cb75377 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Evaluate.hs @@ -121,10 +121,11 @@ step' normalising state = - Answer -- ^ Bound value, which we have *exactly* 1 deed for already that is not recorded in the Deeds itself - Maybe (Deeds, Answer) -- Outgoing deeds have that 1 latent deed included in them, and we have claimed deeds for the outgoing value prepareAnswer deeds x' a - | dUPLICATE_VALUES_EVALUATOR = fmap (flip (,) a) $ claimDeeds (deeds + 1) (answerSize' a) + | dUPLICATE_VALUES_EVALUATOR = fmap (flip (,) a) $ claimDeeds (deeds + 1) (answerSize' a) -- Avoid creating indirections to indirections: implements indirection compression - | (_, (_, Indirect _)) - a = return (deeds, a) - | otherwise = return (deeds, (Nothing, (mkIdentityRenaming (unitVarSet x'), Indirect x'))) + -- FIXME: for cast things as well? + | (Nothing, (_, Indirect _)) - a = return (deeds, a) + | otherwise = return (deeds, (Nothing, (mkIdentityRenaming (unitVarSet x'), Indirect x'))) -- We have not yet claimed deeds for the result of this function lookupAnswer :: Heap - Out Var - Maybe (Anned Answer) @@ -150,6 +151,7 @@ step' normalising state = in_e - heapBindingTerm hb return $ case k of -- Avoid creating consecutive update frames: implements stack squeezing + -- FIXME: squeeze through casts as well? kf : _ | Update y' - tagee kf - (deeds, Heap (M.insert x' (internallyBound (mkIdentityRenaming (unitVarSet y'), annedTerm (tag kf) (Var y'))) h) ids, k, in_e) _ - (deeds, Heap (M.delete x' h) ids, Tagged tg (Update x') : k, in_e) ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Eliminate some dodgy const fmaps with traverses (3b675a8)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/3b675a8d2fd888a65955f19458690885e64787ce --- commit 3b675a8d2fd888a65955f19458690885e64787ce Author: Max Bolingbroke batterseapo...@hotmail.com Date: Wed Jul 27 21:57:55 2011 +0100 Eliminate some dodgy const fmaps with traverses --- compiler/supercompile/Supercompile/Core/Syntax.hs | 10 -- .../supercompile/Supercompile/Drive/Process.hs |5 +++-- .../supercompile/Supercompile/Evaluator/Syntax.hs |9 ++--- 3 files changed, 17 insertions(+), 7 deletions(-) diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs index 1cd4e48..b2d22a0 100644 --- a/compiler/supercompile/Supercompile/Core/Syntax.hs +++ b/compiler/supercompile/Supercompile/Core/Syntax.hs @@ -17,6 +17,8 @@ import Type (Type, mkTyVarTy) import Coercion (Coercion, mkReflCo) import PrimOp (PrimOp) +import Data.Traversable (Traversable(traverse)) + data AltCon = DataAlt DataCon [TyVar] [Id] | LiteralAlt Literal | DefaultAlt deriving (Eq, Show) @@ -139,8 +141,12 @@ pPrintPrecApps :: (Outputable a, Outputable b) = Rational - a - [b] - SDoc pPrintPrecApps prec e1 es2 = prettyParen (not (null es2) prec = appPrec) $ pPrintPrec opPrec e1 + hsep (map (pPrintPrec appPrec) es2) -termToValue :: Copointed ann = ann (TermF ann) - Maybe (ann (ValueF ann)) -termToValue e = case extract e of Value v - Just (fmap (const v) e); _ - Nothing +termToValue :: Traversable ann = ann (TermF ann) - Maybe (ann (ValueF ann)) +termToValue anned_e = traverse termToValue' anned_e + +termToValue' :: TermF ann - Maybe (ValueF ann) +termToValue' (Value v) = Just v +termToValue' _ = Nothing termIsValue :: Copointed ann = ann (TermF ann) - Bool termIsValue = isValue . extract diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index 64e6764..f542560 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -36,6 +36,7 @@ import FastString (mkFastString) import CoreUtils (mkPiTypes) import qualified Data.Foldable as Foldable +import Data.Traversable (Traversable(traverse)) import qualified Data.Map as M import Data.Monoid import Data.Ord @@ -247,9 +248,9 @@ speculate speculated (stats, (deeds, Heap h ids, k, in_e)) = (M.keysSet h, (stat Stop (_old_state, rb) - (no_change, rb) Continue hist - case reduce state of (extra_stats, (deeds, Heap h_speculated_ok' ids, [], qa)) -| Answer a - annee qa +| Just a - traverse qaToAnswer qa , let h_unspeculated = h_speculated_ok' M.\\ h_speculated_ok - in_e' = annedAnswerToAnnedTerm (mkInScopeSet (annedFreeVars qa)) (fmap (const a) qa) + in_e' = annedAnswerToAnnedTerm (mkInScopeSet (annedFreeVars a)) a - ((stats `mappend` extra_stats, deeds, M.insert x' (internallyBound in_e') h_speculated_ok, h_speculated_failure, ids), speculateManyMap hist h_unspeculated) _ - (no_change, speculation_failure) where state = normalise (deeds, Heap h_speculated_ok ids, [], in_e) diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 686bac5..ed39a01 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -123,6 +123,9 @@ qaToAnnedTerm' :: InScopeSet - QA - TermF Anned qaToAnnedTerm' _ (Question x) = Var x qaToAnnedTerm' iss (Answer a) = answerToAnnedTerm' iss a +qaToAnswer :: QA - Maybe Answer +qaToAnswer qa = case qa of Answer a - Just a; Question _ - Nothing + type UnnormalisedState = (Deeds, Heap, Stack, In AnnedTerm) type State = (Deeds, Heap, Stack, Anned QA) @@ -234,9 +237,9 @@ stackFrameType kf hole_ty = case tagee kf of CastIt co - pSnd (coercionKind co) qaType :: Anned QA - Type -qaType qa = case annee qa of -Question x' - idType x' -Answer a- answerType (fmap (const a) qa) +qaType anned_qa = case traverse (\qa - case qa of Question x' - Left (idType x'); Answer a - Right a) anned_qa of +Left q_ty - q_ty +Right anned_a - answerType anned_a answerType :: Anned Answer - Type answerType a = case annee a of ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
[commit: ghc] : Correct the form of implicit datacon workers: only apply existential TVs (4d50df6)
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : http://hackage.haskell.org/trac/ghc/changeset/4d50df6d898d18908a25815c3809a0b3b72cf1bb --- commit 4d50df6d898d18908a25815c3809a0b3b72cf1bb Author: Max Bolingbroke batterseapo...@hotmail.com Date: Mon Aug 1 10:45:08 2011 +0100 Correct the form of implicit datacon workers: only apply existential TVs --- compiler/supercompile/Supercompile.hs |7 --- 1 files changed, 4 insertions(+), 3 deletions(-) diff --git a/compiler/supercompile/Supercompile.hs b/compiler/supercompile/Supercompile.hs index 792583a..8c73380 100644 --- a/compiler/supercompile/Supercompile.hs +++ b/compiler/supercompile/Supercompile.hs @@ -11,7 +11,7 @@ import CoreSyn import CoreFVs(exprFreeVars) import CoreUtils (exprType) import Coercion (Coercion, isCoVar, isCoVarType, mkCoVarCo) -import DataCon(dataConWorkId, dataConAllTyVars, dataConRepArgTys) +import DataCon(dataConWorkId, dataConUnivTyVars, dataConExTyVars, dataConRepArgTys) import VarSet import Name (localiseName) import Var(Var, isTyVar, varName, setVarName) @@ -237,8 +237,9 @@ termUnfoldings e = go (S.termFreeVars e) emptyVarSet [] where (as, arg_tys, _res_ty, _arity, _strictness) = primOpSig pop xs = zipWith (mkSysLocal (fsLit x)) bv_uniques arg_tys -dataUnfolding dc = S.tyLambdas as $ S.lambdas xs $ S.value (S.Data dc (map mkTyVarTy as) (map mkCoVarCo qs) ys) - where as = dataConAllTyVars dc +dataUnfolding dc = S.tyLambdas univ_as $ S.tyLambdas ex_as $ S.lambdas xs $ S.value (S.Data dc (map mkTyVarTy ex_as) (map mkCoVarCo qs) ys) + where univ_as = dataConUnivTyVars dc +ex_as = dataConExTyVars dc arg_tys = dataConRepArgTys dc xs = zipWith (mkSysLocal (fsLit x)) bv_uniques arg_tys (qs, ys) = span isCoVar xs ___ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
