Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Last bug fixes and flag additions.

  • Loading branch information...
commit 08e33edf20e2274b1266b4809ecea5678014b0a3 1 parent 5ff6887
@batterseapower batterseapower authored
View
13 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)
View
4 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) $
View
23 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
View
2  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]
View
2  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]
View
19 compiler/supercompile/Supercompile/Evaluator/Evaluate.hs
@@ -560,7 +560,24 @@ shouldExposeUnfolding :: Id -> Either String Superinlinable
shouldExposeUnfolding x = case inl_inline inl_prag of
-- FIXME: God help my soul
_ | Just mod <- nameModule_maybe (idName x)
- , moduleName mod `elem` map mkModuleName ["Data.Complex", "GHC.List"]
+ , moduleName mod `elem` map mkModuleName [
+ "Data.Complex", "GHC.List",
+ "QSort", -- awards
+ "Checker", "Lisplikefns", "Rewritefns", "Rulebasetext", -- boyer2
+ "Auxil", "Interval", "Key", "Prog", -- cichelli
+ "MonadState", "MonadTrans", -- cryptarithm2
+ "StateMonad", -- cse
+ "Knowledge", "Result", "Search", "Table", "Match", -- expert
+ "Fourier", "Complex_Vectors", -- fft2
+ "RA", "RC", "RG", "RU", "Types", -- nucleic2
+ "ChessSetArray", "ChessSetList", "KnightHeuristic", "Queue", "Sort", -- knights
+ "Mandel", -- mandel
+ "Move", "Problem", "Solution", -- mate
+ "Board", "Game", "Prog", "Tree", "Wins", -- minimax
+ "CharSeq", "Pretty", -- pretty
+ "IntLib", "MyRandom", "Prime", -- primetest
+ "Digraph" -- scc
+ ]
-> Right True
-- These get wrappers generated for them: be very eager to inline the wrappers
| isPrimOpId x || isDataConWorkId x
View
2  compiler/supercompile/Supercompile/GHC.hs
@@ -55,7 +55,7 @@ desc = desc' . unI
desc' :: S.TermF Identity -> Description
desc' (S.Var x) = Opaque (S.varString x)
desc' (S.Value _) = Opaque "value"
-desc' (S.TyApp e1 _) = argOf (desc e1)
+desc' (S.TyApp e1 _) = desc e1 -- NB: no argOf for type arguments because they don't get ANFed, so it's a bit redundant
desc' (S.CoApp e1 _) = argOf (desc e1)
desc' (S.App e1 _) = argOf (desc e1)
desc' (S.PrimOp pop as es) = foldr (\() d -> argOf d) (Opaque (show pop)) (map (const ()) as ++ map (const ()) es)
View
15 compiler/supercompile/Supercompile/StaticFlags.hs
@@ -56,6 +56,9 @@ dEPTH_LIIMT :: Maybe Int
dEPTH_LIIMT = Just (lookup_def_int "-fsupercompiler-depth-limit" maxBound)
--dEPTH_LIIMT = Just 10
+rEDUCE_STOP_LIMIT :: Int
+rEDUCE_STOP_LIMIT = lookup_def_int "-fsupercompiler-reduce-stop-limit" 1
+
pOSITIVE_INFORMATION :: Bool
pOSITIVE_INFORMATION = not $ lookUp $ fsLit "-fsupercompiler-no-positive-information"
--pOSITIVE_INFORMATION = True
@@ -218,14 +221,20 @@ tAG_COLLECTION = parseEnum "-fsupercompiler-tag-collection" (TBT False) [("bags"
data GeneralisationType = NoGeneralisation | AllEligible | DependencyOrder Bool | StackFirst
-gENERALISATION :: GeneralisationType
-gENERALISATION = parseEnum "-fsupercompiler-generalisation" StackFirst [("none", NoGeneralisation), ("all-eligible", AllEligible), ("first-reachable", DependencyOrder True), ("last-reachable", DependencyOrder False), ("stack-first", StackFirst)]
+sPLIT_GENERALISATION_TYPE :: GeneralisationType
+sPLIT_GENERALISATION_TYPE = parseEnum "-fsupercompiler-split-generalisation-type" StackFirst [("none", NoGeneralisation), ("all-eligible", AllEligible), ("first-reachable", DependencyOrder True), ("last-reachable", DependencyOrder False), ("stack-first", StackFirst)]
oCCURRENCE_GENERALISATION :: Bool
oCCURRENCE_GENERALISATION = not $ lookUp $ fsLit "-fsupercompiler-no-occurrence-generalisation"
+gENERALISATION :: Bool
+gENERALISATION = not $ lookUp $ fsLit "-fsupercompiler-no-generalisation"
+
+mSG_GENERALISATION :: Bool
+mSG_GENERALISATION = not $ lookUp $ fsLit "-fsupercompiler-no-msg-generalisation"
+
tYPE_GEN :: Bool
-tYPE_GEN = True
+tYPE_GEN = not $ lookUp $ fsLit "-fsupercompiler-no-type-generalisation"
eVALUATE_PRIMOPS :: Bool
eVALUATE_PRIMOPS = not $ lookUp $ fsLit "-fsupercompiler-no-primops"
Please sign in to comment.
Something went wrong with that request. Please try again.