{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Compile
(
compileExpr
, tryCompileExpr
, intToExpr
, intSubstitution
, offsetSubstitution
, offsetSubstitutionTree
, OffsetScope(..)
, getScopeId
, getScopeExpr
, intListExpr
, exprToIntList
, isLitOrGlobal
, inScopeAll
, isIndexer
, caseExprIndex
, compileGStorableBind
, lintBind
, replaceIdsBind
, compileGroups
)
where
import Prelude hiding ((<>))
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt, AltCon(..), isId, Unfolding(..))
import Literal (Literal(..))
#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
import Literal (LitNumType(..))
#endif
import Id (isLocalId, isGlobalId,setIdInfo,Id)
import IdInfo (IdInfo(..))
import Var (Var(..), idInfo)
import Name (getOccName,mkOccName, getSrcSpan)
import OccName (OccName(..), occNameString)
import qualified Name as N (varName, tvName, tcClsName)
import SrcLoc (noSrcSpan, SrcSpan)
import Unique (getUnique)
import HscMain (hscCompileCoreExpr)
import HscTypes (HscEnv,ModGuts(..))
import CoreMonad (CoreM,CoreToDo(..), getHscEnv, getDynFlags)
import CoreLint (lintExpr)
import BasicTypes (CompilerPhase(..))
import Type (isAlgType, splitTyConApp_maybe)
import TyCon (tyConName, algTyConRhs, visibleDataCons)
import TyCoRep (Type(..), TyBinder(..), TyLit(..))
import TysWiredIn
import TysPrim (intPrimTy)
import DataCon (dataConWorkId,dataConOrigArgTys)
import MkCore (mkWildValBinder)
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma)
import CoreMonad (putMsg, putMsgS)
import GHCi.RemoteTypes
import PrelNames (buildIdKey, augmentIdKey)
import DataCon (dataConWorkId)
import BasicTypes (Boxity(..))
import Unsafe.Coerce
import Data.List
import Data.Maybe
import Data.Either
import Debug.Trace
import Control.Monad.IO.Class
import Control.Monad
import Control.Applicative hiding (empty)
import Control.Exception
import Foreign.Storable.Generic.Plugin.Internal.Helpers
import Foreign.Storable.Generic.Plugin.Internal.Error
import Foreign.Storable.Generic.Plugin.Internal.Predicates
import Foreign.Storable.Generic.Plugin.Internal.Types
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr hsc_env :: HscEnv
hsc_env expr :: CoreExpr
expr src_span :: SrcSpan
src_span = do
ForeignHValue
foreign_hval <- IO ForeignHValue -> IO ForeignHValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> IO ForeignHValue)
-> IO ForeignHValue -> IO ForeignHValue
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span CoreExpr
expr
HValue
hval <- IO HValue -> IO HValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HValue -> IO HValue) -> IO HValue -> IO HValue
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> (RemoteRef HValue -> IO HValue) -> IO HValue
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
foreign_hval RemoteRef HValue -> IO HValue
forall a. RemoteRef a -> IO a
localRef
let val :: a
val = HValue -> a
forall a b. a -> b
unsafeCoerce HValue
hval :: a
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. a
val
tryCompileExpr :: Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr :: Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr id :: Id
id core_expr :: CoreExpr
core_expr = do
HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
Either SomeException a
e_compiled <- IO (Either SomeException a) -> CoreM (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException a) -> CoreM (Either SomeException a))
-> IO (Either SomeException a) -> CoreM (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$
HscEnv -> CoreExpr -> SrcSpan -> IO a
forall a. HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr HscEnv
hsc_env CoreExpr
core_expr (Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
id) :: CoreM (Either SomeException a)
case Either SomeException a
e_compiled of
Left se :: SomeException
se -> Either Error a -> CoreM (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> CoreM (Either Error a))
-> Either Error a -> CoreM (Either Error a)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
core_expr) (String -> SDoc
stringToPpr (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
se)
Right val :: a
val-> Either Error a -> CoreM (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> CoreM (Either Error a))
-> Either Error a -> CoreM (Either Error a)
forall a b. (a -> b) -> a -> b
$ a -> Either Error a
forall a b. b -> Either a b
Right a
val
intLiteral :: (Integral a) => a -> CoreExpr
#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
intLiteral :: a -> CoreExpr
intLiteral i :: a
i = Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Literal -> CoreExpr) -> Literal -> CoreExpr
forall a b. (a -> b) -> a -> b
$ LitNumType -> Integer -> Type -> Literal
LitNumber LitNumType
LitNumInt (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i) Type
intPrimTy
#else
intLiteral i = Lit $ MachInt $ fromIntegral i
#endif
intToExpr :: Type -> Int -> CoreExpr
intToExpr :: Type -> Int -> CoreExpr
intToExpr t :: Type
t i :: Int
i = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
wild (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
forall b. Expr b
fun CoreExpr
arg
where fun :: Expr b
fun = Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Expr b) -> Id -> Expr b
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
intDataCon
arg :: CoreExpr
arg = Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
intLiteral Int
i
wild :: Id
wild= Type -> Id
mkWildValBinder Type
t
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution b :: CoreBind
b@(Rec _) = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
b
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
#endif
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Lam l1 :: Id
l1 l :: CoreExpr
l@(Lam l2 :: Id
l2 e :: CoreExpr
e@(Lam l3 :: Id
l3 expr :: CoreExpr
expr)))) = do
HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
Either Error Int
the_integer <- Id -> CoreExpr -> CoreM (Either Error Int)
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
expr :: CoreM (Either Error Int)
let m_t :: Maybe Type
m_t = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id)
case Maybe Type
m_t of
Just t :: Type
t -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
l1 (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
l2 (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> CoreExpr
intToExpr Type
t (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)))
Nothing ->
Either Error Int -> Either Error CoreBind -> Either Error Int
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer (Either Error CoreBind -> Either Error Int)
-> (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind
-> CoreM (Either Error CoreBind)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b (String -> SDoc
text "Type not found")
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Lam l1 :: Id
l1 expr :: CoreExpr
expr)) = do
HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
Either Error Int
the_integer <- Id -> CoreExpr -> CoreM (Either Error Int)
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
expr :: CoreM (Either Error Int)
let m_t :: Maybe Type
m_t = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id)
case Maybe Type
m_t of
Just t :: Type
t -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> CoreExpr
intToExpr Type
t (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
Nothing ->
Either Error Int -> Either Error CoreBind -> Either Error Int
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer (Either Error CoreBind -> Either Error Int)
-> (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind
-> CoreM (Either Error CoreBind)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b (String -> SDoc
text "Type not found")
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id e :: CoreExpr
e@(App expr :: CoreExpr
expr g :: CoreExpr
g)) = case CoreExpr
expr of
Lam _ (Lam _ (Lam _ e :: CoreExpr
e)) -> CoreBind -> CoreM (Either Error CoreBind)
intSubstitution (CoreBind -> CoreM (Either Error CoreBind))
-> CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
expr
App e :: CoreExpr
e t :: CoreExpr
t -> do
Either Error CoreBind
subs <- CoreBind -> CoreM (Either Error CoreBind)
intSubstitution (CoreBind -> CoreM (Either Error CoreBind))
-> CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
e
case Either Error CoreBind
subs of
Right (NonRec i :: Id
i (Lam l1 :: Id
l1 (Lam l2 :: Id
l2 e :: CoreExpr
e)) ) -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right (CoreBind -> Either Error CoreBind)
-> CoreBind -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
i CoreExpr
e)
err :: Either Error CoreBind
err -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
err
_ -> Id -> CoreExpr -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id CoreExpr
expr
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Case _ _ _ _)) = String -> CoreM (Either Error CoreBind)
forall a. HasCallStack => String -> a
error (String -> CoreM (Either Error CoreBind))
-> String -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ "am case"
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Let _ _)) = String -> CoreM (Either Error CoreBind)
forall a. HasCallStack => String -> a
error (String -> CoreM (Either Error CoreBind))
-> String -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ "am let"
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id e :: CoreExpr
e) = String -> CoreM (Either Error CoreBind)
forall a. HasCallStack => String -> a
error (String -> CoreM (Either Error CoreBind))
-> String -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e
intSubstitutionWorker :: Id -> CoreExpr -> CoreM (Either Error CoreBind)
intSubstitutionWorker id :: Id
id expr :: CoreExpr
expr = do
HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
Either Error Int
the_integer <- Id -> CoreExpr -> CoreM (Either Error Int)
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
expr :: CoreM (Either Error Int)
let m_t :: Maybe Type
m_t = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id)
case Maybe Type
m_t of
Just t :: Type
t -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> CoreExpr
intToExpr Type
t (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
Nothing ->
Either Error Int -> Either Error CoreBind -> Either Error Int
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer (Either Error CoreBind -> Either Error Int)
-> (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind
-> CoreM (Either Error CoreBind)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
expr) (String -> SDoc
text "Type not found")
offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution b :: CoreBind
b@(Rec _) = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
b
offsetSubstitution b :: CoreBind
b@(NonRec id :: Id
id expr :: CoreExpr
expr) = do
Either Error CoreExpr
e_subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [] CoreExpr
expr
let ne_subs :: Either Error CoreExpr
ne_subs = case Either Error CoreExpr
e_subs of
Left (OtherError sdoc :: SDoc
sdoc)
-> Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b SDoc
sdoc
Left err :: Error
err@(CompilationError _ _)
-> Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b (Verbosity -> Error -> SDoc
pprError Verbosity
Some Error
err)
a :: Either Error CoreExpr
a -> Either Error CoreExpr
a
Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
e_subs
data OffsetScope = IntList Id CoreExpr
| IntPrimVal Id CoreExpr
getScopeId :: OffsetScope -> Id
getScopeId :: OffsetScope -> Id
getScopeId (IntList id :: Id
id _) = Id
id
getScopeId (IntPrimVal id :: Id
id _) = Id
id
getScopeExpr :: OffsetScope -> CoreExpr
getScopeExpr :: OffsetScope -> CoreExpr
getScopeExpr (IntList _ expr :: CoreExpr
expr) = CoreExpr
expr
getScopeExpr (IntPrimVal _ expr :: CoreExpr
expr) = CoreExpr
expr
instance Outputable OffsetScope where
ppr :: OffsetScope -> SDoc
ppr (IntList id :: Id
id expr :: CoreExpr
expr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
id) SDoc -> SDoc -> SDoc
<+> SDoc
comma SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
ppr (IntPrimVal id :: Id
id expr :: CoreExpr
expr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
id) SDoc -> SDoc -> SDoc
<+> SDoc
comma SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
pprPrec :: Rational -> OffsetScope -> SDoc
pprPrec _ el :: OffsetScope
el = OffsetScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr OffsetScope
el
intListExpr :: [Int] -> CoreExpr
intListExpr :: [Int] -> CoreExpr
intListExpr list :: [Int]
list = [Int] -> CoreExpr -> CoreExpr
intListExpr' ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
list) CoreExpr
forall b. Expr b
empty_list
where empty_list :: Expr b
empty_list = Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App ( Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Expr b) -> Id -> Expr b
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
nilDataCon) (Type -> Expr b
forall b. Type -> Expr b
Type Type
intTy)
intListExpr' :: [Int] -> CoreExpr -> CoreExpr
intListExpr' :: [Int] -> CoreExpr -> CoreExpr
intListExpr' [] acc :: CoreExpr
acc = CoreExpr
acc
intListExpr' (l :: Int
l:ls :: [Int]
ls) acc :: CoreExpr
acc = [Int] -> CoreExpr -> CoreExpr
intListExpr' [Int]
ls (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
int_cons CoreExpr
acc
where int_t_cons :: Expr b
int_t_cons = Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App (Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Expr b) -> Id -> Expr b
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
consDataCon) (Type -> Expr b
forall b. Type -> Expr b
Type Type
intTy)
int_val :: CoreExpr
int_val = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> Id -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
intDataCon ) (Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
intLiteral Int
l)
int_cons :: CoreExpr
int_cons = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
forall b. Expr b
int_t_cons CoreExpr
int_val
exprToIntList :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList id :: Id
id core_expr :: CoreExpr
core_expr = do
Either Error [Int]
int_list <- Id -> CoreExpr -> CoreM (Either Error [Int])
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
core_expr
let new_expr :: Either Error CoreExpr
new_expr = [Int] -> CoreExpr
intListExpr ([Int] -> CoreExpr) -> Either Error [Int] -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error [Int]
int_list
Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error OffsetScope -> CoreM (Either Error OffsetScope))
-> Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> OffsetScope
IntList Id
id (CoreExpr -> OffsetScope)
-> Either Error CoreExpr -> Either Error OffsetScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
new_expr
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr i :: Int
i = Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
intLiteral Int
i
exprToIntVal :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntVal :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntVal id :: Id
id core_expr :: CoreExpr
core_expr = do
Either Error Int
int_val <- Id -> CoreExpr -> CoreM (Either Error Int)
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
core_expr
let new_expr :: Either Error CoreExpr
new_expr = Int -> CoreExpr
intPrimValExpr (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
int_val
Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error OffsetScope -> CoreM (Either Error OffsetScope))
-> Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> OffsetScope
IntPrimVal Id
id (CoreExpr -> OffsetScope)
-> Either Error CoreExpr -> Either Error OffsetScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
new_expr
isLitOrGlobal :: CoreExpr -> Maybe CoreExpr
isLitOrGlobal :: CoreExpr -> Maybe CoreExpr
isLitOrGlobal e :: CoreExpr
e@(Lit _) = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
isLitOrGlobal e :: CoreExpr
e@(Var id :: Id
id)
| Id -> Bool
isGlobalId Id
id
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
isLitOrGlobal _ = Maybe CoreExpr
forall a. Maybe a
Nothing
inScopeAll :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll (el :: OffsetScope
el:rest :: [OffsetScope]
rest) e :: CoreExpr
e@(Var v_id :: Id
v_id)
| Id
id <- OffsetScope -> Id
getScopeId OffsetScope
el
, Id
id Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v_id
, Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
v_id)
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ OffsetScope -> CoreExpr
getScopeExpr OffsetScope
el
| Bool
otherwise = [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
rest CoreExpr
e
inScopeAll _ _ = Maybe CoreExpr
forall a. Maybe a
Nothing
isIndexer :: Id
-> Bool
isIndexer :: Id -> Bool
isIndexer id :: Id
id = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$w!!"
caseExprIndex :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr
caseExprIndex :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr
caseExprIndex scope :: [OffsetScope]
scope expr :: CoreExpr
expr
| App beg :: CoreExpr
beg lit :: CoreExpr
lit <- CoreExpr
expr
, Just lit_expr :: CoreExpr
lit_expr <- [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
scope CoreExpr
lit Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> Maybe CoreExpr
isLitOrGlobal CoreExpr
lit
, App beg2 :: CoreExpr
beg2 offsets :: CoreExpr
offsets <- CoreExpr
beg
, Just list_expr :: CoreExpr
list_expr <- [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
scope CoreExpr
offsets Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
offsets
, App ix_var :: CoreExpr
ix_var t_int :: CoreExpr
t_int <- CoreExpr
beg2
, Var ix_id :: Id
ix_id <- CoreExpr
ix_var
, Type intt :: Type
intt <- CoreExpr
t_int
, Type -> Bool
isIntType Type
intt
, Id -> Bool
isIndexer Id
ix_id
= CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (CoreExpr -> Maybe CoreExpr) -> CoreExpr -> Maybe CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
ix_var CoreExpr
t_int) CoreExpr
list_expr) CoreExpr
lit_expr
| Bool
otherwise = Maybe CoreExpr
forall a. Maybe a
Nothing
offsetSubstitutionTree :: [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree :: [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Lit _ ) = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(App e1 :: CoreExpr
e1 e2 :: CoreExpr
e2) = do
Either Error CoreExpr
subs1 <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e1
Either Error CoreExpr
subs2 <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e2
Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs1 Either Error (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error CoreExpr
subs2
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Cast expr :: CoreExpr
expr c :: Coercion
c) = do
Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> Coercion -> CoreExpr)
-> Either Error CoreExpr -> Either Error (Coercion -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs Either Error (Coercion -> CoreExpr)
-> Either Error Coercion -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Either Error Coercion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coercion
c
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Tick t :: Tickish Id
t expr :: CoreExpr
expr) = do
Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Type _ ) = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Coercion _) = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Lam b :: Id
b expr :: CoreExpr
expr) = do
Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
b (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs
offsetSubstitutionTree scope :: [OffsetScope]
scope expr :: CoreExpr
expr
| Let offset_bind :: CoreBind
offset_bind in_expr :: CoreExpr
in_expr <- CoreExpr
expr
, NonRec offset_id :: Id
offset_id offset_expr :: CoreExpr
offset_expr <- CoreBind
offset_bind
, Id -> Bool
isOffsetsId Id
offset_id
= do
Either Error OffsetScope
e_new_s <- Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList Id
offset_id CoreExpr
offset_expr
case Either Error OffsetScope
e_new_s of
Left err :: Error
err -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left Error
err
Right int_list :: OffsetScope
int_list -> [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree (OffsetScope
int_listOffsetScope -> [OffsetScope] -> [OffsetScope]
forall a. a -> [a] -> [a]
:[OffsetScope]
scope) CoreExpr
in_expr
| Let bind :: CoreBind
bind in_expr :: CoreExpr
in_expr <- CoreExpr
expr
= do
Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
in_expr
let sub_idexpr :: (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
sub_idexpr (id :: a
id,e :: CoreExpr
e) = do
Either Error CoreExpr
inner_subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e
Either Error (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr)))
-> Either Error (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
forall a b. (a -> b) -> a -> b
$ (,) a
id (CoreExpr -> (a, CoreExpr))
-> Either Error CoreExpr -> Either Error (a, CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
inner_subs
sub_bind :: CoreBind -> CoreM (Either Error CoreBind)
sub_bind (NonRec id :: Id
id e :: CoreExpr
e) = do
Either Error CoreExpr
inner_subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e
Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
inner_subs
sub_bind (Rec bs :: [(Id, CoreExpr)]
bs) = do
[Either Error (Id, CoreExpr)]
inner_subs <- ((Id, CoreExpr) -> CoreM (Either Error (Id, CoreExpr)))
-> [(Id, CoreExpr)] -> CoreM [Either Error (Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, CoreExpr) -> CoreM (Either Error (Id, CoreExpr))
forall a. (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
sub_idexpr [(Id, CoreExpr)]
bs
case [Either Error (Id, CoreExpr)] -> [Error]
forall a b. [Either a b] -> [a]
lefts [Either Error (Id, CoreExpr)]
inner_subs of
[] -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right (CoreBind -> Either Error CoreBind)
-> CoreBind -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Either Error (Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. [Either a b] -> [b]
rights [Either Error (Id, CoreExpr)]
inner_subs)
(err :: Error
err:_) -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left Error
err
Either Error CoreBind
bind_subs <- CoreBind -> CoreM (Either Error CoreBind)
sub_bind CoreBind
bind
Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBind -> CoreExpr -> CoreExpr)
-> Either Error CoreBind -> Either Error (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreBind
bind_subs Either Error (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error CoreExpr
subs
| Case case_expr :: CoreExpr
case_expr _ _ [alt0 :: Alt Id
alt0] <- CoreExpr
expr
, (DataAlt i_prim_con :: DataCon
i_prim_con, [x_id :: Id
x_id], alt_expr :: CoreExpr
alt_expr) <- Alt Id
alt0
, DataCon
i_prim_con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
intDataCon
, Just new_case_expr :: CoreExpr
new_case_expr <- [OffsetScope] -> CoreExpr -> Maybe CoreExpr
caseExprIndex [OffsetScope]
scope CoreExpr
case_expr
= do
Either Error OffsetScope
e_new_s <- Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntVal Id
x_id CoreExpr
new_case_expr
case Either Error OffsetScope
e_new_s of
Left err :: Error
err -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left Error
err
Right int_val :: OffsetScope
int_val -> [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree (OffsetScope
int_valOffsetScope -> [OffsetScope] -> [OffsetScope]
forall a. a -> [a] -> [a]
:[OffsetScope]
scope) CoreExpr
alt_expr
| Case case_expr :: CoreExpr
case_expr cb :: Id
cb t :: Type
t alts :: [Alt Id]
alts <- CoreExpr
expr
= do
[(AltCon, [Id], Either Error CoreExpr)]
e_new_alts <- (Alt Id -> CoreM (AltCon, [Id], Either Error CoreExpr))
-> [Alt Id] -> CoreM [(AltCon, [Id], Either Error CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(a :: AltCon
a, args :: [Id]
args, a_expr :: CoreExpr
a_expr) -> (,,) AltCon
a [Id]
args (Either Error CoreExpr -> (AltCon, [Id], Either Error CoreExpr))
-> CoreM (Either Error CoreExpr)
-> CoreM (AltCon, [Id], Either Error CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
a_expr) [Alt Id]
alts
Either Error CoreExpr
new_case_expr <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
case_expr
let c_err :: Maybe (AltCon, [Id], Either Error CoreExpr)
c_err = ((AltCon, [Id], Either Error CoreExpr) -> Bool)
-> [(AltCon, [Id], Either Error CoreExpr)]
-> Maybe (AltCon, [Id], Either Error CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(_,_,e :: Either Error CoreExpr
e) -> Either Error CoreExpr -> Bool
forall a b. Either a b -> Bool
isLeft Either Error CoreExpr
e) [(AltCon, [Id], Either Error CoreExpr)]
e_new_alts
case Maybe (AltCon, [Id], Either Error CoreExpr)
c_err of
Nothing -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr)
-> Either Error CoreExpr
-> Either Error (Id -> Type -> [Alt Id] -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
new_case_expr
Either Error (Id -> Type -> [Alt Id] -> CoreExpr)
-> Either Error Id -> Either Error (Type -> [Alt Id] -> CoreExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> Either Error Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
cb Either Error (Type -> [Alt Id] -> CoreExpr)
-> Either Error Type -> Either Error ([Alt Id] -> CoreExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Error Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t Either Error ([Alt Id] -> CoreExpr)
-> Either Error [Alt Id] -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Alt Id] -> Either Error [Alt Id]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(AltCon
a,[Id]
b,CoreExpr
ne) | (a :: AltCon
a,b :: [Id]
b,Right ne :: CoreExpr
ne) <- [(AltCon, [Id], Either Error CoreExpr)]
e_new_alts]
Just (_,_,err :: Either Error CoreExpr
err) -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreExpr
err
| Var id :: Id
id <- CoreExpr
expr
= do
let m_subs :: Maybe CoreExpr
m_subs = [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
scope CoreExpr
expr
new_e :: Maybe CoreExpr
new_e = Maybe CoreExpr
m_subs Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
expr
case Maybe CoreExpr
new_e of
Just e :: CoreExpr
e -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
Nothing -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError (String -> SDoc
text "This shouldn't happen."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "`m_subs <|> Just e` cannot be `Nothing`.")
| Bool
otherwise = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError (SDoc -> Error) -> SDoc -> Error
forall a b. (a -> b) -> a -> b
$ (String -> SDoc
text "Unsupported expression:" SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind core_bind :: CoreBind
core_bind
| (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
, Id -> Bool
isSizeOfId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecSizeOfId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoiceSizeOfId Id
id
= CoreBind -> CoreM (Either Error CoreBind)
intSubstitution CoreBind
core_bind
| (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
, Id -> Bool
isAlignmentId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecAlignmentId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoiceAlignmentId Id
id
= CoreBind -> CoreM (Either Error CoreBind)
intSubstitution CoreBind
core_bind
| (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
, Id -> Bool
isPeekId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecPeekId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoicePeekId Id
id
= CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution CoreBind
core_bind
| (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
, Id -> Bool
isPokeId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecPokeId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoicePokeId Id
id
= CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution CoreBind
core_bind
| Bool
otherwise = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
core_bind
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind b :: CoreBind
b@(NonRec id :: Id
id expr :: CoreExpr
expr)
| NonRec id :: Id
id expr :: CoreExpr
expr <- CoreBind
b
, Id -> Bool
isId Id
id
, IdInfo
id_info <- HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
, Unfolding
unfolding <- IdInfo -> Unfolding
unfoldingInfo IdInfo
id_info
, Unfolding -> CoreExpr
_ <- Unfolding -> CoreExpr
uf_tmpl
= Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> IdInfo -> Id
setIdInfo Id
id (IdInfo -> Id) -> IdInfo -> Id
forall a b. (a -> b) -> a -> b
$ IdInfo
id_info {unfoldingInfo :: Unfolding
unfoldingInfo = Unfolding
unfolding{uf_tmpl :: CoreExpr
uf_tmpl = CoreExpr
expr} } ) CoreExpr
expr
| Bool
otherwise
= CoreBind
b
lintBind :: CoreBind
-> CoreBind
-> CoreM (Either Error CoreBind)
lintBind :: CoreBind -> CoreBind -> CoreM (Either Error CoreBind)
lintBind b_old :: CoreBind
b_old b :: CoreBind
b@(NonRec id :: Id
id expr :: CoreExpr
expr) = do
DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case DynFlags -> [Id] -> CoreExpr -> Maybe SDoc
lintExpr DynFlags
dyn_flags [] CoreExpr
expr of
Just sdoc :: SDoc
sdoc -> (Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b_old SDoc
sdoc)
Nothing -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right CoreBind
b
lintBind b_old :: CoreBind
b_old b :: CoreBind
b@(Rec bs :: [(Id, CoreExpr)]
bs) = do
DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let errs :: [SDoc]
errs = ((Id, CoreExpr) -> Maybe SDoc) -> [(Id, CoreExpr)] -> [SDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(_,expr :: CoreExpr
expr) -> DynFlags -> [Id] -> CoreExpr -> Maybe SDoc
lintExpr DynFlags
dyn_flags [] CoreExpr
expr) [(Id, CoreExpr)]
bs
case [SDoc]
errs of
[] -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right CoreBind
b
_ -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b_old ([SDoc] -> SDoc
vcat [SDoc]
errs)
replaceIdsBind :: [CoreBind]
-> [CoreBind]
-> CoreBind
-> CoreBind
replaceIdsBind :: [CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (NonRec id :: Id
id e :: CoreExpr
e) = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
replaceIdsBind gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Rec recs :: [(Id, CoreExpr)]
recs) = [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, CoreExpr)] -> CoreBind) -> [(Id, CoreExpr)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ ((Id, CoreExpr) -> (Id, CoreExpr))
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(id :: Id
id,e :: CoreExpr
e) -> (Id
id,[CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)) [(Id, CoreExpr)]
recs
replaceIds :: [CoreBind]
-> [CoreBind]
-> CoreExpr
-> CoreExpr
replaceIds :: [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs e :: CoreExpr
e@(Var id :: Id
id)
| Id -> Bool
isLocalId Id
id
, Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) ([(Id, CoreExpr)] -> Maybe (Id, CoreExpr))
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall a b. (a -> b) -> a -> b
$ [(Id
id,CoreExpr
expr) | NonRec id :: Id
id expr :: CoreExpr
expr <- [CoreBind]
gstorable_bs]
= [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
expr
| Id -> Bool
isLocalId Id
id
, Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) ([(Id, CoreExpr)] -> Maybe (Id, CoreExpr))
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall a b. (a -> b) -> a -> b
$ [(Id
id,CoreExpr
expr) | NonRec id :: Id
id expr :: CoreExpr
expr <- [CoreBind]
other_bs]
= [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
expr
| Id -> Bool
isLocalId Id
id
, ([id_here :: [(Id, CoreExpr)]
id_here],rest :: [[(Id, CoreExpr)]]
rest) <- ([(Id, CoreExpr)] -> Bool)
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\x :: [(Id, CoreExpr)]
x -> Id
id Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
x)) ([[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]]))
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a b. (a -> b) -> a -> b
$ [[(Id, CoreExpr)]
bs | Rec bs :: [(Id, CoreExpr)]
bs <- [CoreBind]
gstorable_bs]
, Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
id_here
= [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds (([(Id, CoreExpr)] -> CoreBind) -> [[(Id, CoreExpr)]] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [[(Id, CoreExpr)]]
rest) [CoreBind]
other_bs CoreExpr
expr
| Id -> Bool
isLocalId Id
id
, ([id_here :: [(Id, CoreExpr)]
id_here],rest :: [[(Id, CoreExpr)]]
rest) <- ([(Id, CoreExpr)] -> Bool)
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\x :: [(Id, CoreExpr)]
x -> Id
id Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
x)) ([[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]]))
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a b. (a -> b) -> a -> b
$ [[(Id, CoreExpr)]
bs | Rec bs :: [(Id, CoreExpr)]
bs <- [CoreBind]
other_bs]
, Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
id_here
= [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs (([(Id, CoreExpr)] -> CoreBind) -> [[(Id, CoreExpr)]] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [[(Id, CoreExpr)]]
rest) CoreExpr
expr
| Bool
otherwise = CoreExpr
e
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (App e1 :: CoreExpr
e1 e2 :: CoreExpr
e2) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e1) ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e2)
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Lam id :: Id
id e :: CoreExpr
e) = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
id ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Let b :: CoreBind
b e :: CoreExpr
e) = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreBind
b) ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Case e :: CoreExpr
e ev :: Id
ev t :: Type
t alts :: [Alt Id]
alts) = do
let new_e :: CoreExpr
new_e = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e
new_alts :: [Alt Id]
new_alts = (Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map (\(alt :: AltCon
alt, ids :: [Id]
ids, exprs :: CoreExpr
exprs) -> (AltCon
alt,[Id]
ids, [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
exprs)) [Alt Id]
alts
CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
new_e Id
ev Type
t [Alt Id]
new_alts
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Cast e :: CoreExpr
e c :: Coercion
c) = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e) Coercion
c
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Tick t :: Tickish Id
t e :: CoreExpr
e) = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs e :: CoreExpr
e = CoreExpr
e
compileGroups :: Flags
-> [[CoreBind]]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups :: Flags -> [[CoreBind]] -> [CoreBind] -> CoreM [CoreBind]
compileGroups flags :: Flags
flags bind_groups :: [[CoreBind]]
bind_groups bind_rest :: [CoreBind]
bind_rest = Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags 0 [[CoreBind]]
bind_groups [CoreBind]
bind_rest [] []
compileGroups_rec :: Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec :: Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec flags :: Flags
flags _ [] bind_rest :: [CoreBind]
bind_rest subs :: [CoreBind]
subs not_subs :: [CoreBind]
not_subs = [CoreBind] -> CoreM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreM [CoreBind]) -> [CoreBind] -> CoreM [CoreBind]
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> [CoreBind]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreBind]
subs,[CoreBind]
not_subs]
compileGroups_rec flags :: Flags
flags d :: Int
d (bg :: [CoreBind]
bg:bgs :: [[CoreBind]]
bgs) bind_rest :: [CoreBind]
bind_rest subs :: [CoreBind]
subs not_subs :: [CoreBind]
not_subs = do
let layer_replaced :: [CoreBind]
layer_replaced = (CoreBind -> CoreBind) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind [CoreBind]
bind_rest [CoreBind]
subs) [CoreBind]
bg
compile_and_lint :: CoreBind -> CoreM (Either Error CoreBind)
compile_and_lint bind :: CoreBind
bind = do
Either Error CoreBind
e_compiled <- CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind CoreBind
bind
case Either Error CoreBind
e_compiled of
Right bind' :: CoreBind
bind' -> CoreBind -> CoreBind -> CoreM (Either Error CoreBind)
lintBind CoreBind
bind (CoreBind -> CoreBind
replaceUnfoldingBind CoreBind
bind')
_ -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
e_compiled
[Either Error CoreBind]
e_compiled <- (CoreBind -> CoreM (Either Error CoreBind))
-> [CoreBind] -> CoreM [Either Error CoreBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CoreBind -> CoreM (Either Error CoreBind)
compile_and_lint [CoreBind]
layer_replaced
let errors :: [Error]
errors = [Either Error CoreBind] -> [Error]
forall a b. [Either a b] -> [a]
lefts [Either Error CoreBind]
e_compiled
compiled :: [CoreBind]
compiled = [Either Error CoreBind] -> [CoreBind]
forall a b. [Either a b] -> [b]
rights [Either Error CoreBind]
e_compiled
[CoreBind]
not_compiled <- Flags -> Int -> [Error] -> CoreM [CoreBind]
compileGroups_error Flags
flags Int
d [Error]
errors
Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [[CoreBind]]
bgs [CoreBind]
bind_rest ([[CoreBind]] -> [CoreBind]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreBind]
compiled,[CoreBind]
subs]) ([[CoreBind]] -> [CoreBind]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreBind]
not_compiled, [CoreBind]
not_subs])
compileGroups_error :: Flags
-> Int
-> [Error]
-> CoreM [CoreBind]
compileGroups_error :: Flags -> Int -> [Error] -> CoreM [CoreBind]
compileGroups_error flags :: Flags
flags d :: Int
d errors :: [Error]
errors = do
let (Flags verb :: Verbosity
verb to_crash :: Bool
to_crash) = Flags
flags
crasher :: [a] -> m ()
crasher errs :: [a]
errs = case [a]
errs of
[] -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> String -> m ()
forall a. HasCallStack => String -> a
error "Crashing..."
print_header :: SDoc -> SDoc
print_header txt :: SDoc
txt = case Verbosity
verb of
None -> SDoc
empty
other :: Verbosity
other -> String -> SDoc
text "Errors while compiling and substituting bindings at depth " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
d SDoc -> SDoc -> SDoc
<> String -> SDoc
text ":"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 SDoc
txt
printer :: [Error] -> CoreM ()
printer errs :: [Error]
errs = case [Error]
errs of
[] -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ls :: [Error]
ls -> SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
print_header ([SDoc] -> SDoc
vcat ((Error -> SDoc) -> [Error] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Verbosity -> Error -> SDoc
pprError Verbosity
verb) [Error]
errs))
ungroup :: Error -> Maybe CoreBind
ungroup err :: Error
err = case Error
err of
(CompilationNotSupported bind :: CoreBind
bind) -> CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just CoreBind
bind
(CompilationError bind :: CoreBind
bind _) -> CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just CoreBind
bind
_ -> Maybe CoreBind
forall a. Maybe a
Nothing
[Error] -> CoreM ()
printer [Error]
errors
Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
to_crash (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ [Error] -> CoreM ()
forall (m :: * -> *) a. Monad m => [a] -> m ()
crasher [Error]
errors
[CoreBind] -> CoreM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreM [CoreBind]) -> [CoreBind] -> CoreM [CoreBind]
forall a b. (a -> b) -> a -> b
$ (Error -> Maybe CoreBind) -> [Error] -> [CoreBind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Error -> Maybe CoreBind
ungroup [Error]
errors