-- -- (c) Susumu Katayama -- \begin{code} {-# OPTIONS -cpp -XRelaxedPolyRec #-} module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF) where import MagicHaskeller.Types import MagicHaskeller.TyConLib import Control.Monad import MagicHaskeller.CoreLang import Control.Monad.Search.Combinatorial import MagicHaskeller.PriorSubsts import Data.List(partition, sortBy, sort, nub, (\\)) import Data.Ix(inRange) import MagicHaskeller.ClassifyDM import MagicHaskeller.Classify(diffSortedBy) import System.Random(mkStdGen, StdGen) import MagicHaskeller.Instantiate import MagicHaskeller.ProgramGenerator import MagicHaskeller.Options(Opt(..)) import MagicHaskeller.Expression import MagicHaskeller.T10(mergesortWithBy) import MagicHaskeller.DebMT import Debug.Trace -- trace str = id reorganize_ = reorganizer_ -- reorganize_ = id classify = True traceExpTy _ = id -- traceExpTy fty = trace ("lookupexp "++ show fty) traceTy _ = id -- traceTy fty = trace ("lookup "++ show fty) -- Memoization table, created from primitive components type ProgGenSF = PGSF AnnExpr newtype Expression e => PGSF e = PGSF (MemoDeb e) -- internal data representation. -- ^ Program generator with synergetic filtration. -- This program generator employs filtration by random testing, and rarely generate semantically equivalent expressions more than once, while different expressions will eventually appear (for most of the types, represented with Prelude types, whose arguments are instance of Arbitrary and which return instance of Ord). -- The idea is to apply random numbers to the generated expressions, compute the quotient set of the resulting values at each depth of the search tree, and adopt the complete system of representatives for the depth and push the remaining expressions to one step deeper in the search tree. -- (Thus, adoption of expressions that may be equivalent to another already-generated-expression will be postponed until their \"uniqueness\" is proved.) -- As a result, (unlike "ProgGen",) expressions with size N may not appear at depth N but some deeper place. -- -- "ProgGenSF" is more efficient along with a middle-sized primitive set (like @reallyall@ found in LibTH.hs), -- but is slower than "ProgGen" for a small-sized one. -- -- Also note that "ProgGenSF" depends on hard use of unsafe* stuff, so if there is a bug, it may segfault.... type ExpTip e = Matrix e type ExpTrie e = MapType (ExpTip e) type TypeTrie e = MapType (Matrix ([e], Subst, Int)) type MemoTrie e = (TypeTrie e, ExpTrie e) lmt :: Expression e => MemoDeb e -> Type -> Matrix e lmt memoDeb@((_,mt),_,cmn) fty = traceExpTy fty $ lookupMT mt fty -- こっちだとlookup -- filtBF cmn fty $ matchFunctions (maxBound', memoDeb) fty -- こっちだとrecompute -- filtBF ty = fmap fromAnnExpr . filterBF tcl rtrie ty . fmap (toAnnExprWind (execute opt) ty) . tabulate --filtBF cmn ty = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . mapDepthDB uniqSorter -- . mondepth filtBF cmn ty | classify = dbToCumulativeMx . fmap fromAnnExpr . fDM cmn ty . fmap (toAnnExprWind (execute (opt cmn) (vl cmn)) ty) . (\(DB g) -> DB (\d -> -- trace (shows (length (g d)) $ ('\t':) $ shows d $ ('\t':) $ show ty) $ uniqSorter (g d))) | otherwise = toMx . mapDepthDB uniqSorter fDM = filterDM -- こっちが従来 -- fDM = filterDMlite -- depth bound(つまり，Int->[(a,Int)]における引数のInt)の代わりに，depth boundからの距離(つまり，Int->[(a,Int)]におけるInt->[(a,ここのInt)])を使ってnrndsの何番目かを決めるもの． -- filterDMと違って，同じdepth boundでも違う乱数を使うので，filterList同様depthを跨いだfiltrationができず，結果はいまいち． -- ただし，dynamicな関数自体をメモ化すれば，格段にメモにヒットしやすくなるはず． lmtty mt fty = traceTy fty $ lookupMT mt fty --memocond i = 3 ProgramGenerator (PGSF e) where mkTrieOpt cmn tcesopt tces = PGSF (mkTrieOptSF cmn tcesopt tces) matchingPrograms ty (PGSF x) = fromMx $ matchProgs x ty unifyingPrograms ty px@(PGSF x) = catBags $ fromDB $ fmap (\ (es,_,_) -> map (toAnnExpr $ reducer px) es) $ unifyingPossibilities ty x extractCommon (PGSF (_,_,cmn)) = cmn unifyingPossibilities ty memodeb = unPS (unifyableExprs memodeb [] ty) emptySubst 0 matchProgs :: Expression e => MemoDeb e -> Type -> Matrix AnnExpr matchProgs memodeb ty = fmap (toAnnExprWindWind (reducer $ PGSF memodeb) ty) $ lmt memodeb $ normalize $ unquantify ty -- こっちだとlookup {- matchProgs memodeb ty = fmap toAnnExpr $ wind (fmap (mapCE Lambda)) (lookupFuns memodeb) [] (quantify ty) -- こっちだとrecompute というと語弊がある．recomputeしたきゃlmtのところを変えるべし． -- matchProgsのみの下請け，matchFunsと交換可能 lookupFuns :: (Expression e, Ord e) => MemoDeb e -> [Type] -> Type -> BF e lookupFuns memodeb@((_,mt),_,tcl,rtrie) avail reqret = {- #ifdef CLASSIFY fmap fromAnnExpr $ toRc $ filterDM tcl rtrie ty $ fromRc $ fmap (toAnnExprWind ty) $ #endif -} -- mapDepth uniqSort $ matchFuns memodeb avail reqret where ty = popArgs avail reqret -} specializedPossibleTypes :: Expression e => Type -> MemoDeb e -> Recomp Type specializedPossibleTypes ty memodeb = runPS (fmap (\(av,t) -> popArgs av t) $ specializedTypes memodeb [] ty) -- specializedPossibleTypes ty memodeb@(_,((mt,_),_,_,_)) = fmap (\(_,s,_) -> apply s ty) $ toRc $ lmtty mt ty type MemoDeb e = (MemoTrie e, (([Prim],[Prim]),([Prim],[Prim])), Common) mkTrieOptSF :: Expression e => Common -> [Typed [CoreExpr]] -> [Typed [CoreExpr]] -> MemoDeb e mkTrieOptSF cmn txsopt txs = let memoDeb = (memoTrie, (qtlopt,qtl), cmn) -- memoTrie :: MemoTrie memoTrie = (typeTrie,expTrie) typeTrie = mkMTty (tcl cmn) (\ty -> freezePS ty (specTypes memoDeb ty)) expTrie = mkMTexp (tcl cmn) (\ty -> filtBF cmn ty $ matchFunctions memoDeb ty) in memoDeb where qtlopt = splitPrims txsopt qtl = splitPrims txs dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a -- dbToCumulativeMx (DB f) = Mx $ map (map fst . f) [0..] dbToCumulativeMx (DB f) = let foo = map (sort . map fst . f) [0..] in Mx $ zipWith (diffSortedBy compare) foo ([]:foo) -- in Mx $ zipWith (\\) foo ([]:foo) mkMTty = mkMT mkMTexp = mkMT mondepth = zipDepthRc (\d xs -> trace ("depth="++show d++", and the length is "++show (length xs)) xs) -- depthと表示するなら+1するべきであった．(0から始まるので) type BFT = Recomp unBFM = unMx {- freezePS :: (Search m, Expression e) => Type -> PriorSubsts m (ExpTip e) -> Matrix (ExpTip e,Subst,Int) freezePS ty ps = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) in Mx $ map (tokoro10ap ty) $ scanl1 (++) $ unMx $ toMx $ unPS ps emptySubst (mxty+1) -} freezePS :: Type -> PriorSubsts DBound (ExpTip e) -> Matrix ([e],Subst,Int) freezePS ty ps = let mxty = maxVarID ty -- `max` maximum (map maxVarID avail) in zipDepthMx (\d tups -> map (\(Mx xss, s, i)->(xss!!d, s, i)) $ tokoro10ap ty tups) $ toMx $ fmap fst $ Rc $ unDB $ unPS ps emptySubst (mxty+1) -- MemoStingy.tokoro10 is different from T10.tokoro10, in that duplicates will be removed. -- (Note that the type can be specialized to [(Type,k,i)] -> [(Type,k,i)]) tokoro10 :: (Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)] tokoro10 = mergesortWithBy const (\ (_,k,_) (_,l,_) -> k `compare` l) -- tokoro10fstfst = mergesortWithBy const (\ ((k,_),_,_) ((l,_),_,_) -> k `compare` l) tokoro10ap :: Type -> [(a,Subst,i)] -> [(a,Subst,i)] tokoro10ap ty = mergesortWithBy const (\ (_,k,_) (_,l,_) -> normalize (apply k ty) `compare` normalize (apply l ty)) -- availにしろTypeにしろapplyされている． -- だからこそ，runAnotherPS的にemptySubstに対して実行した方が効率的なはず？ でも，Substitutionってそんなにでかくならなかったのでは？FiniteMapでもassoc listでも変わらなかった気が． specializedTypes :: (Search m, Expression e) => MemoDeb e -> [Type] -> Type -> PriorSubsts m ([Type],Type) specializedTypes memodeb avail t = do specializedCases memodeb avail t subst <- getSubst return (map (apply subst) avail, apply subst t) -- specializedCases is the same as unifyableExprs, except that the latter returns PriorSubsts BF [CoreExpr], and that the latter considers memodepth. specializedCases, specCases, specCases' :: (Search m, Expression e) => MemoDeb e -> [Type] -> Type -> PriorSubsts m () specializedCases memodeb = applyDo (specCases memodeb) specCases memodeb = wind_ (\avail reqret -> reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail) {- どっちがわかりやすいかは不明 specCases memodeb avail (t0:->t1) = specCases memodeb (t0 : avail) t1 specCases memodeb avail reqret = reorganize_ (\newavail -> uniExprs_ memodeb newavail reqret) avail -} uniExprs_ :: (Search m, Expression e) => MemoDeb e -> [Type] -> Type -> PriorSubsts m () uniExprs_ memodeb avail t = convertPS fromRc $ psListToPSRecomp lfp where lfp depth | memocond depth = lookupUniExprs memodeb avail t depth >> return () | otherwise = makeUniExprs memodeb avail t depth >> return () lookupUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] [e] lookupUniExprs memodeb@((mt,_),_,_) avail t depth = lookupNormalized (\tn -> unMx (lmtty mt tn) !! depth) avail t makeUniExprs :: Expression e => MemoDeb e -> [Type] -> Type -> Int -> PriorSubsts [] Type makeUniExprs memodeb avail t depth = convertPS tokoro10fst $ do psRecompToPSList (reorganize_ (\av -> specCases' memodeb av t) avail) depth sub <- getSubst return $ quantify (apply sub $ popArgs avail t) -- entry point for memoization specTypes :: (Search m, Expression e) => MemoDeb e -> Type -> PriorSubsts m (ExpTip e) specTypes memodeb@((_,mt),_,_) ty = do let (avail,t) = splitArgs ty reorganize_ (\av -> specCases' memodeb av t) avail -- quantifyはmemo先で既にやられているので不要 typ <- applyPS ty return (lmt memodeb $ normalize $ unquantify typ) funApSub_ :: Search m => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m ()) -> Type -> PriorSubsts m () funApSub_ lltbehalf behalf (t:>ts) = do lltbehalf t funApSub_ lltbehalf behalf ts funApSub_ lltbehalf behalf (t:->ts) = do behalf t funApSub_ lltbehalf behalf ts funApSub_ lltbehalf behalf _t = return () funApSub_spec behalf = funApSub_ behalf behalf -- specCases' trie prims@(primgen,primmono) avail reqret = msum (map (retMono.fromPrim) primmono) `mplus` msum (map retMono fromAvail ++ map retGen primgen) specCases' memodeb@((ttrie,etrie), (prims@(primgen,primmono),_),cmn) avail reqret = msum (map retPrimMono primmono ++ map retMono avail ++ map retGen primgen) where fas | constrL $ opt cmn = funApSub_ lltbehalf behalf | otherwise = funApSub_spec behalf where behalf = specializedCases memodeb avail lltbehalf = flip mguAssumptions_ avail -- retPrimMono :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () retPrimMono (arity, retty, numtvs, _xs:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs mguPS reqret (mapTV (tvid+) retty) fas (mapTV (tvid+) ty) -- retMono :: Type -> PriorSubsts BFT () retMono ty = napply (getArity ty) delayPS $ do mguPS reqret (getRet ty) fas ty -- retGen :: (Int, Type, Int, Typed [CoreExpr]) -> PriorSubsts BFT () retGen (arity, _r, numtvs, _s:::ty) = napply arity delayPS $ do tvid <- reserveTVars numtvs -- この（最初の）IDそのもの（つまり返り値のtvID）はすぐに使われなくなる -- let typ = apply (unitSubst tvid reqret) (mapTV (tvid+) ty) -- mapTVとapplyはhylo-fusionできるはずだが，勝手にされる？ -- -- unitSubstをinlineにしないと駄目か mkSubsts (tvndelay $ opt cmn) tvid reqret fas (mapTV (tvid+) ty) gentvar <- applyPS (TV tvid) guard (orderedAndUsedArgs gentvar) fas gentvar type Generator m e = MemoDeb e -> [Type] -> Type -> PriorSubsts m [e] unifyableExprs :: Expression e => Generator DBound e unifyableExprs memodeb avails ty = convertPS fromRc $ unifyableExprs' memodeb avails ty unifyableExprs' :: Expression e => Generator Recomp e unifyableExprs' memodeb = applyDo (wind (fmap (map (mapCE Lambda))) (lookupNormalized (lookupTypeTrie memodeb))) lookupTypeTrie :: Expression e => MemoDeb e -> Type -> Recomp ([e], Subst, Int) lookupTypeTrie ((mt,_), _, _) t = toRc $ lmtty mt t lookupNormalized :: MonadPlus m => (Type -> m (e, Subst, Int)) -> [Type] -> Type -> PriorSubsts m e lookupNormalized fun avail t = do mx <- getMx let typ = popArgs avail t (tn, decoder) = encode typ mx (es, sub, m) <- mkPS (fun tn) updatePS (retrieve decoder sub) updateMx (m+) return es tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)] tokoro10fst = mergesortWithBy const (\ (k,_,_) (l,_,_) -> k `compare` l) -- entry for memoization matchFunctions :: Expression e => MemoDeb e -> Type -> DBound e matchFunctions memodeb ty = case splitArgs (quantify ty) of (avail,t) -> matchFuns memodeb avail t matchFuns :: Expression e => MemoDeb e -> [Type] -> Type -> DBound e matchFuns memodeb avail reqret = catBags $ runPS (matchFuns' unifyableExprs memodeb avail reqret) matchFuns' :: (Search m, Expression e) => Generator m e -> Generator m e -- matchFuns' = generateFuns matchPS filtExprs lookupListrie -- MemoDebの型の違いでこれはうまくいかなんだ． matchFuns' rec md@(_, (_,(primgen,primmono)),cmn) avail reqret = let behalf = rec md avail lltbehalf = lookupListrie lenavails rec md avail -- heuristic filtration lenavails = length avail -- fe :: Type -> Type -> [CoreExpr] -> [CoreExpr] -- ^ heuristic filtration fe = filtExprs (guess $ opt cmn) in fromAssumptions (PGSF md) lenavails behalf matchPS reqret avail `mplus` msum (map (retPrimMono (PGSF md) lenavails lltbehalf behalf matchPS reqret) primmono ++ map (( if tv0 $ opt cmn then retGenTV0 else if tv1 $ opt cmn then retGenTV1 else retGenOrd) (PGSF md) lenavails fe lltbehalf behalf reqret) primgen) lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e lookupListrie lenavails rec memodeb@(_,_,cmn) avail t | constrL opts = matchAssumptions (PGSF memodeb) lenavails t avail | guess opts = do args <- rec memodeb avail t let args' = filter (not.isClosed.toCE) args when (null args') mzero return args' | otherwise = rec memodeb avail t where opts = opt cmn filtExprs :: Expression e => Bool -> Type -> Type -> [e] -> [e] filtExprs g a b | g = filterExprs a b | otherwise = id \end{code}