diff options
Diffstat (limited to 'compiler/supercompile/Supercompile/Drive')
5 files changed, 31 insertions, 13 deletions
diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 6935b3404d..ee6adad551 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -34,6 +34,7 @@ import Kind --import TysWiredIn (pairTyCon {- , tupleCon -}) import TysPrim (funTyCon) import TypeRep (Type(..)) +import Type (coreView) import TrieMap (TrieMap(..), CoercionMap, TypeMap) import Rules (mkSpecInfo, roughTopNames) import Unique (mkUniqueGrimily) @@ -879,8 +880,16 @@ msgType rn2 ty_l ty_r = case checkEqual (isKindTy ty_l) (isKindTy ty_r) of msgType' :: Bool -> RnEnv2 -> Type -> Type -> MSG Type msgType' _ rn2 (TyVarTy x_l) (TyVarTy x_r) = liftM TyVarTy $ msgVar rn2 x_l x_r -- NB: if this fails, one of the two sides is unfloatable, so don't try to generalise msgType' are_kinds rn2 (AppTy ty1_l ty2_l) (AppTy ty1_r ty2_r) = liftM2 mkAppTy (msgType' are_kinds rn2 ty1_l ty1_r) (msgType rn2 ty2_l ty2_r) -- NB: arguments not necessarily at same level, but type constructor must be -msgType' _ _ (TyConApp tc_l []) (TyConApp tc_r []) | tc_l == tc_r = return (TyConApp tc_r []) -msgType' are_kinds rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) | not (null tys_l) || not (null tys_r) = msgType' are_kinds rn2 (foldl AppTy (TyConApp tc_l []) tys_l) (foldl AppTy (TyConApp tc_r []) tys_r) +msgType' are_kinds rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) + -- Special case so we can avoid splitting most type synonyms, also prevents loops in the case where we have (TyConApp tc []) on each side so breaking apart TyConApp would be a NOP + | tc_l == tc_r && length tys_l == length tys_r = liftM (TyConApp tc_r) (zipWithEqualM (msgType rn2) tys_l tys_r) +msgType' are_kinds rn2 ty_l ty_r + -- MUST look through type synonyms because otherwise we might succeed in generalising when given (ShowsS `msgType` (a -> b)), which would be a disaster + | Just ty_l' <- coreView ty_l = msgType' are_kinds rn2 ty_l' ty_r + | Just ty_r' <- coreView ty_r = msgType' are_kinds rn2 ty_l ty_r' +msgType' are_kinds rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) + -- Must look through synonyms *before* we break apart TyConApps since coreView won't work any other way + | not (null tys_l) || not (null tys_r) = msgType' are_kinds rn2 (foldl AppTy (TyConApp tc_l []) tys_l) (foldl AppTy (TyConApp tc_r []) tys_r) msgType' are_kinds rn2 (FunTy ty1_l ty2_l) (FunTy ty1_r ty2_r) = msgType' are_kinds rn2 ((TyConApp funTyCon [] `AppTy` ty1_l) `AppTy` ty2_l) ((TyConApp funTyCon [] `AppTy` ty1_r) `AppTy` ty2_r) msgType' are_kinds rn2 (ForAllTy a_l ty_l) (ForAllTy a_r ty_r) = msgTyVarBndr ForAllTy rn2 a_l a_r $ \rn2 -> msgType' are_kinds rn2 ty_l ty_r msgType' _ _ (LitTy l_l) (LitTy l_r) | l_l == l_r = return (LitTy l_r) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index c7727b022e..e04073fa0e 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -889,7 +889,7 @@ reduceWithStats :: State -> (SCStats, State) reduceWithStats state = case reduce' state of (_, stats, state') -> (stats, state') reduce' :: State -> (Bool, SCStats, State) -reduce' orig_state = go 0 False init_hist orig_state +reduce' orig_state = go rEDUCE_STOP_LIMIT False init_hist orig_state where init_hist = mkLinearHistory rEDUCE_WQO @@ -903,7 +903,7 @@ reduce' orig_state = go 0 False init_hist orig_state -> case terminate hist (gc state) of Continue hist' -> go n True hist' state' Stop old_state - | n > 0 -> go (n - 1) True init_hist state' -- FIXME: huge hack + | n > 1 -> go (n - 1) True init_hist state' -- FIXME: huge hack | otherwise -> 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) $ diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 7ceef75a0f..c6cdd140c4 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -291,8 +291,9 @@ sc' mb_h state = {- pprTrace "sc'" (trce1 state) $ -} {-# SCC "sc'" #-} case mb_ terminateM h state rb (speculateM (reduce state) $ \state -> my_split state) (\shallow_h shallow_state shallow_rb -> trce shallow_h shallow_state $ do - let (mb_shallow_gen, mb_gen) = zipPair mplus mplus (tryMSG sc shallow_state state) - (tryTaG sc shallow_state state) + let (mb_shallow_gen, mb_gen) | not gENERALISATION = (Nothing, Nothing) + | otherwise = zipPair mplus mplus (tryMSG sc shallow_state state) + (tryTaG sc shallow_state state) 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) @@ -323,7 +324,9 @@ 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 +tryMSG opt shallow_state state + | not mSG_GENERALISATION = (Nothing, Nothing) + | otherwise = 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, _) @@ -620,7 +623,9 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state -- NB: don't record a promise for type generalisation! This is OK for termination because all type gens -- are non-trivial so we will eventually have to stop genning. Furthermore, it means that we can't end -- up with a FIXME: continue - RightGivesTypeGen rn_l s rn_r -> trace "typegen" $ (True, do { (deeds, e') <- memo_opt s + RightGivesTypeGen rn_l s rn_r -> -- pprTrace "typegen" (pPrintFullState fullStatePrettiness state $$ pPrintFullState fullStatePrettiness s) $ + trace "typegen" $ + (True, do { (deeds, e') <- memo_opt s ; (_, e'_r) <- renameSCResult (case s of (_, Heap _ ids, _, _) -> ids) (rn_r, e') -- OH MY GOD: -- - If we do memo-rollback or sc-rollback then we CAN'T overwrite old fulfilments @@ -662,9 +667,13 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state (promise -> Maybe Var) -> [(promise, MSGMatchResult)] -> [(Bool, (promise, MSGMatchResult))] - sortBest dumped ress = filter (\(_, (p, _)) -> case dumped p of Just fun -> pprTraceSC "tieback-to-dumped" (ppr fun) False; Nothing -> True) $ - map ((,) True) best_ress ++ map ((,) False) (sortBy ((\x y -> if x `moreSpecific` y then LT else GT) `on` snd) other_ress) - where -- Stop early upon exact match (as an optimisation) + sortBest dumped ress = filter suitable $ map ((,) True) best_ress ++ map ((,) False) (sortBy ((\x y -> if x `moreSpecific` y then LT else GT) `on` snd) other_ress) + where suitable (_, (p, mr)) + | Just fun <- dumped p = pprTraceSC "tieback-to-dumped" (ppr fun) False + | not tYPE_GEN, RightGivesTypeGen {} <- mr = False + | otherwise = True + + -- Stop early upon exact match (as an optimisation) (best_ress, other_ress) = partition (mostSpecific . snd) ress mostSpecific :: MSGMatchResult -> Bool diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs index 933cf393e0..fd35ef542d 100644 --- a/compiler/supercompile/Supercompile/Drive/Split.hs +++ b/compiler/supercompile/Supercompile/Drive/Split.hs @@ -201,7 +201,7 @@ generalise :: MonadStatics m generalise gen (deeds, Heap h ids, k, qa) = do let named_k = nameStack k - (gen_kfs, gen_xs') <- case gENERALISATION of + (gen_kfs, gen_xs') <- case sPLIT_GENERALISATION_TYPE of 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) <- trainCars named_k, generaliseStackFrame gen kf] diff --git a/compiler/supercompile/Supercompile/Drive/Split2.hs b/compiler/supercompile/Supercompile/Drive/Split2.hs index e529f22baa..92fc3774c8 100644 --- a/compiler/supercompile/Supercompile/Drive/Split2.hs +++ b/compiler/supercompile/Supercompile/Drive/Split2.hs @@ -247,7 +247,7 @@ instanceSplit :: (Applicative m, Monad m) 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 +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 sPLIT_GENERALISATION_TYPE of 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] |