Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/ae7aadd8d786558bea3553c08a4784f4162c284d >--------------------------------------------------------------- commit ae7aadd8d786558bea3553c08a4784f4162c284d Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Wed Jul 4 18:15:54 2012 +0100 Basic implementation of RightGivesTypeGen to stop panics >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process3.hs | 12 +++++++----- 1 files changed, 7 insertions(+), 5 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 83c4393..1a60e88 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -518,14 +518,16 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state ; traceRenderM "<sc }" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res) ; fulfillM res }, s { scpMemoState = ms' }) where (ms', p) = promise (scpMemoState s) (state, reduced_state) - in case fmap (\(exact, (p, mr)) -> case mr of - RightIsInstance heap_inst rn_lr k_inst -> (exact, do { traceRenderM ("=sc" ++ if exact then "" else "(inst)") (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), PrettyDoc (pPrintFullState quietStatePrettiness reduced_state), PrettyDoc (pPrintFullState quietStatePrettiness (meaning p)) {-, res-}) - ; stuff <- instanceSplit (remaining_deeds, heap_inst, k_inst, applyAbsVars (fun p) (Just rn_lr) (abstracted p)) memo_opt - ; insertTagsM stuff }) + in case fmap (\(exact, (p, mr)) -> (exact, case mr of + RightIsInstance heap_inst rn_lr k_inst -> do { traceRenderM ("=sc" ++ if exact then "" else "(inst)") (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), PrettyDoc (pPrintFullState quietStatePrettiness reduced_state), PrettyDoc (pPrintFullState quietStatePrettiness (meaning p)) {-, res-}) + ; stuff <- instanceSplit (remaining_deeds, heap_inst, k_inst, applyAbsVars (fun p) (Just rn_lr) (abstracted p)) memo_opt + ; insertTagsM stuff } where -- This will always succeed because the state had deeds for everything in its heap/stack anyway: Just remaining_deeds = claimDeeds (releaseStateDeed state) (heapSize heap_inst + stackSize k_inst) - RightGivesTypeGen rn_l s rn_r -> error "FIXME: RightGivesTypeGen unimplemented") $ + -- FIXME: in rare cases (i.e when rollback is off OR when the state we are type-genning against is on the stack) + -- then this codepath could also overwrite the fulfilment for the old state to call into the generalised version: + RightGivesTypeGen _rn_l s rn_r -> trace "typegen" $ do { (deeds, e') <- memo_opt s; return (deeds, renameFVedTerm (case s of (_, Heap _ ids, _, _) -> ids) rn_r e') })) $ bestChoice [ (p, mr) | let (parented_ps, unparented_ps) = trainToList (promises (scpMemoState s)) , (p, is_ancestor, common_h_vars) <- [ (p_sibling, fun p_parent == fun p_sibling, common_h_vars) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
