\begin{code}
{-# LANGUAGE CPP, RelaxedPolyRec, FlexibleInstances #-}
module MagicHaskeller.ProgGenSF(ProgGenSF, PGSF(..), freezePS, funApSub_, funApSub_spec, lookupNormalized, tokoro10fst, mkTrieOptSFIO) 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.Instantiate
import MagicHaskeller.ProgramGenerator
import MagicHaskeller.ClassLib(mkCL, ClassLib(..), mguPrograms)
import MagicHaskeller.Options(Opt(..))
import MagicHaskeller.Expression
import Data.Monoid
import MagicHaskeller.T10(mergesortWithBy, diffSortedBy)
import qualified Data.Map as M
import MagicHaskeller.DebMT
import Data.Function(fix)
import System.IO(fixIO)
import System.IO.Unsafe(unsafeInterleaveIO)
import Data.Bits
import Data.Word
import Data.Array
#if __GLASGOW_HASKELL__ >= 710
import Prelude hiding ((<$>))
#endif
import Debug.Trace
reorganize_ :: ([a] -> t) -> [a] -> t
reorganize_ [a] -> t
f [a]
av = [a] -> t
f ([a] -> t) -> [a] -> t
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> (a -> a -> Ordering) -> [a] -> [a]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy a -> a -> a
forall a b. a -> b -> a
const a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [a]
av
reorganizer' :: a -> a
reorganizer' = a -> a
forall a. a -> a
id
reorganizerId' :: (Functor m, Expression e) => ([Type] -> m e) -> [Type] -> m e
reorganizerId' :: ([Type] -> m e) -> [Type] -> m e
reorganizerId' = ([Type] -> m e) -> [Type] -> m e
forall e (m :: * -> *).
(Expression e, Functor m) =>
([Type] -> m e) -> [Type] -> m e
reorganizeId'
classify :: Bool
classify = Bool
True
traceExpTy :: p -> a -> a
traceExpTy p
_ = a -> a
forall a. a -> a
id
traceTy :: p -> a -> a
traceTy p
_ = a -> a
forall a. a -> a
id
type ProgGenSF = PGSF CoreExpr
data PGSF e = PGSF (MemoDeb e) TypeTrie (ExpTrie e)
type ExpTip e = Matrix e
type ExpTrie e = MapType (ExpTip e)
type TypeTrie = MapType (Matrix (Type, Subst, TyVar))
lmt :: Expression e => ExpTrie e -> Type -> Matrix e
lmt :: ExpTrie e -> Type -> Matrix e
lmt ExpTrie e
mt Type
fty = Type -> Matrix e -> Matrix e
forall p a. p -> a -> a
traceExpTy Type
fty (Matrix e -> Matrix e) -> Matrix e -> Matrix e
forall a b. (a -> b) -> a -> b
$
ExpTrie e -> Type -> Matrix e
forall a. MapType a -> Type -> a
lookupMT ExpTrie e
mt Type
fty
filtBF :: Expression e => Common -> Type -> Recomp e -> Matrix e
filtBF :: Common -> Type -> Recomp e -> Matrix e
filtBF Common
cmn Type
ty | Bool
classify = DBound e -> Matrix e
forall a. Ord a => DBound a -> Matrix a
dbToCumulativeMx (DBound e -> Matrix e)
-> (Recomp e -> DBound e) -> Recomp e -> Matrix e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnExpr -> e) -> DBound AnnExpr -> DBound e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnExpr -> e
forall e. Expression e => AnnExpr -> e
fromAnnExpr (DBound AnnExpr -> DBound e)
-> (Recomp e -> DBound AnnExpr) -> Recomp e -> DBound e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Common -> Type -> DBound AnnExpr -> DBound AnnExpr
fDM Common
cmn Type
ty (DBound AnnExpr -> DBound AnnExpr)
-> (Recomp e -> DBound AnnExpr) -> Recomp e -> DBound AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> AnnExpr) -> DBound e -> DBound AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWind (Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
vl Common
cmn)) Type
ty) (DBound e -> DBound AnnExpr)
-> (Recomp e -> DBound e) -> Recomp e -> DBound AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Recomp e -> DBound e
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp e -> DBound e)
-> (Recomp e -> Recomp e) -> Recomp e -> DBound e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort
| Bool
otherwise = Recomp e -> Matrix e
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx (Recomp e -> Matrix e)
-> (Recomp e -> Recomp e) -> Recomp e -> Matrix e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort
fDM :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr
fDM = Common -> Type -> DBound AnnExpr -> DBound AnnExpr
forall (m :: * -> *).
DB m =>
Common -> Type -> m AnnExpr -> m AnnExpr
filterDM
filtBFIO :: Expression e => Common -> Type -> Recomp e -> IO (Matrix e)
filtBFIO :: Common -> Type -> Recomp e -> IO (Matrix e)
filtBFIO Common
cmn Type
ty Recomp e
rc | Bool
classify = DBoundT IO e -> IO (Matrix e)
forall a. Ord a => DBoundT IO a -> IO (Matrix a)
dbtToCumulativeMx (DBoundT IO e -> IO (Matrix e)) -> DBoundT IO e -> IO (Matrix e)
forall a b. (a -> b) -> a -> b
$ (AnnExpr -> e) -> DBoundT IO AnnExpr -> DBoundT IO e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnExpr -> e
forall e. Expression e => AnnExpr -> e
fromAnnExpr (DBoundT IO AnnExpr -> DBoundT IO e)
-> DBoundT IO AnnExpr -> DBoundT IO e
forall a b. (a -> b) -> a -> b
$ Common -> Type -> DBound AnnExpr -> DBoundT IO AnnExpr
filterDMIO Common
cmn Type
ty (DBound AnnExpr -> DBoundT IO AnnExpr)
-> DBound AnnExpr -> DBoundT IO AnnExpr
forall a b. (a -> b) -> a -> b
$ (e -> AnnExpr) -> DBound e -> DBound AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWind (Opt () -> VarLib -> CoreExpr -> Dynamic
forall a. Opt a -> VarLib -> CoreExpr -> Dynamic
execute (Common -> Opt ()
opt Common
cmn) (Common -> VarLib
vl Common
cmn)) Type
ty) (DBound e -> DBound AnnExpr) -> DBound e -> DBound AnnExpr
forall a b. (a -> b) -> a -> b
$ Recomp e -> DBound e
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp e -> DBound e) -> Recomp e -> DBound e
forall a b. (a -> b) -> a -> b
$ (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort Recomp e
rc
| Bool
otherwise = Matrix e -> IO (Matrix e)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matrix e -> IO (Matrix e)) -> Matrix e -> IO (Matrix e)
forall a b. (a -> b) -> a -> b
$ Recomp e -> Matrix e
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx (Recomp e -> Matrix e) -> Recomp e -> Matrix e
forall a b. (a -> b) -> a -> b
$ (Bag e -> Bag e) -> Recomp e -> Recomp e
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag e -> Bag e
forall a. Ord a => [a] -> [a]
uniqSort Recomp e
rc
lmtty :: MapType a -> Type -> a
lmtty MapType a
mt Type
fty = Type -> a -> a
forall p a. p -> a -> a
traceTy Type
fty (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
MapType a -> Type -> a
forall a. MapType a -> Type -> a
lookupMT MapType a
mt Type
fty
memocond :: p -> Bool
memocond p
i = Bool
True
instance (Expression e) => ProgramGenerator (PGSF e) where
mkTrieOpt :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
mkTrieOpt = Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
forall e.
Expression e =>
Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
mkTrieOptSF
matchingProgramsWOAbsents :: Type -> PGSF e -> m AnnExpr
matchingProgramsWOAbsents Type
ty (PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
etrie) = Matrix AnnExpr -> m AnnExpr
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx (Matrix AnnExpr -> m AnnExpr) -> Matrix AnnExpr -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ (Int -> Bag AnnExpr -> Bag AnnExpr)
-> Matrix AnnExpr -> Matrix AnnExpr
forall a b. (Int -> Bag a -> Bag b) -> Matrix a -> Matrix b
zipDepthMx (\Int
i Bag AnnExpr
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Type -> Int
forall i. Integral i => Type -> i
getArity Type
ty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag AnnExpr
es) (Matrix AnnExpr -> Matrix AnnExpr)
-> Matrix AnnExpr -> Matrix AnnExpr
forall a b. (a -> b) -> a -> b
$ Common -> ExpTrie e -> Type -> Matrix AnnExpr
forall e.
Expression e =>
Common -> ExpTrie e -> Type -> Matrix AnnExpr
matchProgs Common
cmn ExpTrie e
etrie Type
ty
matchingPrograms :: Type -> PGSF e -> m AnnExpr
matchingPrograms Type
ty pgsf :: PGSF e
pgsf@(PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
_) = Recomp AnnExpr -> m AnnExpr
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp AnnExpr -> m AnnExpr) -> Recomp AnnExpr -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ (e -> AnnExpr) -> Recomp e -> Recomp AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWindWind (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Type
ty) (Recomp e -> Recomp AnnExpr) -> Recomp e -> Recomp AnnExpr
forall a b. (a -> b) -> a -> b
$ PGSF e -> Type -> Recomp e
forall (m :: * -> *) e.
(Search m, Expression e) =>
PGSF e -> Type -> m e
lookupWithAbsents PGSF e
pgsf Type
ty
unifyingPrograms :: Type -> PGSF e -> m AnnExpr
unifyingPrograms Type
ty pgsf :: PGSF e
pgsf@(PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
_) = m (Bag AnnExpr) -> m AnnExpr
forall (m :: * -> *) a. Search m => m (Bag a) -> m a
catBags (m (Bag AnnExpr) -> m AnnExpr) -> m (Bag AnnExpr) -> m AnnExpr
forall a b. (a -> b) -> a -> b
$ Recomp (Bag AnnExpr) -> m (Bag AnnExpr)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp (Bag AnnExpr) -> m (Bag AnnExpr))
-> Recomp (Bag AnnExpr) -> m (Bag AnnExpr)
forall a b. (a -> b) -> a -> b
$ ((([e], BitSet), Subst, TyVar) -> Bag AnnExpr)
-> Recomp (([e], BitSet), Subst, TyVar) -> Recomp (Bag AnnExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (([e]
es,BitSet
_),Subst
_,TyVar
_) -> (e -> AnnExpr) -> [e] -> Bag AnnExpr
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> e -> AnnExpr
forall e. Expression e => (CoreExpr -> Dynamic) -> e -> AnnExpr
toAnnExpr ((CoreExpr -> Dynamic) -> e -> AnnExpr)
-> (CoreExpr -> Dynamic) -> e -> AnnExpr
forall a b. (a -> b) -> a -> b
$ Common -> CoreExpr -> Dynamic
reducer Common
cmn) [e]
es) (Recomp (([e], BitSet), Subst, TyVar) -> Recomp (Bag AnnExpr))
-> Recomp (([e], BitSet), Subst, TyVar) -> Recomp (Bag AnnExpr)
forall a b. (a -> b) -> a -> b
$ Type -> PGSF e -> Recomp (([e], BitSet), Subst, TyVar)
forall e.
Expression e =>
Type -> PGSF e -> Recomp (([e], BitSet), Subst, TyVar)
unifyingPossibilities Type
ty PGSF e
pgsf
instance Expression e => WithCommon (PGSF e) where
extractCommon :: PGSF e -> Common
extractCommon (PGSF (ClassLib e
_,(([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_,Common
cmn) TypeTrie
_ ExpTrie e
_) = Common
cmn
unifyingPossibilities :: Type -> PGSF e -> Recomp (([e], BitSet), Subst, TyVar)
unifyingPossibilities Type
ty PGSF e
memodeb = PriorSubsts Recomp ([e], BitSet)
-> Subst -> TyVar -> Recomp (([e], BitSet), Subst, TyVar)
forall (m :: * -> *) a.
PriorSubsts m a -> Subst -> TyVar -> m (a, Subst, TyVar)
unPS (Generator Recomp e
forall e. Expression e => Generator Recomp e
unifyableExprs PGSF e
memodeb [] Type
ty) Subst
forall a. [a]
emptySubst TyVar
0
matchProgs :: Expression e => Common -> ExpTrie e -> Type -> Matrix AnnExpr
matchProgs :: Common -> ExpTrie e -> Type -> Matrix AnnExpr
matchProgs Common
cmn ExpTrie e
etrie Type
ty = (e -> AnnExpr) -> Matrix e -> Matrix AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
forall e.
Expression e =>
(CoreExpr -> Dynamic) -> Type -> e -> AnnExpr
toAnnExprWindWind (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Type
ty) (Matrix e -> Matrix AnnExpr) -> Matrix e -> Matrix AnnExpr
forall a b. (a -> b) -> a -> b
$ ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
etrie Type
ty
specializedPossibleTypes :: Type -> MemoDeb CoreExpr -> TypeTrie -> Recomp Type
specializedPossibleTypes :: Type -> MemoDeb CoreExpr -> TypeTrie -> Recomp Type
specializedPossibleTypes Type
ty MemoDeb CoreExpr
memodeb TypeTrie
ttrie = PriorSubsts Recomp Type -> Recomp Type
forall (m :: * -> *) a. Monad m => PriorSubsts m a -> m a
runPS ((([Type], Type) -> Type)
-> PriorSubsts Recomp ([Type], Type) -> PriorSubsts Recomp Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([Type]
av,Type
t) -> [Type] -> Type -> Type
popArgs [Type]
av Type
t) (PriorSubsts Recomp ([Type], Type) -> PriorSubsts Recomp Type)
-> PriorSubsts Recomp ([Type], Type) -> PriorSubsts Recomp Type
forall a b. (a -> b) -> a -> b
$ MemoDeb CoreExpr
-> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ([Type], Type)
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e
-> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type], Type)
specializedTypes MemoDeb CoreExpr
memodeb TypeTrie
ttrie [] Type
ty)
type MemoDeb e = (ClassLib e, (([[Prim]],[[Prim]]),([[Prim]],[[Prim]])), Common)
mkTrieOptSF :: Expression e => Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> PGSF e
mkTrieOptSF :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> PGSF e
mkTrieOptSF Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
txsopt [[Typed [CoreExpr]]]
txs
= (PGSF e -> PGSF e) -> PGSF e
forall a. (a -> a) -> a
fix ((PGSF e -> PGSF e) -> PGSF e) -> (PGSF e -> PGSF e) -> PGSF e
forall a b. (a -> b) -> a -> b
$ \PGSF e
pgsf -> MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
forall e. MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
PGSF MemoDeb e
memoDeb TypeTrie
typeTrie (ExpTrie e -> PGSF e) -> ExpTrie e -> PGSF e
forall a b. (a -> b) -> a -> b
$ TyConLib -> (Type -> Matrix e) -> ExpTrie e
forall a. TyConLib -> (Type -> a) -> MapType a
mkMTexp (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Common -> Type -> Recomp e -> Matrix e
forall e. Expression e => Common -> Type -> Recomp e -> Matrix e
filtBF Common
cmn Type
ty (Recomp e -> Matrix e) -> Recomp e -> Matrix e
forall a b. (a -> b) -> a -> b
$ PGSF e -> Type -> Recomp e
forall e. Expression e => PGSF e -> Type -> Recomp e
matchFunctions PGSF e
pgsf Type
ty)
where qtlopt :: ([[Prim]], [[Prim]])
qtlopt = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txsopt
qtl :: ([[Prim]], [[Prim]])
qtl = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txs
memoDeb :: MemoDeb e
memoDeb = (Common -> [Typed [CoreExpr]] -> ClassLib e
forall e.
Expression e =>
Common -> [Typed [CoreExpr]] -> ClassLib e
mkCL Common
cmn [Typed [CoreExpr]]
classes, (([[Prim]], [[Prim]])
qtlopt,([[Prim]], [[Prim]])
qtl), Common
cmn)
typeTrie :: TypeTrie
typeTrie = TyConLib -> (Type -> Matrix (Type, Subst, TyVar)) -> TypeTrie
forall a. TyConLib -> (Type -> a) -> MapType a
mkMTty (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
ty (MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memoDeb TypeTrie
typeTrie Type
ty))
dbToCumulativeMx :: (Ord a) => DBound a -> Matrix a
dbToCumulativeMx :: DBound a -> Matrix a
dbToCumulativeMx (DB Int -> Bag (a, Int)
f) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag a) -> Matrix a) -> Stream (Bag a) -> Matrix a
forall a b. (a -> b) -> a -> b
$ case (Int -> Bag a) -> [Int] -> Stream (Bag a)
forall a b. (a -> b) -> [a] -> [b]
map (Bag a -> Bag a
forall a. Ord a => [a] -> [a]
sort (Bag a -> Bag a) -> (Int -> Bag a) -> Int -> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int) -> a) -> Bag (a, Int) -> Bag a
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> a
forall a b. (a, b) -> a
fst (Bag (a, Int) -> Bag a) -> (Int -> Bag (a, Int)) -> Int -> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bag (a, Int)
f) [Int
0..] of
Stream (Bag a)
xss -> let result :: Stream (Bag a)
result = (Bag a -> Bag a -> Bag a)
-> Stream (Bag a) -> Stream (Bag a) -> Stream (Bag a)
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> a -> Ordering) -> Bag a -> Bag a -> Bag a
forall a t. (a -> t -> Ordering) -> [a] -> [t] -> [a]
diffSortedBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) Stream (Bag a)
xss (Stream (Bag a) -> Stream (Bag a))
-> Stream (Bag a) -> Stream (Bag a)
forall a b. (a -> b) -> a -> b
$ (Bag a -> Bag a -> Bag a)
-> Bag a -> Stream (Bag a) -> Stream (Bag a)
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Bag a -> Bag a -> Bag a
forall a. [a] -> [a] -> [a]
(++) [] Stream (Bag a)
result in Stream (Bag a)
result
mkTrieOptSFIO :: Expression e => Common -> [Typed [CoreExpr]] -> [[Typed [CoreExpr]]] -> [[Typed [CoreExpr]]] -> IO (PGSF e)
mkTrieOptSFIO :: Common
-> [Typed [CoreExpr]]
-> [[Typed [CoreExpr]]]
-> [[Typed [CoreExpr]]]
-> IO (PGSF e)
mkTrieOptSFIO Common
cmn [Typed [CoreExpr]]
classes [[Typed [CoreExpr]]]
txsopt [[Typed [CoreExpr]]]
txs
= (PGSF e -> IO (PGSF e)) -> IO (PGSF e)
forall a. (a -> IO a) -> IO a
fixIO ((PGSF e -> IO (PGSF e)) -> IO (PGSF e))
-> (PGSF e -> IO (PGSF e)) -> IO (PGSF e)
forall a b. (a -> b) -> a -> b
$ \PGSF e
pgsf -> (ExpTrie e -> PGSF e) -> IO (ExpTrie e) -> IO (PGSF e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
forall e. MemoDeb e -> TypeTrie -> ExpTrie e -> PGSF e
PGSF MemoDeb e
memoDeb TypeTrie
typeTrie) (IO (ExpTrie e) -> IO (PGSF e)) -> IO (ExpTrie e) -> IO (PGSF e)
forall a b. (a -> b) -> a -> b
$ TyConLib -> (Type -> IO (Matrix e)) -> IO (ExpTrie e)
forall a. TyConLib -> (Type -> IO a) -> IO (MapType a)
mkMTIO (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Common -> Type -> Recomp e -> IO (Matrix e)
forall e.
Expression e =>
Common -> Type -> Recomp e -> IO (Matrix e)
filtBFIO Common
cmn Type
ty (Recomp e -> IO (Matrix e)) -> Recomp e -> IO (Matrix e)
forall a b. (a -> b) -> a -> b
$ PGSF e -> Type -> Recomp e
forall e. Expression e => PGSF e -> Type -> Recomp e
matchFunctions PGSF e
pgsf Type
ty)
where qtlopt :: ([[Prim]], [[Prim]])
qtlopt = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txsopt
qtl :: ([[Prim]], [[Prim]])
qtl = [[Typed [CoreExpr]]] -> ([[Prim]], [[Prim]])
splitPrimss [[Typed [CoreExpr]]]
txs
memoDeb :: MemoDeb e
memoDeb = (Common -> [Typed [CoreExpr]] -> ClassLib e
forall e.
Expression e =>
Common -> [Typed [CoreExpr]] -> ClassLib e
mkCL Common
cmn [Typed [CoreExpr]]
classes, (([[Prim]], [[Prim]])
qtlopt,([[Prim]], [[Prim]])
qtl), Common
cmn)
typeTrie :: TypeTrie
typeTrie = TyConLib -> (Type -> Matrix (Type, Subst, TyVar)) -> TypeTrie
forall a. TyConLib -> (Type -> a) -> MapType a
mkMTty (Common -> TyConLib
tcl Common
cmn) (\Type
ty -> Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
ty (MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memoDeb TypeTrie
typeTrie Type
ty))
dbtToCumulativeMx :: (Ord a) => DBoundT IO a -> IO (Matrix a)
dbtToCumulativeMx :: DBoundT IO a -> IO (Matrix a)
dbtToCumulativeMx (DBT Int -> IO (Bag (a, Int))
f) = do [Bag (a, Int)]
ts <- [IO (Bag (a, Int))] -> IO [Bag (a, Int)]
forall a. [IO a] -> IO [a]
interleaveActions ([IO (Bag (a, Int))] -> IO [Bag (a, Int)])
-> [IO (Bag (a, Int))] -> IO [Bag (a, Int)]
forall a b. (a -> b) -> a -> b
$ (Int -> IO (Bag (a, Int))) -> [Int] -> [IO (Bag (a, Int))]
forall a b. (a -> b) -> [a] -> [b]
map Int -> IO (Bag (a, Int))
f [Int
0..]
let xss :: [[a]]
xss = (Bag (a, Int) -> [a]) -> [Bag (a, Int)] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]) -> (Bag (a, Int) -> [a]) -> Bag (a, Int) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int) -> a) -> Bag (a, Int) -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Int) -> a
forall a b. (a, b) -> a
fst) [Bag (a, Int)]
ts
let result :: [[a]]
result = ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> a -> Ordering) -> [a] -> [a] -> [a]
forall a t. (a -> t -> Ordering) -> [a] -> [t] -> [a]
diffSortedBy a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) [[a]]
xss ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> [a] -> [[a]] -> [[a]]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [] [[a]]
result
Matrix a -> IO (Matrix a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Matrix a -> IO (Matrix a)) -> Matrix a -> IO (Matrix a)
forall a b. (a -> b) -> a -> b
$ [[a]] -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx [[a]]
result
mkMTty :: TyConLib -> (Type -> a) -> MapType a
mkMTty = TyConLib -> (Type -> a) -> MapType a
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT
mkMTexp :: TyConLib -> (Type -> a) -> MapType a
mkMTexp = TyConLib -> (Type -> a) -> MapType a
forall a. TyConLib -> (Type -> a) -> MapType a
mkMT
mondepth :: Recomp b -> Recomp b
mondepth = (Int -> Bag b -> Bag b) -> Recomp b -> Recomp b
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
d Bag b
xs -> String -> Bag b -> Bag b
forall a. String -> a -> a
trace (String
"depth="String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
dString -> String -> String
forall a. [a] -> [a] -> [a]
++String
", and the length is "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show (Bag b -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Bag b
xs)) Bag b
xs)
type BFT = Recomp
unBFM :: Matrix a -> Stream (Bag a)
unBFM = Matrix a -> Stream (Bag a)
forall a. Matrix a -> Stream (Bag a)
unMx
freezePS :: Type -> PriorSubsts Recomp Type -> Matrix (Type,Subst,TyVar)
freezePS :: Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
ty PriorSubsts Recomp Type
ps
= let mxty :: TyVar
mxty = Type -> TyVar
maxVarID Type
ty
in (Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar))
-> Matrix (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar)
forall s i. [(Type, s, i)] -> [(Type, s, i)]
tokoro10ap (Matrix (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar))
-> Matrix (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Recomp (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx (Recomp (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar))
-> Recomp (Type, Subst, TyVar) -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ (((Type, Subst, TyVar), Int) -> (Type, Subst, TyVar))
-> Recomp ((Type, Subst, TyVar), Int)
-> Recomp (Type, Subst, TyVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type, Subst, TyVar), Int) -> (Type, Subst, TyVar)
forall a b. (a, b) -> a
fst (Recomp ((Type, Subst, TyVar), Int) -> Recomp (Type, Subst, TyVar))
-> Recomp ((Type, Subst, TyVar), Int)
-> Recomp (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag ((Type, Subst, TyVar), Int))
-> Recomp ((Type, Subst, TyVar), Int)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag ((Type, Subst, TyVar), Int))
-> Recomp ((Type, Subst, TyVar), Int))
-> (Int -> Bag ((Type, Subst, TyVar), Int))
-> Recomp ((Type, Subst, TyVar), Int)
forall a b. (a -> b) -> a -> b
$ DBound (Type, Subst, TyVar)
-> Int -> Bag ((Type, Subst, TyVar), Int)
forall a. DBound a -> Int -> Bag (a, Int)
unDB (DBound (Type, Subst, TyVar)
-> Int -> Bag ((Type, Subst, TyVar), Int))
-> DBound (Type, Subst, TyVar)
-> Int
-> Bag ((Type, Subst, TyVar), Int)
forall a b. (a -> b) -> a -> b
$ Recomp (Type, Subst, TyVar) -> DBound (Type, Subst, TyVar)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp (Type, Subst, TyVar) -> DBound (Type, Subst, TyVar))
-> Recomp (Type, Subst, TyVar) -> DBound (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ PriorSubsts Recomp Type
-> Subst -> TyVar -> Recomp (Type, Subst, TyVar)
forall (m :: * -> *) a.
PriorSubsts m a -> Subst -> TyVar -> m (a, Subst, TyVar)
unPS PriorSubsts Recomp Type
ps Subst
forall a. [a]
emptySubst (TyVar
mxtyTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1)
tokoro10 :: (Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)]
tokoro10 :: [(a, k, i)] -> [(a, k, i)]
tokoro10 = ((a, k, i) -> (a, k, i) -> (a, k, i))
-> ((a, k, i) -> (a, k, i) -> Ordering)
-> [(a, k, i)]
-> [(a, k, i)]
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy (a, k, i) -> (a, k, i) -> (a, k, i)
forall a b. a -> b -> a
const (\ (a
_,k
k,i
_) (a
_,k
l,i
_) -> k
k k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` k
l)
tokoro10ap :: [(Type,s,i)] -> [(Type,s,i)]
tokoro10ap :: [(Type, s, i)] -> [(Type, s, i)]
tokoro10ap = Map Type (Type, s, i) -> [(Type, s, i)]
forall k a. Map k a -> [a]
M.elems (Map Type (Type, s, i) -> [(Type, s, i)])
-> ([(Type, s, i)] -> Map Type (Type, s, i))
-> [(Type, s, i)]
-> [(Type, s, i)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, s, i) -> (Type, s, i) -> (Type, s, i))
-> [(Type, (Type, s, i))] -> Map Type (Type, s, i)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (Type, s, i) -> (Type, s, i) -> (Type, s, i)
forall a b. a -> b -> a
const ([(Type, (Type, s, i))] -> Map Type (Type, s, i))
-> ([(Type, s, i)] -> [(Type, (Type, s, i))])
-> [(Type, s, i)]
-> Map Type (Type, s, i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, s, i) -> (Type, (Type, s, i)))
-> [(Type, s, i)] -> [(Type, (Type, s, i))]
forall a b. (a -> b) -> [a] -> [b]
map (\ t :: (Type, s, i)
t@(Type
ty,s
_,i
_) -> ( Type
ty, (Type, s, i)
t))
fps :: Search m => TyVar -> PriorSubsts m e -> m (e,[(TyVar, Type)],TyVar)
fps :: TyVar -> PriorSubsts m e -> m (e, Subst, TyVar)
fps TyVar
mxty (PS Subst -> TyVar -> m (e, Subst, TyVar)
f) = do (e
exprs, Subst
sub, TyVar
m) <- Subst -> TyVar -> m (e, Subst, TyVar)
f Subst
forall a. [a]
emptySubst (TyVar
mxtyTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1)
(e, Subst, TyVar) -> m (e, Subst, TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (e
exprs, Subst -> TyVar -> Subst
filterSubst Subst
sub TyVar
mxty, TyVar
m)
where filterSubst :: Subst -> TyVar -> [(TyVar, Type)]
filterSubst :: Subst -> TyVar -> Subst
filterSubst Subst
sub TyVar
mx = [ (TyVar, Type)
t | t :: (TyVar, Type)
t@(TyVar
i,Type
_) <- Subst
sub, (TyVar, TyVar) -> TyVar -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (TyVar
0,TyVar
mx) TyVar
i ]
specializedTypes :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type],Type)
specializedTypes :: MemoDeb e
-> TypeTrie -> [Type] -> Type -> PriorSubsts m ([Type], Type)
specializedTypes MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
t = do BitSet
_ <- MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
t
Subst
subst <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
([Type], Type) -> PriorSubsts m ([Type], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Type -> Type
apply Subst
subst) [Type]
avail, Subst -> Type -> Type
apply Subst
subst Type
t)
specializedCases, specCases :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases MemoDeb e
memodeb TypeTrie
ttrie = ([Type] -> Type -> PriorSubsts m BitSet)
-> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo (MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specCases MemoDeb e
memodeb TypeTrie
ttrie)
specCases :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail (Type
t0:->Type
t1) = (BitSet -> BitSet) -> PriorSubsts m BitSet -> PriorSubsts m BitSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) (PriorSubsts m BitSet -> PriorSubsts m BitSet)
-> PriorSubsts m BitSet -> PriorSubsts m BitSet
forall a b. (a -> b) -> a -> b
$ MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specCases MemoDeb e
memodeb TypeTrie
ttrie (Type
t0 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
avail) Type
t1
specCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
reqret = ([Type] -> PriorSubsts m BitSet) -> [Type] -> PriorSubsts m BitSet
forall a t. Ord a => ([a] -> t) -> [a] -> t
reorganize_ (\[Type]
newavail -> MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
uniExprs_ MemoDeb e
memodeb TypeTrie
ttrie [Type]
newavail Type
reqret) [Type]
avail
uniExprs_ :: (Search m, Expression e) => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
uniExprs_ :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
uniExprs_ MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail Type
t
= (Matrix (BitSet, Subst, TyVar) -> m (BitSet, Subst, TyVar))
-> PriorSubsts Matrix BitSet -> PriorSubsts m BitSet
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS Matrix (BitSet, Subst, TyVar) -> m (BitSet, Subst, TyVar)
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx (PriorSubsts Matrix BitSet -> PriorSubsts m BitSet)
-> PriorSubsts Matrix BitSet -> PriorSubsts m BitSet
forall a b. (a -> b) -> a -> b
$ (BitSet -> Type -> BitSet)
-> (Type -> Recomp (Type, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts Matrix BitSet
forall (m :: * -> *) (n :: * -> *) e r.
(Search m, Search n) =>
(BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedSharedBits (\BitSet
ixs Type
_ -> BitSet
ixs) (MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
lookupTypeTrie MemoDeb e
memodeb TypeTrie
ttrie) [Type]
avail Type
t
lookupReorganized :: ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
md Type
typ = let ([Type]
avs, Type
retty) = Type -> ([Type], Type)
splitArgs (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ Type -> Type
normalize Type
typ
in ([Type] -> Matrix e) -> [Type] -> Matrix e
forall (m :: * -> *) e.
(Functor m, Expression e) =>
([Type] -> m e) -> [Type] -> m e
reorganizerId' (\[Type]
av -> ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lmt ExpTrie e
md (Type -> Matrix e) -> Type -> Matrix e
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
popArgs [Type]
av Type
retty) [Type]
avs
specTypes :: Expression e => MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes :: MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memodeb TypeTrie
ttrie Type
ty
= let ([Type]
avail,Type
t) = Type -> ([Type], Type)
splitArgs Type
ty
in (Recomp (Type, Subst, TyVar) -> Recomp (Type, Subst, TyVar))
-> PriorSubsts Recomp Type -> PriorSubsts Recomp Type
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS ((Int -> Bag (Type, Subst, TyVar) -> Bag (Type, Subst, TyVar))
-> Recomp (Type, Subst, TyVar) -> Recomp (Type, Subst, TyVar)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag (Type, Subst, TyVar)
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag (Type, Subst, TyVar)
es)) (PriorSubsts Recomp Type -> PriorSubsts Recomp Type)
-> PriorSubsts Recomp Type -> PriorSubsts Recomp Type
forall a b. (a -> b) -> a -> b
$ do
([Type] -> PriorSubsts Recomp ())
-> [Type] -> PriorSubsts Recomp ()
forall a t. Ord a => ([a] -> t) -> [a] -> t
reorganize_ (\[Type]
av -> MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
specCases' MemoDeb e
memodeb TypeTrie
ttrie [Type]
av Type
t) [Type]
avail
Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS Type
ty
#ifdef SEMIGROUP
instance Semigroup BitSet where
<> :: BitSet -> BitSet -> BitSet
(<>) = BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
(.|.)
#endif
instance Monoid BitSet where
mappend :: BitSet -> BitSet -> BitSet
mappend = BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
(.|.)
mempty :: BitSet
mempty = BitSet
0
funApSub_ :: (Search m, Monoid a) => (Type -> PriorSubsts m ()) -> (Type -> PriorSubsts m a) -> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_ :: (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf (Type
t:=>Type
ts) = do Type -> PriorSubsts m ()
clbehalf Type
t
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
ts
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf (Type
t:>Type
ts) = (a -> a -> a)
-> PriorSubsts m a -> PriorSubsts m a -> PriorSubsts m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (Type -> PriorSubsts m a
lltbehalf Type
t) ((Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
ts)
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf (Type
t:->Type
ts) = (a -> a -> a)
-> PriorSubsts m a -> PriorSubsts m a -> PriorSubsts m a
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (Type -> PriorSubsts m a
behalf Type
t) ((Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
ts)
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
lltbehalf Type -> PriorSubsts m a
behalf Type
_t = a -> PriorSubsts m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
funApSub_spec :: (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_spec Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
behalf = (Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts m a
behalf Type -> PriorSubsts m a
behalf
funApSub_forcingNil :: (Type -> PriorSubsts Recomp ()) -> (Type -> PriorSubsts Recomp BitSet) -> (Type -> PriorSubsts Recomp BitSet) -> Type -> BitSet -> PriorSubsts Recomp ()
funApSub_forcingNil :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
t BitSet
bsf
= (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
t BitSet
bsf ((BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ())
-> (BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ \BitSet
bs -> Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts Recomp ()) -> Bool -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ BitSet
bs BitSet -> BitSet -> Bool
forall a. Eq a => a -> a -> Bool
== BitSet
0
funApSub_forcingNil_spec :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil_spec Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf Type -> PriorSubsts Recomp BitSet
behalf
funApSub_forcingNil_cont :: (Type -> PriorSubsts Recomp ()) -> (Type -> PriorSubsts Recomp BitSet) -> (Type -> PriorSubsts Recomp BitSet) -> Type -> BitSet -> (BitSet->PriorSubsts Recomp a) -> PriorSubsts Recomp a
funApSub_forcingNil_cont :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf (Type
t:=>Type
ts) BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = do Type -> PriorSubsts Recomp ()
clbehalf Type
t
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
ts BitSet
bsf BitSet -> PriorSubsts Recomp a
cont
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf (Type
t:>Type
ts) BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = do BitSet
bse <- Type -> PriorSubsts Recomp BitSet
lltbehalf Type
t
let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
BitSet -> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp a -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall a b. (a -> b) -> a -> b
$
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
ts BitSet
newRemaining BitSet -> PriorSubsts Recomp a
cont
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf (Type
t:->Type
ts) BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = do BitSet
bse <- Type -> PriorSubsts Recomp BitSet
behalf Type
t
let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
BitSet -> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp a -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a -> PriorSubsts Recomp a
forall a b. (a -> b) -> a -> b
$
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
ts BitSet
newRemaining BitSet -> PriorSubsts Recomp a
cont
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf Type
_t BitSet
bsf BitSet -> PriorSubsts Recomp a
cont = BitSet -> PriorSubsts Recomp a
cont BitSet
bsf
funApSub_forcingNil_cont_spec :: (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont_spec Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont Type -> PriorSubsts Recomp ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf Type -> PriorSubsts Recomp BitSet
behalf
mguAssumptionsBits :: (Functor m, MonadPlus m) => Type -> [Type] -> PriorSubsts m BitSet
mguAssumptionsBits :: Type -> [Type] -> PriorSubsts m BitSet
mguAssumptionsBits Type
patty [Type]
assumptions = ([Type] -> Type -> PriorSubsts m BitSet)
-> [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo [Type] -> Type -> PriorSubsts m BitSet
forall (m :: * -> *) a.
(MonadPlus m, Bits a, Num a) =>
[Type] -> Type -> PriorSubsts m a
mguAssumptionsBits' [Type]
assumptions Type
patty
mguAssumptionsBits' :: [Type] -> Type -> PriorSubsts m a
mguAssumptionsBits' [Type]
assumptions Type
patty = [PriorSubsts m a] -> PriorSubsts m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m a] -> PriorSubsts m a)
-> [PriorSubsts m a] -> PriorSubsts m a
forall a b. (a -> b) -> a -> b
$ (Int -> Type -> PriorSubsts m a)
-> [Int] -> [Type] -> [PriorSubsts m a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n Type
t -> Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
patty Type
t PriorSubsts m () -> PriorSubsts m a -> PriorSubsts m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> PriorSubsts m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
1 a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
n)) [Int
0..] [Type]
assumptions
specCases' :: Expression e => MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
specCases' :: MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp ()
specCases' memodeb :: MemoDeb e
memodeb@(CL MemoDeb e
classLib, (prims :: ([[Prim]], [[Prim]])
prims@([[Prim]]
primgen,[[Prim]]
primmono),([[Prim]], [[Prim]])
_),Common
cmn) TypeTrie
ttrie [Type]
avail Type
reqret
= (Prim -> PriorSubsts Recomp ())
-> [[Prim]] -> PriorSubsts Recomp ()
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum Prim -> PriorSubsts Recomp ()
forall i a a.
Integral i =>
(a, i, Type, TyVar, Typed a) -> PriorSubsts Recomp ()
retPrimMono [[Prim]]
primmono PriorSubsts Recomp ()
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` [PriorSubsts Recomp ()] -> PriorSubsts Recomp ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((BitSet -> Type -> PriorSubsts Recomp ())
-> [BitSet] -> [Type] -> [PriorSubsts Recomp ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith BitSet -> Type -> PriorSubsts Recomp ()
retMono ((BitSet -> BitSet) -> BitSet -> [BitSet]
forall a. (a -> a) -> a -> [a]
iterate (BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) BitSet
1) [Type]
avail) PriorSubsts Recomp ()
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (Prim -> PriorSubsts Recomp ())
-> [[Prim]] -> PriorSubsts Recomp ()
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum Prim -> PriorSubsts Recomp ()
forall i a c a.
Integral i =>
(a, i, c, TyVar, Typed a) -> PriorSubsts Recomp ()
retGen [[Prim]]
primgen
where fas :: Type -> PriorSubsts Recomp BitSet
fas | Opt () -> Bool
forall a. Opt a -> Bool
constrL (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> PriorSubsts Recomp BitSet
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a)
-> (Type -> PriorSubsts m a)
-> Type
-> PriorSubsts m a
funApSub_ Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
forall (m :: * -> *). MonadPlus m => Type -> PriorSubsts m BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf
| Bool
otherwise = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> PriorSubsts Recomp BitSet
forall (m :: * -> *) a.
(Search m, Monoid a) =>
(Type -> PriorSubsts m ())
-> (Type -> PriorSubsts m a) -> Type -> PriorSubsts m a
funApSub_spec Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf
fasf :: Type -> BitSet -> PriorSubsts Recomp ()
fasf| Opt () -> Bool
forall a. Opt a -> Bool
constrL (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
forall (m :: * -> *). MonadPlus m => Type -> PriorSubsts m BitSet
lltbehalf Type -> PriorSubsts Recomp BitSet
behalf
| Bool
otherwise = (Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> PriorSubsts Recomp ()
funApSub_forcingNil_spec Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf
behalf :: Type -> PriorSubsts Recomp BitSet
behalf = MemoDeb e
-> TypeTrie -> [Type] -> Type -> PriorSubsts Recomp BitSet
forall (m :: * -> *) e.
(Search m, Expression e) =>
MemoDeb e -> TypeTrie -> [Type] -> Type -> PriorSubsts m BitSet
specializedCases MemoDeb e
memodeb TypeTrie
ttrie [Type]
avail
lltbehalf :: Type -> PriorSubsts m BitSet
lltbehalf Type
ty = Type -> [Type] -> PriorSubsts m BitSet
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> [Type] -> PriorSubsts m BitSet
mguAssumptionsBits Type
ty [Type]
avail
clbehalf :: Type -> PriorSubsts m ()
clbehalf Type
ty = Generator m e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguPrograms MemoDeb e
classLib Type
ty PriorSubsts m [e] -> PriorSubsts m () -> PriorSubsts m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> PriorSubsts m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lenavails :: Int
lenavails = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail
fullBits :: BitSet
fullBits | Int
lenavails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
29 = BitSet
0
| Bool
otherwise = (BitSet
1 BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
lenavails) BitSet -> BitSet -> BitSet
forall a. Num a => a -> a -> a
- BitSet
1
retPrimMono :: (a, i, Type, TyVar, Typed a) -> PriorSubsts Recomp ()
retPrimMono (a
_, i
arity, Type
retty, TyVar
numtvs, a
_xs:::Type
ty)
= i
-> (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
-> PriorSubsts Recomp ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
arity PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$
do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
Type -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
reqret ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
retty)
Type -> BitSet -> PriorSubsts Recomp ()
fasf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) BitSet
fullBits
retMono :: BitSet -> Type -> PriorSubsts Recomp ()
retMono BitSet
ix Type
ty = Integer
-> (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
-> PriorSubsts Recomp ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply (Type -> Integer
forall i. Integral i => Type -> i
getArity Type
ty) PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ do
Type -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
mguPS Type
reqret (Type -> Type
getRet Type
ty)
Type -> BitSet -> PriorSubsts Recomp ()
fasf Type
ty (BitSet -> PriorSubsts Recomp ())
-> BitSet -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ BitSet
fullBits BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
ix
retGen :: (a, i, c, TyVar, Typed a) -> PriorSubsts Recomp ()
retGen (a
_, i
arity, c
_r, TyVar
numtvs, a
_s:::Type
ty) = i
-> (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
-> PriorSubsts Recomp ()
forall i a. Integral i => i -> (a -> a) -> a -> a
napply i
arity PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall (m :: * -> *) a.
Delay m =>
PriorSubsts m a -> PriorSubsts m a
delayPS (PriorSubsts Recomp () -> PriorSubsts Recomp ())
-> PriorSubsts Recomp () -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$
do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
Int -> TyVar -> Type -> PriorSubsts Recomp Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts (Opt () -> Int
forall a. Opt a -> Int
tvndelay (Opt () -> Int) -> Opt () -> Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) TyVar
tvid Type
reqret
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp ())
-> PriorSubsts Recomp ()
forall a.
(Type -> PriorSubsts Recomp ())
-> (Type -> PriorSubsts Recomp BitSet)
-> Type
-> BitSet
-> (BitSet -> PriorSubsts Recomp a)
-> PriorSubsts Recomp a
funApSub_forcingNil_cont_spec Type -> PriorSubsts Recomp ()
forall (m :: * -> *). Search m => Type -> PriorSubsts m ()
clbehalf Type -> PriorSubsts Recomp BitSet
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) BitSet
fullBits ((BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ())
-> (BitSet -> PriorSubsts Recomp ()) -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ \BitSet
i -> do
Type
gentvar <- Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
orderedAndUsedArgs Type
gentvar)
Type -> BitSet -> PriorSubsts Recomp ()
fasf Type
gentvar BitSet
i
lookupWithAbsents :: (Search m, Expression e) => PGSF e -> Type -> m e
lookupWithAbsents :: PGSF e -> Type -> m e
lookupWithAbsents PGSF e
memodeb Type
ty
= case Type -> ([Type], Type)
splitArgs Type
ty of
([Type]
a,Type
r) -> (m e -> m e) -> ([Type] -> Type -> m e) -> [Type] -> Type -> m e
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind ((e -> e) -> m e -> m e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CoreExpr -> CoreExpr) -> e -> e
forall e. Expression e => (CoreExpr -> CoreExpr) -> e -> e
mapCE CoreExpr -> CoreExpr
Lambda)) ((Type -> Recomp ([e], Subst, TyVar)) -> [Type] -> Type -> m e
forall (m :: * -> *) (n :: * -> *) e.
(Search m, Search n, Expression e) =>
(Type -> m ([e], Subst, TyVar)) -> [Type] -> Type -> n e
lookupNormalizedSharedET (PGSF e -> Type -> Recomp ([e], Subst, TyVar)
forall e.
Expression e =>
PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie PGSF e
memodeb)) [Type]
a Type
r
lookupNormalizedSharedET :: (Search m, Search n, Expression e) => (Type -> m ([e], Subst, TyVar)) -> [Type] -> Type -> n e
lookupNormalizedSharedET :: (Type -> m ([e], Subst, TyVar)) -> [Type] -> Type -> n e
lookupNormalizedSharedET Type -> m ([e], Subst, TyVar)
fun [Type]
avail Type
t
= let annAvails :: Subst
annAvails = [TyVar] -> [Type] -> Subst
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar
0..] [Type]
avail
in Recomp e -> n e
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp e -> n e) -> Recomp e -> n e
forall a b. (a -> b) -> a -> b
$ (Int -> [e]) -> Recomp e
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> [e]) -> Recomp e) -> (Int -> [e]) -> Recomp e
forall a b. (a -> b) -> a -> b
$ \Int
d -> [ Int -> [TyVar] -> e -> e
forall e. Expression e => Int -> [TyVar] -> e -> e
decodeVars ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail) [TyVar]
ixs e
e
| Subst
avs <- Int -> Subst -> [Subst]
forall t a. (Eq t, Num t) => t -> [a] -> [[a]]
combs (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Subst
annAvails
, let ([TyVar]
ixs, [Type]
newavails) = Subst -> ([TyVar], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip Subst
avs
(Type
tn, Decoder
_decoder) = Type -> TyVar -> (Type, Decoder)
encode Type
newt (Type -> TyVar
maxVarID Type
newt TyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+ TyVar
1)
newt :: Type
newt = [Type] -> Type -> Type
popArgs [Type]
newavails Type
t
, ([e]
exprs, Subst
_, TyVar
_) <- Recomp ([e], Subst, TyVar) -> Int -> Bag ([e], Subst, TyVar)
forall a. Recomp a -> Int -> Bag a
unRc (m ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Search m => m a -> Recomp a
toRc (Type -> m ([e], Subst, TyVar)
fun Type
tn)) Int
d
, e
e <- [e]
exprs
]
type Generator m e = PGSF e -> [Type] -> Type -> PriorSubsts m ([e], BitSet)
unifyableExprs :: Expression e => Generator Recomp e
unifyableExprs :: Generator Recomp e
unifyableExprs PGSF e
memodeb
= ([Type] -> Type -> PriorSubsts Recomp ([e], BitSet))
-> [Type] -> Type -> PriorSubsts Recomp ([e], BitSet)
forall (m :: * -> *) a.
(Functor m, Monad m) =>
([Type] -> Type -> PriorSubsts m a)
-> [Type] -> Type -> PriorSubsts m a
applyDo ((PriorSubsts Recomp ([e], BitSet)
-> PriorSubsts Recomp ([e], BitSet))
-> ([Type] -> Type -> PriorSubsts Recomp ([e], BitSet))
-> [Type]
-> Type
-> PriorSubsts Recomp ([e], BitSet)
forall a. (a -> a) -> ([Type] -> Type -> a) -> [Type] -> Type -> a
wind ((([e], BitSet) -> ([e], BitSet))
-> PriorSubsts Recomp ([e], BitSet)
-> PriorSubsts Recomp ([e], BitSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ ([e]
es, BitSet
bs) -> ((e -> e) -> [e] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> CoreExpr) -> e -> e
forall e. Expression e => (CoreExpr -> CoreExpr) -> e -> e
mapCE CoreExpr -> CoreExpr
Lambda) [e]
es, BitSet
bs BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1)))
(\[Type]
avail -> ([TyVar] -> BitSet -> [e] -> ([e], BitSet))
-> (Type -> Recomp ([e], Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts Recomp ([e], BitSet)
forall (m :: * -> *) (n :: * -> *) e r.
(Search m, Search n) =>
([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedShared (\[TyVar]
ixs BitSet
ixBits [e]
e -> ((e -> e) -> [e] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [TyVar] -> e -> e
forall e. Expression e => Int -> [TyVar] -> e -> e
decodeVars ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail) [TyVar]
ixs) [e]
e, BitSet
ixBits)) (PGSF e -> Type -> Recomp ([e], Subst, TyVar)
forall e.
Expression e =>
PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie PGSF e
memodeb) [Type]
avail))
memocondexp :: Type -> a -> Bool
memocondexp Type
t a
d = Type -> Int
size Type
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 Bool -> Bool -> Bool
&& a
0a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
d Bool -> Bool -> Bool
&& a
da -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
7
lookupTypeTrie :: Expression e => MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
lookupTypeTrie :: MemoDeb e -> TypeTrie -> Type -> Recomp (Type, Subst, TyVar)
lookupTypeTrie memodeb :: MemoDeb e
memodeb@(ClassLib e
_, (([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_, Common
cmn) TypeTrie
ttrie Type
t
= (Int -> Bag (Type, Subst, TyVar)) -> Recomp (Type, Subst, TyVar)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag (Type, Subst, TyVar)) -> Recomp (Type, Subst, TyVar))
-> (Int -> Bag (Type, Subst, TyVar)) -> Recomp (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
d -> Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx (if Opt () -> Type -> Int -> Bool
forall a. Opt a -> Type -> Int -> Bool
memoCondPure (Common -> Opt ()
opt Common
cmn) Type
t Int
d
then (Type -> Matrix (Type, Subst, TyVar))
-> Type -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) e.
MonadPlus m =>
(Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm (TypeTrie -> Type -> Matrix (Type, Subst, TyVar)
forall a. MapType a -> Type -> a
lmtty TypeTrie
ttrie) Type
t
else Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
t (PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar))
-> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memodeb TypeTrie
ttrie Type
t ) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
d
lookupTypeTrieAndExpTrie :: Expression e => PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie :: PGSF e -> Type -> Recomp ([e], Subst, TyVar)
lookupTypeTrieAndExpTrie (PGSF memodeb :: MemoDeb e
memodeb@(ClassLib e
_, (([[Prim]], [[Prim]]), ([[Prim]], [[Prim]]))
_, Common
cmn) TypeTrie
ttrie ExpTrie e
etrie) Type
t
= (Int -> Bag ([e], Subst, TyVar)) -> Recomp ([e], Subst, TyVar)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag ([e], Subst, TyVar)) -> Recomp ([e], Subst, TyVar))
-> (Int -> Bag ([e], Subst, TyVar)) -> Recomp ([e], Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
d -> if Opt () -> Type -> Int -> Bool
forall a. Opt a -> Type -> Int -> Bool
memoCondPure (Common -> Opt ()
opt Common
cmn) Type
t Int
d
then [ (Matrix e -> Stream [e]
forall a. Matrix a -> Stream (Bag a)
unMx (ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
etrie (Type -> Matrix e) -> Type -> Matrix e
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
apply Subst
s Type
t) Stream [e] -> Int -> [e]
forall a. [a] -> Int -> a
!! Int
d, Subst
s, TyVar
i)
| (Type
_ty, Subst
s, TyVar
i) <- Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx ((Type -> Matrix (Type, Subst, TyVar))
-> Type -> Matrix (Type, Subst, TyVar)
forall (m :: * -> *) e.
MonadPlus m =>
(Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNormReorganized (TypeTrie -> Type -> Matrix (Type, Subst, TyVar)
forall a. MapType a -> Type -> a
lmtty TypeTrie
ttrie) Type
t) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
d ]
else
[ (Matrix e -> Stream [e]
forall a. Matrix a -> Stream (Bag a)
unMx (ExpTrie e -> Type -> Matrix e
forall e. Expression e => ExpTrie e -> Type -> Matrix e
lookupReorganized ExpTrie e
etrie (Type -> Matrix e) -> Type -> Matrix e
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
apply Subst
s Type
t) Stream [e] -> Int -> [e]
forall a. [a] -> Int -> a
!! Int
d, Subst
s, TyVar
i)
| (Type
ty, Subst
s, TyVar
i) <- Matrix (Type, Subst, TyVar) -> Stream (Bag (Type, Subst, TyVar))
forall a. Matrix a -> Stream (Bag a)
unMx (Type -> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
freezePS Type
t (PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar))
-> PriorSubsts Recomp Type -> Matrix (Type, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
forall e.
Expression e =>
MemoDeb e -> TypeTrie -> Type -> PriorSubsts Recomp Type
specTypes MemoDeb e
memodeb TypeTrie
ttrie Type
t) Stream (Bag (Type, Subst, TyVar))
-> Int -> Bag (Type, Subst, TyVar)
forall a. [a] -> Int -> a
!! Int
d ]
lookupNormReorganized :: (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNormReorganized Type -> m (e, Subst, TyVar)
fun Type
typ = let ([Type]
avs, Type
retty) = Type -> ([Type], Type)
splitArgs Type
typ
in ([Type] -> m (e, Subst, TyVar)) -> [Type] -> m (e, Subst, TyVar)
forall a t. Ord a => ([a] -> t) -> [a] -> t
reorganize_ (\[Type]
av -> (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
forall (m :: * -> *) e.
MonadPlus m =>
(Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm Type -> m (e, Subst, TyVar)
fun ([Type] -> Type -> Type
popArgs [Type]
av Type
retty)) [Type]
avs
lookupNorm :: MonadPlus m => (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm :: (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
lookupNorm = (Type -> m (e, Subst, TyVar)) -> Type -> m (e, Subst, TyVar)
forall a. a -> a
id
lookupNormalized :: (Functor m, MonadPlus m) => (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e
lookupNormalized :: (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts m e
lookupNormalized Type -> m (e, Subst, TyVar)
fun [Type]
avail Type
t
= do TyVar
mx <- PriorSubsts m TyVar
forall (m :: * -> *). Monad m => PriorSubsts m TyVar
getMx
let typ :: Type
typ = [Type] -> Type -> Type
popArgs [Type]
avail Type
t
(Type
tn, Decoder
decoder) = Type -> TyVar -> (Type, Decoder)
encode Type
typ TyVar
mx
(e
es, Subst
sub, TyVar
m) <- m (e, Subst, TyVar) -> PriorSubsts m (e, Subst, TyVar)
forall (m :: * -> *) a. Monad m => m a -> PriorSubsts m a
mkPS (Type -> m (e, Subst, TyVar)
fun Type
tn)
Subst -> PriorSubsts m ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (Decoder -> Subst -> Subst
retrieve Decoder
decoder Subst
sub)
(TyVar -> TyVar) -> PriorSubsts m ()
forall (m :: * -> *).
Monad m =>
(TyVar -> TyVar) -> PriorSubsts m ()
updateMx (TyVar
mTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+)
e -> PriorSubsts m e
forall (m :: * -> *) a. Monad m => a -> m a
return e
es
lookupNormalizedShared :: (Search m, Search n) => ([Int8] -> BitSet -> e -> r) -> (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts n r
lookupNormalizedShared :: ([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedShared [TyVar] -> BitSet -> e -> r
ceDecoder Type -> m (e, Subst, TyVar)
fun [Type]
avail Type
t
= let annAvails :: [(TyVar, BitSet, Type)]
annAvails = [TyVar] -> [BitSet] -> [Type] -> [(TyVar, BitSet, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [TyVar
0..] ((BitSet -> BitSet) -> BitSet -> [BitSet]
forall a. (a -> a) -> a -> [a]
iterate (BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) BitSet
1) [Type]
avail
in (Subst -> TyVar -> n (r, Subst, TyVar)) -> PriorSubsts n r
forall (m :: * -> *) a.
(Subst -> TyVar -> m (a, Subst, TyVar)) -> PriorSubsts m a
PS (\Subst
subst TyVar
mx -> Recomp (r, Subst, TyVar) -> n (r, Subst, TyVar)
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp (r, Subst, TyVar) -> n (r, Subst, TyVar))
-> Recomp (r, Subst, TyVar) -> n (r, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag (r, Subst, TyVar)) -> Recomp (r, Subst, TyVar)
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag (r, Subst, TyVar)) -> Recomp (r, Subst, TyVar))
-> (Int -> Bag (r, Subst, TyVar)) -> Recomp (r, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ \Int
d ->[Bag (r, Subst, TyVar)] -> Bag (r, Subst, TyVar)
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ ((e, Subst, TyVar) -> (r, Subst, TyVar))
-> [(e, Subst, TyVar)] -> Bag (r, Subst, TyVar)
forall a b. (a -> b) -> [a] -> [b]
map (\ (e
exprs, Subst
sub, TyVar
m) -> ([TyVar] -> BitSet -> e -> r
ceDecoder [TyVar]
ixs BitSet
ixBits e
exprs, Decoder -> Subst -> Subst
retrieve Decoder
decoder Subst
sub Subst -> Subst -> Subst
`plusSubst` Subst
subst, TyVar
mxTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
m)) ([(e, Subst, TyVar)] -> Bag (r, Subst, TyVar))
-> [(e, Subst, TyVar)] -> Bag (r, Subst, TyVar)
forall a b. (a -> b) -> a -> b
$ Recomp (e, Subst, TyVar) -> Int -> [(e, Subst, TyVar)]
forall a. Recomp a -> Int -> Bag a
unRc (m (e, Subst, TyVar) -> Recomp (e, Subst, TyVar)
forall (m :: * -> *) a. Search m => m a -> Recomp a
toRc (Type -> m (e, Subst, TyVar)
fun Type
tn)) Int
d
| [(TyVar, BitSet, Type)]
annAvs <- Int -> [(TyVar, BitSet, Type)] -> [[(TyVar, BitSet, Type)]]
forall t a. (Eq t, Num t) => t -> [a] -> [[a]]
combs (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(TyVar, BitSet, Type)]
annAvails
, let ([TyVar]
ixs, [BitSet]
ixBitss, [Type]
newavails) = [(TyVar, BitSet, Type)] -> ([TyVar], [BitSet], [Type])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(TyVar, BitSet, Type)]
annAvs
ixBits :: BitSet
ixBits = (BitSet -> BitSet -> BitSet) -> BitSet -> [BitSet] -> BitSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
(.|.) BitSet
0 [BitSet]
ixBitss
(Type
tn, Decoder
decoder) = Type -> TyVar -> (Type, Decoder)
encode ([Type] -> Type -> Type
popArgs [Type]
newavails Type
t) TyVar
mx
])
type BitSet = Word32
#if __GLASGOW_HASKELL__ < 706
countBits = countBits32
#else
countBits :: BitSet -> Int
countBits = BitSet -> Int
forall a. Bits a => a -> Int
popCount
#endif
lookupNormalizedSharedBits :: (Search m, Search n) => (BitSet -> e -> r) -> (Type -> m (e, Subst, TyVar)) -> [Type] -> Type -> PriorSubsts n r
lookupNormalizedSharedBits :: (BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedSharedBits BitSet -> e -> r
f = ([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
forall (m :: * -> *) (n :: * -> *) e r.
(Search m, Search n) =>
([TyVar] -> BitSet -> e -> r)
-> (Type -> m (e, Subst, TyVar))
-> [Type]
-> Type
-> PriorSubsts n r
lookupNormalizedShared ((BitSet -> e -> r) -> [TyVar] -> BitSet -> e -> r
forall a b. a -> b -> a
const BitSet -> e -> r
f)
tokoro10fst :: (Eq k, Ord k) => [(k,s,i)] -> [(k,s,i)]
tokoro10fst :: [(k, s, i)] -> [(k, s, i)]
tokoro10fst = Map k (k, s, i) -> [(k, s, i)]
forall k a. Map k a -> [a]
M.elems (Map k (k, s, i) -> [(k, s, i)])
-> ([(k, s, i)] -> Map k (k, s, i)) -> [(k, s, i)] -> [(k, s, i)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, s, i) -> (k, s, i) -> (k, s, i))
-> [(k, (k, s, i))] -> Map k (k, s, i)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (k, s, i) -> (k, s, i) -> (k, s, i)
forall a b. a -> b -> a
const ([(k, (k, s, i))] -> Map k (k, s, i))
-> ([(k, s, i)] -> [(k, (k, s, i))])
-> [(k, s, i)]
-> Map k (k, s, i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, s, i) -> (k, (k, s, i))) -> [(k, s, i)] -> [(k, (k, s, i))]
forall a b. (a -> b) -> [a] -> [b]
map (\ t :: (k, s, i)
t@(k
k,s
_,i
_) -> (k
k,(k, s, i)
t))
matchFunctions :: (Expression e) => PGSF e -> Type -> Recomp e
matchFunctions :: PGSF e -> Type -> Recomp e
matchFunctions PGSF e
memodeb Type
ty =
case Type -> ([Type], Type)
splitArgs (Type -> Type
saferQuantify Type
ty) of ([Type]
avail,Type
t) -> PGSF e -> [Type] -> Type -> Recomp e
forall e. Expression e => PGSF e -> [Type] -> Type -> Recomp e
matchFuns PGSF e
memodeb [Type]
avail Type
t
matchFuns :: Expression e => PGSF e -> [Type] -> Type -> Recomp e
matchFuns :: PGSF e -> [Type] -> Type -> Recomp e
matchFuns PGSF e
memodeb [Type]
avail Type
reqret = (Int -> Bag e -> Bag e) -> Recomp e -> Recomp e
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag e
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag e
es) (Recomp e -> Recomp e) -> Recomp e -> Recomp e
forall a b. (a -> b) -> a -> b
$ Recomp (Bag e) -> Recomp e
forall (m :: * -> *) a. Search m => m (Bag a) -> m a
catBags (Recomp (Bag e) -> Recomp e) -> Recomp (Bag e) -> Recomp e
forall a b. (a -> b) -> a -> b
$ PriorSubsts Recomp (Bag e) -> Recomp (Bag e)
forall (m :: * -> *) a. Monad m => PriorSubsts m a -> m a
runPS (Generator Recomp e
-> PGSF e -> [Type] -> Type -> PriorSubsts Recomp (Bag e)
forall e.
Expression e =>
Generator Recomp e
-> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e]
matchFuns' Generator Recomp e
forall e. Expression e => Generator Recomp e
unifyableExprs PGSF e
memodeb [Type]
avail Type
reqret)
matchFuns' :: Expression e => Generator Recomp e -> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e]
matchFuns' :: Generator Recomp e
-> PGSF e -> [Type] -> Type -> PriorSubsts Recomp [e]
matchFuns' Generator Recomp e
rec md :: PGSF e
md@(PGSF (CL MemoDeb e
classLib, (([[Prim]], [[Prim]])
_,([[Prim]]
primgen,[[Prim]]
primmono)),Common
cmn) TypeTrie
_ ExpTrie e
_) [Type]
avail Type
reqret
= let clbehalf :: Type -> PriorSubsts Recomp [e]
clbehalf = Generator Recomp e
forall (m :: * -> *) e. (Search m, Expression e) => Generator m e
mguPrograms MemoDeb e
classLib
behalf :: Type -> PriorSubsts Recomp ([e], BitSet)
behalf = Generator Recomp e
rec PGSF e
md [Type]
avail
lltbehalf :: Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf = Int -> Generator Recomp e -> Generator Recomp e
forall (m :: * -> *) e.
(Search m, Expression e) =>
Int -> Generator m e -> Generator m e
lookupListrie Int
lenavails Generator Recomp e
rec PGSF e
md [Type]
avail
lenavails :: Int
lenavails = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
avail
fullBits :: BitSet
fullBits | Int
lenavails Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
29 = BitSet
0
| Bool
otherwise = (BitSet
1 BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
lenavails) BitSet -> BitSet -> BitSet
forall a. Num a => a -> a -> a
- BitSet
1
fe :: Type -> Type -> [e] -> [e]
fe = Bool -> Type -> Type -> [e] -> [e]
forall e. Expression e => Bool -> Type -> Type -> [e] -> [e]
filtExprs (Opt () -> Bool
forall a. Opt a -> Bool
guess (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn)
in Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> [Type]
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> [Type]
-> PriorSubsts Recomp [e]
fromAssumptionsBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf (\Type
a Type
b -> Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts Recomp ()) -> Bool -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ Type
aType -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==Type
b) Type
reqret [Type]
avail PriorSubsts Recomp [e]
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
(Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS ((Int -> Bag ([e], Subst, TyVar) -> Bag ([e], Subst, TyVar))
-> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag ([e], Subst, TyVar)
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lenavails then [] else Bag ([e], Subst, TyVar)
es))
((Prim -> PriorSubsts Recomp [e])
-> [[Prim]] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum (Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> Prim
-> PriorSubsts Recomp [e]
retPrimMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> Type -> PriorSubsts Recomp ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
matchPS Type
reqret) [[Prim]]
primmono PriorSubsts Recomp [e]
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
(Prim -> PriorSubsts Recomp [e])
-> [[Prim]] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a b.
(MonadPlus m, Delay m) =>
(a -> m b) -> [[a]] -> m b
mapSum (( if Opt () -> Bool
forall a. Opt a -> Bool
tv0 (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn then Common
-> Int
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall e i b c.
(Expression e, Integral i) =>
Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> b)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp b
retGenTV0Bits else
if Opt () -> Bool
forall a. Opt a -> Bool
tv1 (Opt () -> Bool) -> Opt () -> Bool
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn then Common
-> Int
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall e i c.
(Expression e, Integral i) =>
Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp [e]
retGenTV1Bits else Common
-> Int
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> Prim
-> PriorSubsts Recomp [e]
forall (n :: * -> *) r i c.
(Search n, Integral i, Expression r) =>
Common
-> i
-> BitSet
-> (Type -> Type -> [r] -> [r])
-> (Type -> PriorSubsts n [r])
-> (Type -> PriorSubsts n ([r], BitSet))
-> (Type -> PriorSubsts n ([r], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n [r]
retGenOrdBits) Common
cmn Int
lenavails BitSet
fullBits Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
reqret) [[Prim]]
primgen)
fromAssumptionsBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> [Type] -> PriorSubsts Recomp [e]
fromAssumptionsBits :: Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> [Type]
-> PriorSubsts Recomp [e]
fromAssumptionsBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> Type -> PriorSubsts Recomp ()
mps Type
reqret [Type]
avail = [PriorSubsts Recomp [e]] -> PriorSubsts Recomp [e]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts Recomp [e]] -> PriorSubsts Recomp [e])
-> [PriorSubsts Recomp [e]] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$ ((Int, Type) -> PriorSubsts Recomp [e])
-> [(Int, Type)] -> [PriorSubsts Recomp [e]]
forall a b. (a -> b) -> [a] -> [b]
map (Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ())
-> (Int, Type)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ())
-> (Int, Type)
-> PriorSubsts Recomp [e]
retMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((Type -> Type -> PriorSubsts Recomp ())
-> Type -> Type -> PriorSubsts Recomp ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> PriorSubsts Recomp ()
mps Type
reqret)) ([Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Type]
avail)
retMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ()) -> (Int, Type) -> PriorSubsts Recomp [e]
retMonoBits :: Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ())
-> (Int, Type)
-> PriorSubsts Recomp [e]
retMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> PriorSubsts Recomp ()
tok (Int, Type)
fromBlah
= do let (Int
n, Type
ty) = (Int, Type)
fromBlah
(Int
arity,[Type]
args,Type
retty) = Type -> (Int, [Type], Type)
forall i. Integral i => Type -> (i, [Type], Type)
revSplitArgs Type
ty
Type -> PriorSubsts Recomp ()
tok Type
retty
(Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp [e] -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
forall a. HasCallStack => a
undefined Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty ([ (CoreExpr -> Dynamic) -> Int -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Int
lenavails Int
0 Int
arity (CoreExpr -> e) -> CoreExpr -> e
forall a b. (a -> b) -> a -> b
$ TyVar -> CoreExpr
X (TyVar -> CoreExpr) -> TyVar -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Int -> TyVar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n], BitSet
fullBits BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`clearBit` Int
n)
retPrimMonoBits :: (Expression e) => Common -> Int -> BitSet -> (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> Type -> PriorSubsts Recomp ()) -> Type -> Prim -> PriorSubsts Recomp [e]
retPrimMonoBits :: Common
-> Int
-> BitSet
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> Type -> PriorSubsts Recomp ())
-> Type
-> Prim
-> PriorSubsts Recomp [e]
retPrimMonoBits Common
cmn Int
lenavails BitSet
fullBits Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type -> Type -> PriorSubsts Recomp ()
mps Type
reqret (Int
numcxts, Int
arity, Type
retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
= do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
Type -> Type -> PriorSubsts Recomp ()
mps ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
retty) Type
reqret
(Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp [e] -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> e) -> [CoreExpr] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> Int -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Int
lenavails Int
numcxts Int
arity) [CoreExpr]
xs, BitSet
fullBits)
funApSubBits, funApSubBits_resetting :: (Search m, Expression e) => (Type -> PriorSubsts m [e]) -> (Type -> PriorSubsts m ([e],BitSet)) -> (Type -> PriorSubsts m ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts m ([e],BitSet)
funApSubBits :: (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
funApSubBits = (e -> e -> e)
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) (m :: * -> *) a r a2.
(Monad m, Monad m, Bits a) =>
(r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits e -> e -> e
forall e. Expression e => e -> e -> e
(<$>)
funApSubOpBits :: (r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits r -> a2 -> r
op Type -> m (m a2)
clbehalf Type -> m (m a2, a)
lltbehalf Type -> m (m a2, a)
behalf = Type -> (m r, a) -> m (m r, a)
faso
where faso :: Type -> (m r, a) -> m (m r, a)
faso (Type
t:=>Type
ts) (m r
funs, a
bsf)
= do m a2
args <- Type -> m (m a2)
clbehalf Type
t
Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf)
faso (Type
t:> Type
ts) (m r
funs, a
bsf)
= do (m a2
args, a
bse) <- Type -> m (m a2, a)
lltbehalf Type
t
Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
bse)
faso (Type
t:->Type
ts) (m r
funs, a
bsf)
= do (m a2
args, a
bse) <- Type -> m (m a2, a)
behalf Type
t
Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
bse)
faso Type
_ (m r, a)
tup = (m r, a) -> m (m r, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r, a)
tup
funApSubBits_resetting :: (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
funApSubBits_resetting = (e -> e -> e)
-> (Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) (m :: * -> *) a r a2.
(Monad m, Monad m, Bits a) =>
(r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits_resetting e -> e -> e
forall e. Expression e => e -> e -> e
(<$>)
funApSubOpBits_resetting :: (r -> a2 -> r)
-> (Type -> m (m a2))
-> (Type -> m (m a2, a))
-> (Type -> m (m a2, a))
-> Type
-> (m r, a)
-> m (m r, a)
funApSubOpBits_resetting r -> a2 -> r
op Type -> m (m a2)
clbehalf Type -> m (m a2, a)
lltbehalf Type -> m (m a2, a)
behalf = Type -> (m r, a) -> m (m r, a)
faso
where faso :: Type -> (m r, a) -> m (m r, a)
faso (Type
t:=>Type
ts) (m r
funs, a
bsf)
= do m a2
args <- Type -> m (m a2)
clbehalf Type
t
Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf)
faso (Type
t:> Type
ts) (m r
funs, a
bsf)
= do (m a2
args, a
bse) <- Type -> m (m a2, a)
lltbehalf Type
t
Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.&. a -> a
forall a. Bits a => a -> a
complement a
bse)
faso (Type
t:->Type
ts) (m r
funs, a
bsf)
= do (m a2
args, a
bse) <- Type -> m (m a2, a)
behalf Type
t
Type -> (m r, a) -> m (m r, a)
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, a
bsf a -> a -> a
forall a. Bits a => a -> a -> a
.&. a -> a
forall a. Bits a => a -> a
complement a
bse)
faso Type
_ (m r, a)
tup = (m r, a) -> m (m r, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (m r, a)
tup
fapBits :: (t -> m (m r, b)) -> t t -> (m r, b) -> m (m r, b)
fapBits t -> m (m r, b)
behalf t t
ts (m r, b)
tups = ((m r, b) -> t -> m (m r, b)) -> (m r, b) -> t t -> m (m r, b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ (m r
fs,b
bsf) t
t -> do (m r
args, b
bse) <- t -> m (m r, b)
behalf t
t
(m r, b) -> m (m r, b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((r -> r -> r) -> m r -> m r -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall e. Expression e => e -> e -> e
(<$>) m r
fs m r
args, b
bsf b -> b -> b
forall a. Bits a => a -> a -> a
.|. b
bse))
(m r, b)
tups
t t
ts
forceNil :: BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil :: BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining = (Recomp (e, Subst, TyVar) -> Recomp (e, Subst, TyVar))
-> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS ((Int -> Bag (e, Subst, TyVar) -> Bag (e, Subst, TyVar))
-> Recomp (e, Subst, TyVar) -> Recomp (e, Subst, TyVar)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
i Bag (e, Subst, TyVar)
es -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< BitSet -> Int
countBits BitSet
newRemaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then [] else Bag (e, Subst, TyVar)
es))
funApSubBits_forcingNil :: (Expression e) => (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> Type -> ([e],BitSet) -> PriorSubsts Recomp [e]
funApSubBits_forcingNil :: (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty = (e -> e -> e)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall (m :: * -> *) r a2.
Monad m =>
(r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> PriorSubsts Recomp (m r)
funApSubOpBits_forcingNil (String -> e -> e -> e
forall e. Expression e => String -> e -> e -> e
aeAppErr (String
" to the request of "String -> String -> String
forall a. [a] -> [a] -> [a]
++Type -> String
forall a. Show a => a -> String
show Type
ty)) Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty
funApSubBits_forcingNil_cont :: (Expression e) => (Type -> PriorSubsts Recomp [e]) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> (Type -> PriorSubsts Recomp ([e],BitSet)) -> Type -> ([e],BitSet) -> (([e],BitSet) -> PriorSubsts Recomp [e]) -> PriorSubsts Recomp [e]
funApSubBits_forcingNil_cont :: (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil_cont Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty = (e -> e -> e)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
forall (m :: * -> *) r a2 e.
Monad m =>
(r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
funApSubOpBits_forcingNil_cont (String -> e -> e -> e
forall e. Expression e => String -> e -> e -> e
aeAppErr (String
" to the request of "String -> String -> String
forall a. [a] -> [a] -> [a]
++Type -> String
forall a. Show a => a -> String
show Type
ty)) Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
ty
funApSubOpBits_forcingNil_cont :: (r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
funApSubOpBits_forcingNil_cont r -> a2 -> r
op Type -> PriorSubsts Recomp (m a2)
clbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
behalf = Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
forall e.
Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso
where faso :: Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso (Type
t:=>Type
ts) (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
= do m a2
args <- Type -> PriorSubsts Recomp (m a2)
clbehalf Type
t
Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
faso (Type
t:> Type
ts) (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
= do (m a2
args, BitSet
bse) <- Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type
t
let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp e -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall a b. (a -> b) -> a -> b
$
Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, BitSet
newRemaining) (m r, BitSet) -> PriorSubsts Recomp e
cont
faso (Type
t:->Type
ts) (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont
= do (m a2
args, BitSet
bse) <- Type -> PriorSubsts Recomp (m a2, BitSet)
behalf Type
t
let newRemaining :: BitSet
newRemaining = BitSet
bsf BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
bse
BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall e. BitSet -> PriorSubsts Recomp e -> PriorSubsts Recomp e
forceNil BitSet
newRemaining (PriorSubsts Recomp e -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e -> PriorSubsts Recomp e
forall a b. (a -> b) -> a -> b
$
Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
faso Type
ts ((r -> a2 -> r) -> m r -> m a2 -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> a2 -> r
op m r
funs m a2
args, BitSet
newRemaining) (m r, BitSet) -> PriorSubsts Recomp e
cont
faso Type
_ (m r
funs, BitSet
bsf) (m r, BitSet) -> PriorSubsts Recomp e
cont = (m r, BitSet) -> PriorSubsts Recomp e
cont (m r
funs, BitSet
bsf)
funApSubOpBits_forcingNil :: (r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> PriorSubsts Recomp (m r)
funApSubOpBits_forcingNil r -> a2 -> r
op Type -> PriorSubsts Recomp (m a2)
clbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
behalf Type
t (m r, BitSet)
tup
= (r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp (m r))
-> PriorSubsts Recomp (m r)
forall (m :: * -> *) r a2 e.
Monad m =>
(r -> a2 -> r)
-> (Type -> PriorSubsts Recomp (m a2))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> (Type -> PriorSubsts Recomp (m a2, BitSet))
-> Type
-> (m r, BitSet)
-> ((m r, BitSet) -> PriorSubsts Recomp e)
-> PriorSubsts Recomp e
funApSubOpBits_forcingNil_cont r -> a2 -> r
op Type -> PriorSubsts Recomp (m a2)
clbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
lltbehalf Type -> PriorSubsts Recomp (m a2, BitSet)
behalf Type
t (m r, BitSet)
tup (((m r, BitSet) -> PriorSubsts Recomp (m r))
-> PriorSubsts Recomp (m r))
-> ((m r, BitSet) -> PriorSubsts Recomp (m r))
-> PriorSubsts Recomp (m r)
forall a b. (a -> b) -> a -> b
$ \(m r
funs, BitSet
bsf) ->
do Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts Recomp ()) -> Bool -> PriorSubsts Recomp ()
forall a b. (a -> b) -> a -> b
$ BitSet
bsf BitSet -> BitSet -> Bool
forall a. Eq a => a -> a -> Bool
== BitSet
0
m r -> PriorSubsts Recomp (m r)
forall (m :: * -> *) a. Monad m => a -> m a
return m r
funs
countBits32 :: a -> b
countBits32 a
bin
= let quad :: a
quad = a
bin a -> a -> a
forall a. Num a => a -> a -> a
- ((a
bin a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x55555555)
hex :: a
hex = (a
quad a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x33333333) a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
quad a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x33333333)
in a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ ((((a
hex a -> a -> a
forall a. Num a => a -> a -> a
+ (a
hex a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4)) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x0F0F0F0F) a -> a -> a
forall a. Num a => a -> a -> a
* a
0x01010101) a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF
retGenOrdBits :: Common
-> i
-> BitSet
-> (Type -> Type -> [r] -> [r])
-> (Type -> PriorSubsts n [r])
-> (Type -> PriorSubsts n ([r], BitSet))
-> (Type -> PriorSubsts n ([r], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts n [r]
retGenOrdBits Common
cmn i
lenavails BitSet
fullBits Type -> Type -> [r] -> [r]
fe Type -> PriorSubsts n [r]
clbehalf Type -> PriorSubsts n ([r], BitSet)
lltbehalf Type -> PriorSubsts n ([r], BitSet)
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
= (n ([r], Subst, TyVar) -> n ([r], Subst, TyVar))
-> PriorSubsts n [r] -> PriorSubsts n [r]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> n ([r], Subst, TyVar) -> n ([r], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts n [r] -> PriorSubsts n [r])
-> PriorSubsts n [r] -> PriorSubsts n [r]
forall a b. (a -> b) -> a -> b
$ do TyVar
tvid <- TyVar -> PriorSubsts n TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
Int
a <- Int -> TyVar -> Type -> PriorSubsts n Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubsts (Opt () -> Int
forall a. Opt a -> Int
tvndelay (Opt () -> Int) -> Opt () -> Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) TyVar
tvid Type
reqret
([r]
exprs, BitSet
bs1) <- (Type -> PriorSubsts n [r])
-> (Type -> PriorSubsts n ([r], BitSet))
-> (Type -> PriorSubsts n ([r], BitSet))
-> Type
-> ([r], BitSet)
-> PriorSubsts n ([r], BitSet)
forall (m :: * -> *) e.
(Search m, Expression e) =>
(Type -> PriorSubsts m [e])
-> (Type -> PriorSubsts m ([e], BitSet))
-> (Type -> PriorSubsts m ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts m ([e], BitSet)
funApSubBits_resetting Type -> PriorSubsts n [r]
clbehalf Type -> PriorSubsts n ([r], BitSet)
lltbehalf Type -> PriorSubsts n ([r], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> r) -> [CoreExpr] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> i -> Int -> Int -> CoreExpr -> r
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) i
lenavails Int
numcxts (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
a)) [CoreExpr]
xs, BitSet
fullBits)
Type
gentvar <- Type -> PriorSubsts n Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
Bool -> PriorSubsts n ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Type -> Bool
orderedAndUsedArgs Type
gentvar)
([r]
es, BitSet
bs2) <- Bool -> Type -> ([r], BitSet) -> PriorSubsts n ([r], BitSet)
funApSub'' Bool
False Type
gentvar (Type -> Type -> [r] -> [r]
fe Type
gentvar Type
ty [r]
exprs, BitSet
bs1)
Bool -> PriorSubsts n ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> PriorSubsts n ()) -> Bool -> PriorSubsts n ()
forall a b. (a -> b) -> a -> b
$ BitSet
bs2 BitSet -> BitSet -> Bool
forall a. Eq a => a -> a -> Bool
== BitSet
0
[r] -> PriorSubsts n [r]
forall (m :: * -> *) a. Monad m => a -> m a
return [r]
es
where
funApSub'' :: Bool -> Type -> ([r], BitSet) -> PriorSubsts n ([r], BitSet)
funApSub'' Bool
filtexp (Type
t:->ts :: Type
ts@(Type
u:->Type
_)) ([r]
funs, BitSet
bs)
| Bool
otherwise = do ([r]
args, BitSet
ixs) <- Type -> PriorSubsts n ([r], BitSet)
behalf Type
t
Bool -> Type -> ([r], BitSet) -> PriorSubsts n ([r], BitSet)
funApSub'' (Type
tType -> Type -> Bool
forall a. Eq a => a -> a -> Bool
==Type
u) Type
ts (if Bool
filtexp then [ r
f r -> r -> r
forall e. Expression e => e -> e -> e
<$> r
e | r
f <- [r]
funs, r
e <- [r]
args, let CoreExpr
_:$CoreExpr
d = r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
f, CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Ord a => a -> a -> Bool
<= r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
e ]
else (r -> r -> r) -> [r] -> [r] -> [r]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall e. Expression e => e -> e -> e
(<$>) [r]
funs [r]
args,
BitSet
bs BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
ixs)
funApSub'' Bool
filtexp (Type
t:->Type
ts) ([r]
funs, BitSet
bs)
= do ([r]
args, BitSet
ixs) <- Type -> PriorSubsts n ([r], BitSet)
behalf Type
t
([r], BitSet) -> PriorSubsts n ([r], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
filtexp then [ r
f r -> r -> r
forall e. Expression e => e -> e -> e
<$> r
e | r
f <- [r]
funs, r
e <- [r]
args, let CoreExpr
_:$CoreExpr
d = r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
f, CoreExpr
d CoreExpr -> CoreExpr -> Bool
forall a. Ord a => a -> a -> Bool
<= r -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE r
e]
else (r -> r -> r) -> [r] -> [r] -> [r]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 r -> r -> r
forall e. Expression e => e -> e -> e
(<$>) [r]
funs [r]
args,
BitSet
bs BitSet -> BitSet -> BitSet
forall a. Bits a => a -> a -> a
.&. BitSet -> BitSet
forall a. Bits a => a -> a
complement BitSet
ixs)
funApSub'' Bool
_fe Type
_t ([r], BitSet)
tups = ([r], BitSet) -> PriorSubsts n ([r], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([r], BitSet)
tups
retGenTV1Bits :: Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> [e])
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp [e]
retGenTV1Bits Common
cmn i
lenavails BitSet
fullBits Type -> Type -> [e] -> [e]
fe Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
= (Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar))
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp ([e], Subst, TyVar) -> Recomp ([e], Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp [e] -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e] -> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$ do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
Int
a <- Int -> TyVar -> Type -> PriorSubsts Recomp Int
forall (m :: * -> *).
Search m =>
Int -> TyVar -> Type -> PriorSubsts m Int
mkSubst (Opt () -> Int
forall a. Opt a -> Int
tvndelay (Opt () -> Int) -> Opt () -> Int
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) TyVar
tvid Type
reqret
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil_cont Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> e) -> [CoreExpr] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> i -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) i
lenavails Int
numcxts (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
a)) [CoreExpr]
xs, BitSet
fullBits) ((([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e])
-> (([e], BitSet) -> PriorSubsts Recomp [e])
-> PriorSubsts Recomp [e]
forall a b. (a -> b) -> a -> b
$ \([e]
exprs, BitSet
bs1) -> do
Type
gentvar <- Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
Bool -> PriorSubsts Recomp ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyVar -> Type -> Bool
usedArg (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+TyVar
1) Type
gentvar)
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
gentvar (Type -> Type -> [e] -> [e]
fe Type
gentvar Type
ty [e]
exprs, BitSet
bs1)
retGenTV0Bits :: Common
-> i
-> BitSet
-> (Type -> Type -> [e] -> b)
-> (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> (Int, Int, c, TyVar, Typed [CoreExpr])
-> PriorSubsts Recomp b
retGenTV0Bits Common
cmn i
lenavails BitSet
fullBits Type -> Type -> [e] -> b
fe Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf Type
reqret (Int
numcxts, Int
arity, c
_retty, TyVar
numtvs, [CoreExpr]
xs:::Type
ty)
= (Recomp (b, Subst, TyVar) -> Recomp (b, Subst, TyVar))
-> PriorSubsts Recomp b -> PriorSubsts Recomp b
forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Subst, TyVar) -> n (b, Subst, TyVar))
-> PriorSubsts m a -> PriorSubsts n b
convertPS (Int -> Recomp (b, Subst, TyVar) -> Recomp (b, Subst, TyVar)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
arity) (PriorSubsts Recomp b -> PriorSubsts Recomp b)
-> PriorSubsts Recomp b -> PriorSubsts Recomp b
forall a b. (a -> b) -> a -> b
$ do TyVar
tvid <- TyVar -> PriorSubsts Recomp TyVar
forall (m :: * -> *). Monad m => TyVar -> PriorSubsts m TyVar
reserveTVars TyVar
numtvs
Subst -> PriorSubsts Recomp ()
forall (m :: * -> *). Monad m => Subst -> PriorSubsts m ()
updatePS (TyVar -> Type -> Subst
forall a b. a -> b -> [(a, b)]
unitSubst TyVar
tvid Type
reqret)
[e]
exprs <- (Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
forall e.
Expression e =>
(Type -> PriorSubsts Recomp [e])
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> (Type -> PriorSubsts Recomp ([e], BitSet))
-> Type
-> ([e], BitSet)
-> PriorSubsts Recomp [e]
funApSubBits_forcingNil Type -> PriorSubsts Recomp [e]
clbehalf Type -> PriorSubsts Recomp ([e], BitSet)
lltbehalf Type -> PriorSubsts Recomp ([e], BitSet)
behalf ((TyVar -> TyVar) -> Type -> Type
mapTV (TyVar
tvidTyVar -> TyVar -> TyVar
forall a. Num a => a -> a -> a
+) Type
ty) ((CoreExpr -> e) -> [CoreExpr] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreExpr -> Dynamic) -> i -> Int -> Int -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) i
lenavails Int
numcxts Int
arity) [CoreExpr]
xs, BitSet
fullBits)
Type
gentvar <- Type -> PriorSubsts Recomp Type
forall (m :: * -> *). Monad m => Type -> PriorSubsts m Type
applyPS (TyVar -> Type
TV TyVar
tvid)
b -> PriorSubsts Recomp b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> PriorSubsts Recomp b) -> b -> PriorSubsts Recomp b
forall a b. (a -> b) -> a -> b
$ Type -> Type -> [e] -> b
fe Type
gentvar Type
ty [e]
exprs
matchAssumptionsBits :: (Functor m, MonadPlus m, Expression e) => Common -> Int -> Type -> [Type] -> PriorSubsts m ([e],BitSet)
matchAssumptionsBits :: Common -> Int -> Type -> [Type] -> PriorSubsts m ([e], BitSet)
matchAssumptionsBits Common
cmn Int
lenavails Type
reqty [Type]
assumptions
= do Subst
s <- PriorSubsts m Subst
forall (m :: * -> *). Monad m => PriorSubsts m Subst
getSubst
let newty :: Type
newty = Subst -> Type -> Type
apply Subst
s Type
reqty
(Integer
numcxts, Integer
arity) = Type -> (Integer, Integer)
forall i. Integral i => Type -> (i, i)
getArities Type
newty
[PriorSubsts m ([e], BitSet)] -> PriorSubsts m ([e], BitSet)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([PriorSubsts m ([e], BitSet)] -> PriorSubsts m ([e], BitSet))
-> [PriorSubsts m ([e], BitSet)] -> PriorSubsts m ([e], BitSet)
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type -> PriorSubsts m ([e], BitSet))
-> [TyVar] -> [Type] -> [PriorSubsts m ([e], BitSet)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\TyVar
n Type
t -> Type -> Type -> PriorSubsts m ()
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Type -> Type -> PriorSubsts m ()
matchPS Type
newty Type
t PriorSubsts m ()
-> PriorSubsts m ([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CoreExpr -> Dynamic) -> Int -> Integer -> Integer -> CoreExpr -> e
forall e i j.
(Expression e, Integral i, Integral j) =>
(CoreExpr -> Dynamic) -> i -> j -> j -> CoreExpr -> e
mkHead (Common -> CoreExpr -> Dynamic
reducer Common
cmn) Int
lenavails Integer
numcxts Integer
arity (TyVar -> CoreExpr
X TyVar
n)], BitSet
1 BitSet -> Int -> BitSet
forall a. Bits a => a -> Int -> a
`shiftL` TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
n)) [TyVar
0..] [Type]
assumptions
lookupListrie :: (Search m, Expression e) => Int -> Generator m e -> Generator m e
lookupListrie :: Int -> Generator m e -> Generator m e
lookupListrie Int
lenavails Generator m e
rec PGSF e
memodeb [Type]
avail Type
t
| Opt () -> Bool
forall a. Opt a -> Bool
constrL Opt ()
opts = Common -> Int -> Type -> [Type] -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) e.
(Functor m, MonadPlus m, Expression e) =>
Common -> Int -> Type -> [Type] -> PriorSubsts m ([e], BitSet)
matchAssumptionsBits Common
cmn Int
lenavails Type
t [Type]
avail
| Opt () -> Bool
forall a. Opt a -> Bool
guess Opt ()
opts = do
([e]
args, BitSet
ixBits) <- Generator m e
rec PGSF e
memodeb [Type]
avail Type
t
let args' :: [e]
args' = (e -> Bool) -> [e] -> [e]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CoreExpr -> Bool
isClosed(CoreExpr -> Bool) -> (e -> CoreExpr) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE) [e]
args
Bool -> PriorSubsts m () -> PriorSubsts m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([e] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
args') PriorSubsts m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([e]
args', BitSet
ixBits)
| Bool
otherwise = do
([e]
args, BitSet
ixBits) <- Generator m e
rec PGSF e
memodeb [Type]
avail Type
t
let args' :: [e]
args' = (e -> Bool) -> [e] -> [e]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (e -> Bool) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CoreExpr -> Bool
isConstrExpr(CoreExpr -> Bool) -> (e -> CoreExpr) -> e -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.e -> CoreExpr
forall e. Expression e => e -> CoreExpr
toCE) [e]
args
Bool -> PriorSubsts m () -> PriorSubsts m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([e] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
args') PriorSubsts m ()
forall (m :: * -> *) a. MonadPlus m => m a
mzero
([e], BitSet) -> PriorSubsts m ([e], BitSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([e]
args', BitSet
ixBits)
where opts :: Opt ()
opts = Common -> Opt ()
opt Common
cmn
cmn :: Common
cmn = PGSF e -> Common
forall a. WithCommon a => a -> Common
extractCommon PGSF e
memodeb
\end{code}