[commit: ghc] supercompiler: A more plausible checkpoint, but still broken overall (bf2ba32)
Max Bolingbroke <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/bf2ba324734364675b49d43b88e4d427c967c8b4 >--------------------------------------------------------------- commit bf2ba324734364675b49d43b88e4d427c967c8b4 Author: Max Bolingbroke <[email protected]> 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) h k tg_v in_v x' ty' in_alts PrimApply pop in_vs in_es -> primop deeds (tag kf) h k tg_v pop in_vs in_v in_es CastIt co' -> cast deeds (tag kf) h k in_v co' @@ -167,12 +167,21 @@ step' normalising state = tyApply :: Deeds -> Heap -> Stack -> Answer -> Out Type -> Maybe UnnormalisedState 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 - (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? + fmap (\deeds -> (deeds, h, case mb_co of Nothing -> k; Just (co', tg_co) -> Tagged tg_co (Coerce (co' `mkInstCo` ty')) : k, (insertTypeSubst rn x ty', e_body))) $ + claimDeeds (deeds + annedValueSize' v) (annedSize e_body) + + apply :: Deeds -> Tag -> Heap -> Stack -> Answer -> Out Var -> Maybe UnnormalisedState + 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, (insertRenaming rn x x', e_body))) $ + claimDeeds (deeds + 1 + annedValueSize' v) (annedSize e_body) + Just (co', tg_co) -> fmap (\deeds -> (deeds, Heap (M.insert y' e_arg h) ids', Tagged tg_co (Cast res_co') : k)) $ + claimDeeds (deeds + 1 + annedValueSize' v) (annedSize e_arg + annedSize e_body) + where (ids', rn', [y']) = renameNonRecBinders ids rn [x `setVarType` arg_co_from_ty']) $ + (arg_co_from_ty', _arg_co_to_ty') = coercionKind arg_co' + [arg_co', res_co'] = decomposeCo 2 co' + e_arg = annedTerm tg_co (annedTerm tg_v (Var x') `Cast` mkSymCo arg_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) @@ -190,7 +199,7 @@ step' normalising state = -- NB: we add the *non-dereferenced* value to the heap in a default branch with variable, because anything else may duplicate allocation | otherwise = Nothing -- This can legitimately occur, e.g. when supercompiling (if x then (case x of False -> 1) else 2) - where (rn_v_deref, v_deref) = dereference (Heap h ids) (rn_v, v) + where (mb_co_deref, (rn_v_deref, v_deref)) = dereference (Heap h ids) (rn_v, v) primop :: Deeds -> Tag -> Heap -> Stack -> Tag -> PrimOp -> [Anned Answer] -> Answer -> [In AnnedTerm] -> Maybe UnnormalisedState primop deeds tg_kf h k tg_a pop anned_as a [] = do