{-|
Module      : Foreign.Storable.Generic.Plugin.Internal.Compile
Copyright   : (c) Mateusz Kłoczko, 2016
License     : MIT
Maintainer  : mateusz.p.kloczko@gmail.com
Stability   : experimental
Portability : GHC-only

The core of compile and substitute optimisations.

-}
{-#LANGUAGE CPP#-}
module Foreign.Storable.Generic.Plugin.Internal.Compile
    (
    -- Compilation
      compileExpr
    , tryCompileExpr
    -- Int substitution
    , intToExpr
    , intSubstitution
    -- Offset substitution
    , offsetSubstitution
    , offsetSubstitutionTree
    , OffsetScope(..)
    , getScopeId
    , getScopeExpr
    , intListExpr
    , exprToIntList
    , isLitOrGlobal
    , inScopeAll
    , isIndexer
    , caseExprIndex
    -- GStorable compilation-substitution
    , compileGStorableBind
    , lintBind
    , replaceIdsBind
    , compileGroups
    )

where

import Prelude hiding ((<>))

#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Core (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt(..), AltCon(..), isId, Unfolding(..))
import GHC.Types.Literal (Literal(..))
import GHC.Types.Id      (isLocalId, isGlobalId,setIdInfo, Id)
import GHC.Types.Id.Info (IdInfo(..), setUnfoldingInfo, unfoldingInfo)
import GHC.Types.Var             (Var(..))
import GHC.Types.Name            (getOccName,mkOccName,getSrcSpan)
import GHC.Types.Name.Occurrence (OccName(..), occNameString)
import qualified GHC.Types.Name as N (varName)
import GHC.Types.SrcLoc (noSrcSpan,SrcSpan)
import GHC.Types.Unique (getUnique)
import GHC.Driver.Main (hscCompileCoreExpr)
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
import GHC.Data.Bag (bagToList)
import GHC.Driver.Env.Types (HscEnv)
import GHC.Unit.Module.ModGuts (ModGuts(..))
#else
import GHC.Driver.Types (HscEnv,ModGuts(..))
#endif
import GHC.Core.Opt.Monad (CoreM,getHscEnv,getDynFlags)
#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
import GHC.Core.Opt.Pipeline.Types (CoreToDo(..))
#else
import GHC.Core.Opt.Monad (CoreToDo(..))
#endif
import GHC.Core.Lint (lintExpr)
import GHC.Types.Basic (CompilerPhase(..), Boxity(..))
import GHC.Core.Type
import GHC.Core.TyCon (algTyConRhs, visibleDataCons)
import GHC.Builtin.Types
import GHC.Core.DataCon    (dataConWorkId,dataConOrigArgTys)
import GHC.Core.Make       (mkWildValBinder)
import GHC.Utils.Outputable (cat, ppr, SDoc, showSDocUnsafe)
import GHC.Utils.Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma)
import GHC.Core.Opt.Monad (putMsg, putMsgS)
import GHC.Builtin.Names  (buildIdKey, augmentIdKey)
import GHC.Builtin.Types.Prim (intPrimTy)
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import CoreSyn (Bind(..),Expr(..), CoreExpr, CoreBind, CoreProgram, Alt, AltCon(..), isId, Unfolding(..))
import Literal (Literal(..))
import Id  (isLocalId, isGlobalId,setIdInfo, Id)
import IdInfo (IdInfo(..), setUnfoldingInfo)
import Var (Var(..))
import Name (getOccName,mkOccName,getSrcSpan)
import OccName (OccName(..), occNameString)
import qualified Name as N (varName)
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(..), Boxity(..))
import Type (isAlgType, splitTyConApp_maybe)
import TyCon (algTyConRhs, visibleDataCons)
import TysWiredIn
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 PrelNames (buildIdKey, augmentIdKey)
import TysPrim (intPrimTy)
#endif



-- Used to get to compiled values
import GHCi.RemoteTypes


#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
import GHC.Types.Var (TyVarBinder(..), VarBndr(..))
import GHC.Core.TyCo.Rep (Type(..), scaledThing)
import GHC.Types.Var
import GHC.Driver.Config.Core.Lint (initLintConfig)
#define Many ManyTy
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Types.Var (TyVarBinder(..), VarBndr(..))
import GHC.Core.TyCo.Rep (Type(..), TyBinder(..), TyCoBinder(..),scaledThing)
import GHC.Types.Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
import Var (TyVarBinder(..), VarBndr(..))
import TyCoRep (Type(..), TyBinder(..), TyCoBinder(..))
import Var
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)
import Var (TyVarBndr(..), TyVarBinder)
import TyCoRep (Type(..), TyBinder(..))
import Var
#endif

#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Types.Literal (LitNumType(..))
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
import Literal (LitNumType(..))
#endif

-- Management of Core.
-- 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)
-- -- Compilation pipeline stuff
-- import HscMain (hscCompileCoreExpr)
-- import HscTypes (HscEnv,ModGuts(..))
-- import CoreMonad (CoreM,CoreToDo(..), getHscEnv, getDynFlags)
-- import CoreLint (lintExpr)
-- import BasicTypes (CompilerPhase(..))
-- -- Haskell types
-- 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 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

#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
-- See 778c6adca2c995cd8a1b84394d4d5ca26b915dac
type TyBinder = PiTyBinder
type TyCoVarBinder = ForAllTyBinder
#endif

---------------------
-- compile helpers --
---------------------

-- | Compile an expression.
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr :: forall a. HscEnv -> Expr Id -> SrcSpan -> IO a
compileExpr HscEnv
hsc_env Expr Id
expr SrcSpan
src_span = do
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
    (ForeignHValue
foreign_hval, [Linkable]
_, PkgsLoaded
_) <-
#else
    foreign_hval <-
#endif
      IO (ForeignHValue, [Linkable], PkgsLoaded)
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForeignHValue, [Linkable], PkgsLoaded)
 -> IO (ForeignHValue, [Linkable], PkgsLoaded))
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> SrcSpan -> Expr Id -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span Expr Id
expr
    HValue
hval         <- IO HValue -> IO HValue
forall a. IO a -> IO a
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
    -- finalizeForeignRef foreign_hval  -- check whether that's the source of the error
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall {a}. a
val

-- | Try to compile an expression. Perhaps return an error.
tryCompileExpr :: Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr :: forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
core_expr  = do
    HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
    Either SomeException a
e_compiled <- IO (Either SomeException a) -> CoreM (Either SomeException a)
forall a. IO a -> CoreM 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 -> Expr Id -> SrcSpan -> IO a
forall a. HscEnv -> Expr Id -> SrcSpan -> IO a
compileExpr HscEnv
hsc_env Expr Id
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  SomeException
se  -> Either Error a -> CoreM (Either Error a)
forall a. a -> CoreM 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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
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 a
val-> Either Error a -> CoreM (Either Error a)
forall a. a -> CoreM 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

----------------------
-- Int substitution --
----------------------

-- | A small helper - create an integer literal.
intLiteral :: (Integral a) => a -> CoreExpr
#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
intLiteral :: forall a. Integral a => a -> Expr Id
intLiteral a
i =  Literal -> Expr Id
forall b. Literal -> Expr b
Lit (Literal -> Expr Id) -> Literal -> Expr Id
forall a b. (a -> b) -> a -> b
$ LitNumType -> Integer -> Literal
LitNumber LitNumType
LitNumInt (a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
intLiteral i =  Lit $ LitNumber LitNumInt (fromIntegral i) intPrimTy
#else
intLiteral i = Lit $ MachInt $ fromIntegral i
#endif

-- | Create an expression of form: \x -> 16
intToExpr :: Type -> Int -> CoreExpr
intToExpr :: Type -> Int -> Expr Id
intToExpr Type
t Int
i = Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
wild (Expr Id -> Expr Id) -> Expr Id -> Expr Id
forall a b. (a -> b) -> a -> b
$ Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App Expr Id
forall {b}. Expr b
fun Expr Id
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 = Lit $ MachInt $ fromIntegral i
          arg :: Expr Id
arg = Int -> Expr Id
forall a. Integral a => a -> Expr Id
intLiteral Int
i
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
          wild :: Id
wild= Type -> Type -> Id
mkWildValBinder Many t
#else
          wild= mkWildValBinder t
#endif

-- | For gsizeOf and galignment - calculate the variables.
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution b :: CoreBind
b@(Rec    [(Id, Expr Id)]
_) = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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
-- For GSTORABLE_SUMTYPES
intSubstitution b :: CoreBind
b@(NonRec Id
id (Lam Id
l1 l :: Expr Id
l@(Lam Id
l2 e :: Expr Id
e@(Lam Id
l3 Expr Id
expr)))) = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    Either Error Int
the_integer <- Id -> Expr Id -> CoreM (Either Error Int)
forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
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 Type
t ->  Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Expr Id -> CoreBind)
-> Either Error (Expr Id) -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
l1 (Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
l2 (Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> Expr Id
intToExpr Type
t (Int -> Expr Id) -> Either Error Int -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)))
        Maybe Type
Nothing ->
            Either Error Int -> Either Error CoreBind -> Either Error Int
forall a. a -> Either Error CoreBind -> a
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 a b.
(Either Error CoreBind -> a)
-> (Either Error CoreBind -> b) -> Either Error CoreBind -> b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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
forall doc. IsLine doc => String -> doc
text String
"Type not found"]
-- Without GSTORABLE_SUMPTYPES
intSubstitution b :: CoreBind
b@(NonRec Id
id (Lam Id
l1 Expr Id
expr)) = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    Either Error Int
the_integer <- Id -> Expr Id -> CoreM (Either Error Int)
forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
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 Type
t ->  Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Expr Id -> CoreBind)
-> Either Error (Expr Id) -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> Expr Id
intToExpr Type
t (Int -> Expr Id) -> Either Error Int -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
        Maybe Type
Nothing ->
            Either Error Int -> Either Error CoreBind -> Either Error Int
forall a. a -> Either Error CoreBind -> a
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 a b.
(Either Error CoreBind -> a)
-> (Either Error CoreBind -> b) -> Either Error CoreBind -> b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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
forall doc. IsLine doc => String -> doc
text String
"Type not found"]
-- For GHC <= 8.6.5
intSubstitution b :: CoreBind
b@(NonRec Id
id e :: Expr Id
e@(App Expr Id
expr Expr Id
g)) = case Expr Id
expr of
     Lam Id
_ (Lam Id
_ (Lam Id
_ Expr Id
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
expr
     App Expr Id
e Expr Id
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
e
        case Either Error CoreBind
subs of
            Right (NonRec Id
i (Lam Id
l1 (Lam Id
l2 Expr Id
e)) ) -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
i Expr Id
e)
            Either Error CoreBind
err                                   -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
err
     Expr Id
_                       -> Id -> Expr Id -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id Expr Id
expr
intSubstitution b :: CoreBind
b@(NonRec Id
id (Case Expr Id
_ Id
_ Type
_ [Alt Id]
_)) = 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
$ String
"am case"
intSubstitution b :: CoreBind
b@(NonRec Id
id (Let CoreBind
_ Expr Id
_)) = 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
$ String
"am let"
intSubstitution b :: CoreBind
b@(NonRec Id
id Expr Id
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
$ Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
e

intSubstitutionWorker :: Id -> Expr Id -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id Expr Id
expr = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    Either Error Int
the_integer <- Id -> Expr Id -> CoreM (Either Error Int)
forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
expr :: CoreM (Either Error Int)
    -- Get the type.
    let m_t :: Maybe Type
m_t      = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id)
    case Maybe Type
m_t of
        Just Type
t ->  Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Expr Id -> CoreBind)
-> Either Error (Expr Id) -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> Expr Id
intToExpr Type
t (Int -> Expr Id) -> Either Error Int -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
        -- If the compilation error occured, first return it.
        Maybe Type
Nothing ->
            Either Error Int -> Either Error CoreBind -> Either Error Int
forall a. a -> Either Error CoreBind -> a
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 a b.
(Either Error CoreBind -> a)
-> (Either Error CoreBind -> b) -> Either Error CoreBind -> b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
expr) [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type not found"]
-----------------------
-- peek substitution --
-----------------------

-- | Try to substitute the offsets.
offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution b :: CoreBind
b@(Rec [(Id, Expr Id)]
_) = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 Expr Id
expr) = do
    Either Error (Expr Id)
e_subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [] Expr Id
expr
    let ne_subs :: Either Error (Expr Id)
ne_subs = case Either Error (Expr Id)
e_subs of
             -- Add the text from other error.
             Left (OtherError SDoc
sdoc)
                 -> Error -> Either Error (Expr Id)
forall a b. a -> Either a b
Left (Error -> Either Error (Expr Id))
-> Error -> Either Error (Expr Id)
forall a b. (a -> b) -> a -> b
$ CoreBind -> [SDoc] -> Error
CompilationError CoreBind
b [SDoc
sdoc]
             -- Add the information about uncompiled expr.
             Left err :: Error
err@(CompilationError CoreBind
_ [SDoc]
_)
                 -> Error -> Either Error (Expr Id)
forall a b. a -> Either a b
Left (Error -> Either Error (Expr Id))
-> Error -> Either Error (Expr Id)
forall a b. (a -> b) -> a -> b
$ CoreBind -> [SDoc] -> Error
CompilationError CoreBind
b [Verbosity -> Error -> SDoc
pprError Verbosity
Some Error
err]
             Either Error (Expr Id)
a   -> Either Error (Expr Id)
a

    Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Expr Id -> CoreBind)
-> Either Error (Expr Id) -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
e_subs


-- | Scoped variables for optimising offsets.
data OffsetScope = IntList Id CoreExpr
                 | IntPrimVal  Id CoreExpr

-- | Get 'Id' from 'OffsetScope'
getScopeId   :: OffsetScope -> Id
getScopeId :: OffsetScope -> Id
getScopeId (IntList      Id
id Expr Id
_) = Id
id
getScopeId (IntPrimVal   Id
id Expr Id
_) = Id
id

-- | Get 'CoreExpr' from 'OffsetScope'
getScopeExpr :: OffsetScope -> CoreExpr
getScopeExpr :: OffsetScope -> Expr Id
getScopeExpr (IntList      Id
_ Expr Id
expr) = Expr Id
expr
getScopeExpr (IntPrimVal   Id
_ Expr Id
expr) = Expr Id
expr

instance Outputable OffsetScope where
    ppr :: OffsetScope -> SDoc
ppr (IntList    Id
id Expr Id
expr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
id) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
expr
    ppr (IntPrimVal Id
id Expr Id
expr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
id) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
expr

#if !MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
    pprPrec _ el = ppr el
#endif

-- | Create a list expression from Haskell list.
intListExpr :: [Int] -> CoreExpr
intListExpr :: [Int] -> Expr Id
intListExpr [Int]
list = [Int] -> Expr Id -> Expr Id
intListExpr' ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
list) Expr Id
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] -> Expr Id -> Expr Id
intListExpr'  []    Expr Id
acc = Expr Id
acc
intListExpr' (Int
l:[Int]
ls) Expr Id
acc = [Int] -> Expr Id -> Expr Id
intListExpr' [Int]
ls (Expr Id -> Expr Id) -> Expr Id -> Expr Id
forall a b. (a -> b) -> a -> b
$ Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App Expr Id
int_cons Expr Id
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 :: Expr Id
int_val    = Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App (Id -> Expr Id
forall b. Id -> Expr b
Var (Id -> Expr Id) -> Id -> Expr Id
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
intDataCon ) (Int -> Expr Id
forall a. Integral a => a -> Expr Id
intLiteral Int
l)
          int_cons :: Expr Id
int_cons   = Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App Expr Id
forall {b}. Expr b
int_t_cons Expr Id
int_val

-- | Compile expression to list and then write it back to core expr.
exprToIntList :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList :: Id -> Expr Id -> CoreM (Either Error OffsetScope)
exprToIntList Id
id Expr Id
core_expr = do
    Either Error [Int]
int_list <- Id -> Expr Id -> CoreM (Either Error [Int])
forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
core_expr
    let new_expr :: Either Error (Expr Id)
new_expr = [Int] -> Expr Id
intListExpr ([Int] -> Expr Id) -> Either Error [Int] -> Either Error (Expr Id)
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 a. a -> CoreM a
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 -> Expr Id -> OffsetScope
IntList Id
id (Expr Id -> OffsetScope)
-> Either Error (Expr Id) -> Either Error OffsetScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
new_expr

-- | Create a int prim expression.
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr :: Int -> Expr Id
intPrimValExpr Int
i = Int -> Expr Id
forall a. Integral a => a -> Expr Id
intLiteral Int
i

-- | Compile expression to int prim and then write it back to core expr.
exprToIntVal :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntVal :: Id -> Expr Id -> CoreM (Either Error OffsetScope)
exprToIntVal Id
id Expr Id
core_expr = do
    Either Error Int
int_val <- Id -> Expr Id -> CoreM (Either Error Int)
forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
core_expr
    let new_expr :: Either Error (Expr Id)
new_expr = Int -> Expr Id
intPrimValExpr (Int -> Expr Id) -> Either Error Int -> Either Error (Expr Id)
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 a. a -> CoreM a
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 -> Expr Id -> OffsetScope
IntPrimVal Id
id (Expr Id -> OffsetScope)
-> Either Error (Expr Id) -> Either Error OffsetScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
new_expr

-- | Return the expression if it's a literal or global.
isLitOrGlobal :: CoreExpr -> Maybe CoreExpr
-- Whether it is a literal.
isLitOrGlobal :: Expr Id -> Maybe (Expr Id)
isLitOrGlobal e :: Expr Id
e@(Lit Literal
_) = Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just Expr Id
e
-- Whether it is a global id:
isLitOrGlobal e :: Expr Id
e@(Var Id
id)
    | Id -> Bool
isGlobalId Id
id
    = Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just Expr Id
e
isLitOrGlobal Expr Id
_ = Maybe (Expr Id)
forall a. Maybe a
Nothing

-- | Check whether the given CoreExpr is an id,
-- and if yes - substitute it.
inScopeAll :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll :: [OffsetScope] -> Expr Id -> Maybe (Expr Id)
inScopeAll (OffsetScope
el:[OffsetScope]
rest) e :: Expr Id
e@(Var Id
v_id)
    | Id
id <- OffsetScope -> Id
getScopeId OffsetScope
el
    -- Thought uniques will be unique inside.
    , Id
id Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v_id
    -- Check whether the types have the same name and 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)
    = Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just (Expr Id -> Maybe (Expr Id)) -> Expr Id -> Maybe (Expr Id)
forall a b. (a -> b) -> a -> b
$ OffsetScope -> Expr Id
getScopeExpr OffsetScope
el
    | Bool
otherwise = [OffsetScope] -> Expr Id -> Maybe (Expr Id)
inScopeAll [OffsetScope]
rest Expr Id
e
inScopeAll [OffsetScope]
_  Expr Id
_ = Maybe (Expr Id)
forall a. Maybe a
Nothing


-- | Is an "$w!!" identifier
isIndexer :: Id
          -> Bool
isIndexer :: Id -> Bool
isIndexer 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 String
"$w!!"

-- | Try to create a compileable version of case expr body.
-- For !! @Int offsets val expressions.
caseExprIndex :: [OffsetScope] -> CoreExpr -> Maybe CoreExpr
caseExprIndex :: [OffsetScope] -> Expr Id -> Maybe (Expr Id)
caseExprIndex [OffsetScope]
scope Expr Id
expr
    -- A long list of what needs to be inside the expression.
    | App Expr Id
beg Expr Id
lit <- Expr Id
expr
    -- Substitute or leave the literal be. Otherwise cancel.
    , Just Expr Id
lit_expr <- [OffsetScope] -> Expr Id -> Maybe (Expr Id)
inScopeAll [OffsetScope]
scope Expr Id
lit Maybe (Expr Id) -> Maybe (Expr Id) -> Maybe (Expr Id)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr Id -> Maybe (Expr Id)
isLitOrGlobal Expr Id
lit
    , App Expr Id
beg2 Expr Id
offsets <- Expr Id
beg
    -- Substitute or leave the offsets list free.
    , Just Expr Id
list_expr <- [OffsetScope] -> Expr Id -> Maybe (Expr Id)
inScopeAll [OffsetScope]
scope Expr Id
offsets Maybe (Expr Id) -> Maybe (Expr Id) -> Maybe (Expr Id)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just Expr Id
offsets
    , App Expr Id
ix_var Expr Id
t_int <- Expr Id
beg2
    -- Get to the !! var.
    , Var Id
ix_id    <- Expr Id
ix_var
    -- Check whether types are ok.
    , Type Type
intt <- Expr Id
t_int
    , Type -> Bool
isIntType Type
intt
    , Id -> Bool
isIndexer Id
ix_id
    -- New expression.
    = Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just (Expr Id -> Maybe (Expr Id)) -> Expr Id -> Maybe (Expr Id)
forall a b. (a -> b) -> a -> b
$ Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App (Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App (Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App Expr Id
ix_var Expr Id
t_int) Expr Id
list_expr) Expr Id
lit_expr
    | Bool
otherwise = Maybe (Expr Id)
forall a. Maybe a
Nothing


{- Note [Offset substitution]
 - ~~~~~~~~~~~~~~~~~~~~~~~~~~
 -
 - We would like for gpeekByteOff and gpokeByteOff methods to work as fast as
 - handwritten versions. This depends on whether the field's offsets are known
 - at compile time or not.
 -
 - To have offsets at compile time we have look for certain expressions to pop up.
 - We need to compile them, and later translate them back to Core expressions.
 - This approach relies on compiler optimisations of GStorable internals,
 - like inlining gpeekByteOff' methods and not inlining the calcOffsets functions.
 - If these optimisations do not happen, a compilation error might occur.
 - If not, the resulting method might be not as fast as handwritten one.
 -
 -
 - We expect to deal with the following expressions:
 -
 -
 - 1) let offsets = ... :: [Int] in expr
 -
 - Here we compile the offsets and put them for later use in expr.
 -
 -
 - 2) case $w!! @Int offsets 0# of _ I# x -> alt_expr
 - or case $w!! @Int ...     0# of _ I# x -> alt_expr
 -
 - Here we substitute the offsets if we can, and then we compile the
 - evaluated expression to later replace 'x' occurences in alt_expr.
 -
 -
 -}

-- | Substitute the offsets in a tree.
-- All top-level local ids should be alread in place.
-- Now try to compile selected expressions (See note [Offset substitution])
offsetSubstitutionTree :: [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
-- Literal. Return it.
offsetSubstitutionTree :: [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(Lit  Literal
_  )    = Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> Either Error (Expr Id)
forall a b. b -> Either a b
Right Expr Id
e
-- Do substitutions for both left and right side of an application.
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(App  Expr Id
e1  Expr Id
e2) = do
    Either Error (Expr Id)
subs1 <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
e1
    Either Error (Expr Id)
subs2 <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
e2
    Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App (Expr Id -> Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id -> Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
subs1 Either Error (Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error (Expr Id)
subs2
-- Do substitution for the expressions in Cast
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(Cast Expr Id
expr CoercionR
c) = do
    Either Error (Expr Id)
subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
expr
    Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> CoercionR -> Expr Id
forall b. Expr b -> CoercionR -> Expr b
Cast (Expr Id -> CoercionR -> Expr Id)
-> Either Error (Expr Id) -> Either Error (CoercionR -> Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
subs Either Error (CoercionR -> Expr Id)
-> Either Error CoercionR -> Either Error (Expr Id)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoercionR -> Either Error CoercionR
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoercionR
c
-- Do substitution for the expressions in Tick
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(Tick CoreTickish
t Expr Id
expr) = do
    Either Error (Expr Id)
subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
expr
    Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ CoreTickish -> Expr Id -> Expr Id
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
subs
-- Leave types alone.
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(Type Type
_  )    = Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> Either Error (Expr Id)
forall a b. b -> Either a b
Right Expr Id
e
-- And coercions too.
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(Coercion CoercionR
_)    = Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> Either Error (Expr Id)
forall a b. b -> Either a b
Right Expr Id
e
-- Do substitutions for the lambda body.
offsetSubstitutionTree [OffsetScope]
scope e :: Expr Id
e@(Lam  Id
b Expr Id
expr) = do
    Either Error (Expr Id)
subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
expr
    Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
b (Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
subs
-- Other substitutions: For Case, Let, and Var.
offsetSubstitutionTree [OffsetScope]
scope Expr Id
expr
    -- Parse let offsets = ... in ... expressions.
    -- Compile offsets and put it in scope for further substitution.
    | Let    CoreBind
offset_bind Expr Id
in_expr     <- Expr Id
expr
    , NonRec Id
offset_id   Expr Id
offset_expr <- CoreBind
offset_bind
    , Id -> Bool
isOffsetsId Id
offset_id
    = do
      Either Error OffsetScope
e_new_s <- Id -> Expr Id -> CoreM (Either Error OffsetScope)
exprToIntList Id
offset_id Expr Id
offset_expr
      case Either Error OffsetScope
e_new_s of
          Left Error
err       -> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error (Expr Id)
forall a b. a -> Either a b
Left Error
err
          Right OffsetScope
int_list -> [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree (OffsetScope
int_listOffsetScope -> [OffsetScope] -> [OffsetScope]
forall a. a -> [a] -> [a]
:[OffsetScope]
scope) Expr Id
in_expr
    -- Normal let bindings
    | Let CoreBind
bind Expr Id
in_expr <- Expr Id
expr
    = do
      Either Error (Expr Id)
subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
in_expr
      -- Substitution for the bindings
      let sub_idexpr :: (a, Expr Id) -> CoreM (Either Error (a, Expr Id))
sub_idexpr (a
id,Expr Id
e) = do
              Either Error (Expr Id)
inner_subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
e
              Either Error (a, Expr Id) -> CoreM (Either Error (a, Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (a, Expr Id) -> CoreM (Either Error (a, Expr Id)))
-> Either Error (a, Expr Id) -> CoreM (Either Error (a, Expr Id))
forall a b. (a -> b) -> a -> b
$ (,) a
id (Expr Id -> (a, Expr Id))
-> Either Error (Expr Id) -> Either Error (a, Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
inner_subs
          sub_bind :: CoreBind -> CoreM (Either Error CoreBind)
sub_bind (NonRec Id
id Expr Id
e) = do
              Either Error (Expr Id)
inner_subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
e
              Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Expr Id -> CoreBind)
-> Either Error (Expr Id) -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
inner_subs
          sub_bind (Rec [(Id, Expr Id)]
bs) = do
              [Either Error (Id, Expr Id)]
inner_subs <- ((Id, Expr Id) -> CoreM (Either Error (Id, Expr Id)))
-> [(Id, Expr Id)] -> CoreM [Either Error (Id, Expr Id)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id, Expr Id) -> CoreM (Either Error (Id, Expr Id))
forall {a}. (a, Expr Id) -> CoreM (Either Error (a, Expr Id))
sub_idexpr [(Id, Expr Id)]
bs
              case [Either Error (Id, Expr Id)] -> [Error]
forall a b. [Either a b] -> [a]
lefts [Either Error (Id, Expr Id)]
inner_subs of
                  []      -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Either Error (Id, Expr Id)] -> [(Id, Expr Id)]
forall a b. [Either a b] -> [b]
rights [Either Error (Id, Expr Id)]
inner_subs)
                  (Error
err:[Error]
_) -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let (CoreBind -> Expr Id -> Expr Id)
-> Either Error CoreBind -> Either Error (Expr Id -> Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreBind
bind_subs Either Error (Expr Id -> Expr Id)
-> Either Error (Expr Id) -> Either Error (Expr Id)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error (Expr Id)
subs
    -- Parse case expr of _ I# x# -> ... expressions.
    -- Compile case_expr and put it in scope as x#
    -- case_expr is of format $w!! @Int offsets 0#
    | Case Expr Id
case_expr Id
_ Type
_ [Alt Id
alt0] <- Expr Id
expr
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
    , (Alt (DataAlt DataCon
i_prim_con) [Id
x_id] Expr Id
alt_expr) <- Alt Id
alt0
#else
    , (DataAlt i_prim_con, [x_id], alt_expr) <- alt0
#endif
    , DataCon
i_prim_con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
intDataCon
    , Just Expr Id
new_case_expr <- [OffsetScope] -> Expr Id -> Maybe (Expr Id)
caseExprIndex [OffsetScope]
scope Expr Id
case_expr
    = do
      Either Error OffsetScope
e_new_s <- Id -> Expr Id -> CoreM (Either Error OffsetScope)
exprToIntVal Id
x_id Expr Id
new_case_expr
      case Either Error OffsetScope
e_new_s of
          Left Error
err       -> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error (Expr Id)
forall a b. a -> Either a b
Left Error
err
          Right OffsetScope
int_val  -> [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree (OffsetScope
int_valOffsetScope -> [OffsetScope] -> [OffsetScope]
forall a. a -> [a] -> [a]
:[OffsetScope]
scope) Expr Id
alt_expr

    -- Normal case expressions.
    | Case Expr Id
case_expr Id
cb Type
t [Alt Id]
alts <- Expr Id
expr
    = do
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
        let mkAlt :: AltCon -> [b] -> Expr b -> Alt b
mkAlt = AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt
#else
        let mkAlt = (,,)
#endif

        [(AltCon, [Id], Either Error (Expr Id))]
e_new_alts <- ((Alt Id -> CoreM (AltCon, [Id], Either Error (Expr Id)))
 -> [Alt Id] -> CoreM [(AltCon, [Id], Either Error (Expr Id))])
-> [Alt Id]
-> (Alt Id -> CoreM (AltCon, [Id], Either Error (Expr Id)))
-> CoreM [(AltCon, [Id], Either Error (Expr Id))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Alt Id -> CoreM (AltCon, [Id], Either Error (Expr Id)))
-> [Alt Id] -> CoreM [(AltCon, [Id], Either Error (Expr Id))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Alt Id]
alts ((Alt Id -> CoreM (AltCon, [Id], Either Error (Expr Id)))
 -> CoreM [(AltCon, [Id], Either Error (Expr Id))])
-> (Alt Id -> CoreM (AltCon, [Id], Either Error (Expr Id)))
-> CoreM [(AltCon, [Id], Either Error (Expr Id))]
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
          \(Alt AltCon
a [Id]
args Expr Id
a_expr) ->
#else
          \(a, args, a_expr) ->
#endif
            (,,) AltCon
a [Id]
args (Either Error (Expr Id) -> (AltCon, [Id], Either Error (Expr Id)))
-> CoreM (Either Error (Expr Id))
-> CoreM (AltCon, [Id], Either Error (Expr Id))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
a_expr

        Either Error (Expr Id)
new_case_expr <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [OffsetScope]
scope Expr Id
case_expr
        -- Find the first error in alternative compilation
        let c_err :: Maybe (AltCon, [Id], Either Error (Expr Id))
c_err = ((AltCon, [Id], Either Error (Expr Id)) -> Bool)
-> [(AltCon, [Id], Either Error (Expr Id))]
-> Maybe (AltCon, [Id], Either Error (Expr Id))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(AltCon
_,[Id]
_,Either Error (Expr Id)
e) -> Either Error (Expr Id) -> Bool
forall a b. Either a b -> Bool
isLeft Either Error (Expr Id)
e) [(AltCon, [Id], Either Error (Expr Id))]
e_new_alts
        case Maybe (AltCon, [Id], Either Error (Expr Id))
c_err of
            Maybe (AltCon, [Id], Either Error (Expr Id))
Nothing -> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Expr Id -> Id -> Type -> [Alt Id] -> Expr Id)
-> Either Error (Expr Id)
-> Either Error (Id -> Type -> [Alt Id] -> Expr Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error (Expr Id)
new_case_expr
                Either Error (Id -> Type -> [Alt Id] -> Expr Id)
-> Either Error Id -> Either Error (Type -> [Alt Id] -> Expr Id)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> Either Error Id
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
cb Either Error (Type -> [Alt Id] -> Expr Id)
-> Either Error Type -> Either Error ([Alt Id] -> Expr Id)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Error Type
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t Either Error ([Alt Id] -> Expr Id)
-> Either Error [Alt Id] -> Either Error (Expr Id)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Alt Id] -> Either Error [Alt Id]
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
mkAlt AltCon
a [Id]
b Expr Id
ne | (AltCon
a,[Id]
b,Right Expr Id
ne)  <- [(AltCon, [Id], Either Error (Expr Id))]
e_new_alts]
            Just (AltCon
_,[Id]
_,Either Error (Expr Id)
err) -> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error (Expr Id)
err
    -- Variable. Return it or try to replace it.
    -- Must be here, otherwise other substitutions won't happen
    -- due to replacement of offsets to lists.
    | Var Id
id <- Expr Id
expr
    = do
      let m_subs :: Maybe (Expr Id)
m_subs = [OffsetScope] -> Expr Id -> Maybe (Expr Id)
inScopeAll [OffsetScope]
scope Expr Id
expr
          new_e :: Maybe (Expr Id)
new_e = Maybe (Expr Id)
m_subs Maybe (Expr Id) -> Maybe (Expr Id) -> Maybe (Expr Id)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just Expr Id
expr
      case Maybe (Expr Id)
new_e of
          Just Expr Id
e -> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Expr Id -> Either Error (Expr Id)
forall a b. b -> Either a b
Right Expr Id
e
          Maybe (Expr Id)
Nothing -> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (Expr Id) -> CoreM (Either Error (Expr Id)))
-> Either Error (Expr Id) -> CoreM (Either Error (Expr Id))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error (Expr Id)
forall a b. a -> Either a b
Left (Error -> Either Error (Expr Id))
-> Error -> Either Error (Expr Id)
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError  (String -> SDoc
forall doc. IsLine doc => String -> doc
text  String
"This shouldn't happen."
                                      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"`m_subs <|> Just e` cannot be `Nothing`.")

-----------------
-- compilation --
-----------------


-- | Compile the expression in Core Bind and replace it.
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind CoreBind
core_bind
    -- Substitute gsizeOf
    | (NonRec Id
id Expr Id
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
    -- Substitute galignment
    | (NonRec Id
id Expr Id
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
    -- Substitute offsets in peeks.
    | (NonRec Id
id Expr Id
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
    -- Substitute offsets in pokes.
    | (NonRec Id
id Expr Id
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
    -- Everything else - nope.
    | Bool
otherwise = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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

-- | Put the expression back into the unfolding core expr.
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind b :: CoreBind
b@(NonRec Id
id Expr Id
expr)
    | NonRec Id
id Expr Id
expr <- CoreBind
b
    , Id -> Bool
isId Id
id
    , IdInfo
id_info <- (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
    , Unfolding
unfolding <- IdInfo -> Unfolding
unfoldingInfo IdInfo
id_info
    , Unfolding -> Expr Id
_ <- Unfolding -> Expr Id
uf_tmpl
    = Id -> Expr Id -> 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 -> Unfolding -> IdInfo
setUnfoldingInfo IdInfo
id_info Unfolding
unfolding{uf_tmpl = expr} ) Expr Id
expr
    | Bool
otherwise
    = CoreBind
b


-- | Lint a binding
lintBind :: CoreBind -- ^ Core binding to use when returning CompilationError
         -> CoreBind -- ^ Core binding to check
         -> CoreM (Either Error CoreBind) -- ^ Success or failure
lintBind :: CoreBind -> CoreBind -> CoreM (Either Error CoreBind)
lintBind CoreBind
b_old b :: CoreBind
b@(NonRec Id
id Expr Id
expr) = do
    DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
    let lintConfig :: LintConfig
lintConfig = DynFlags -> [Id] -> LintConfig
initLintConfig DynFlags
dyn_flags []
    case LintConfig -> Expr Id -> Maybe (Bag SDoc)
lintExpr LintConfig
lintConfig Expr Id
expr of
#else
    case lintExpr dyn_flags [] expr of
#endif
        Just Bag SDoc
sdoc -> do
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
            let err :: [SDoc]
err = Bag SDoc -> [SDoc]
forall a. Bag a -> [a]
bagToList Bag SDoc
sdoc
#else
            let err = [sdoc]
#endif
            Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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]
err
        Maybe (Bag SDoc)
Nothing ->
            Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 CoreBind
b_old b :: CoreBind
b@(Rec [(Id, Expr Id)]
bs) = do
    DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)
    let lintConfig :: LintConfig
lintConfig = DynFlags -> [Id] -> LintConfig
initLintConfig DynFlags
dyn_flags []
    let errs :: [Bag SDoc]
errs = ((Id, Expr Id) -> Maybe (Bag SDoc))
-> [(Id, Expr Id)] -> [Bag SDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Id
_,Expr Id
expr) -> LintConfig -> Expr Id -> Maybe (Bag SDoc)
lintExpr LintConfig
lintConfig Expr Id
expr) [(Id, Expr Id)]
bs
#else
    let errs = mapMaybe (\(_,expr) -> lintExpr dyn_flags [] expr) bs
#endif
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
    let convert :: [Bag a] -> [a]
convert = (Bag a -> [a]) -> [Bag a] -> [a]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Bag a -> [a]
forall a. Bag a -> [a]
bagToList
#else
    let convert = id
#endif
    case [Bag SDoc]
errs of
        [] -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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
        [Bag SDoc]
_  -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
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 ([Bag SDoc] -> [SDoc]
forall {a}. [Bag a] -> [a]
convert [Bag SDoc]
errs)

-- | Substitutes the localIds inside the bindings with bodies of provided bindings.
replaceIdsBind :: [CoreBind] -- ^ Replace with - for GStorable bindings
               -> [CoreBind] -- ^ Replace with - for other top-bindings
               -> CoreBind   -- ^ Binding which will have ids replaced.
               -> CoreBind   -- ^ Binding with replaced ids.
replaceIdsBind :: [CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind [CoreBind]
gstorable_bs [CoreBind]
other_bs (NonRec Id
id Expr Id
e) = Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e)
replaceIdsBind [CoreBind]
gstorable_bs [CoreBind]
other_bs (Rec    [(Id, Expr Id)]
recs) = [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, Expr Id)] -> CoreBind) -> [(Id, Expr Id)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ ((Id, Expr Id) -> (Id, Expr Id))
-> [(Id, Expr Id)] -> [(Id, Expr Id)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
id,Expr Id
e) -> (Id
id,[CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e)) [(Id, Expr Id)]
recs

-- | Substitutes the localIds inside the expressions with bodies of provided bindings.
replaceIds :: [CoreBind] -- ^ Replace with - for GStorable bindins
           -> [CoreBind] -- ^ Replace with - for other top-bindings
           -> CoreExpr   -- ^ Expression which will have ids replaced.
           -> CoreExpr   -- ^ Expression with replaced ids.
replaceIds :: [CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs e :: Expr Id
e@(Var Id
id)
    -- For non recs.
    | Id -> Bool
isLocalId Id
id
    , Just (Id
_,Expr Id
expr) <- ((Id, Expr Id) -> Bool) -> [(Id, Expr Id)] -> Maybe (Id, Expr Id)
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, Expr Id) -> Id) -> (Id, Expr Id) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst) ([(Id, Expr Id)] -> Maybe (Id, Expr Id))
-> [(Id, Expr Id)] -> Maybe (Id, Expr Id)
forall a b. (a -> b) -> a -> b
$ [(Id
id,Expr Id
expr) | NonRec Id
id Expr Id
expr <- [CoreBind]
gstorable_bs]
    = [CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
expr
    | Id -> Bool
isLocalId Id
id
    , Just (Id
_,Expr Id
expr) <- ((Id, Expr Id) -> Bool) -> [(Id, Expr Id)] -> Maybe (Id, Expr Id)
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, Expr Id) -> Id) -> (Id, Expr Id) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst) ([(Id, Expr Id)] -> Maybe (Id, Expr Id))
-> [(Id, Expr Id)] -> Maybe (Id, Expr Id)
forall a b. (a -> b) -> a -> b
$ [(Id
id,Expr Id
expr) | NonRec Id
id Expr Id
expr <- [CoreBind]
other_bs]
    = [CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
expr
    -- For recs. The substituted component has to be removed.
    | Id -> Bool
isLocalId Id
id
    , ([[(Id, Expr Id)]
id_here],[[(Id, Expr Id)]]
rest) <- ([(Id, Expr Id)] -> Bool)
-> [[(Id, Expr Id)]] -> ([[(Id, Expr Id)]], [[(Id, Expr Id)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(Id, Expr Id)]
x -> Id
id Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Expr Id)]
x)) ([[(Id, Expr Id)]] -> ([[(Id, Expr Id)]], [[(Id, Expr Id)]]))
-> [[(Id, Expr Id)]] -> ([[(Id, Expr Id)]], [[(Id, Expr Id)]])
forall a b. (a -> b) -> a -> b
$ [[(Id, Expr Id)]
bs | Rec [(Id, Expr Id)]
bs <- [CoreBind]
gstorable_bs]
    , Just (Id
_,Expr Id
expr) <- ((Id, Expr Id) -> Bool) -> [(Id, Expr Id)] -> Maybe (Id, Expr Id)
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, Expr Id) -> Id) -> (Id, Expr Id) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst) [(Id, Expr Id)]
id_here
    = [CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds (([(Id, Expr Id)] -> CoreBind) -> [[(Id, Expr Id)]] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [[(Id, Expr Id)]]
rest) [CoreBind]
other_bs Expr Id
expr
    | Id -> Bool
isLocalId Id
id
    , ([[(Id, Expr Id)]
id_here],[[(Id, Expr Id)]]
rest) <- ([(Id, Expr Id)] -> Bool)
-> [[(Id, Expr Id)]] -> ([[(Id, Expr Id)]], [[(Id, Expr Id)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(Id, Expr Id)]
x -> Id
id Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Expr Id)]
x)) ([[(Id, Expr Id)]] -> ([[(Id, Expr Id)]], [[(Id, Expr Id)]]))
-> [[(Id, Expr Id)]] -> ([[(Id, Expr Id)]], [[(Id, Expr Id)]])
forall a b. (a -> b) -> a -> b
$ [[(Id, Expr Id)]
bs | Rec [(Id, Expr Id)]
bs <- [CoreBind]
other_bs]
    , Just (Id
_,Expr Id
expr) <- ((Id, Expr Id) -> Bool) -> [(Id, Expr Id)] -> Maybe (Id, Expr Id)
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, Expr Id) -> Id) -> (Id, Expr Id) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst) [(Id, Expr Id)]
id_here
    = [CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs (([(Id, Expr Id)] -> CoreBind) -> [[(Id, Expr Id)]] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [[(Id, Expr Id)]]
rest) Expr Id
expr
    -- If is a global id, or id was not found (local inside the expression) - leave it alone.
    | Bool
otherwise = Expr Id
e
-- Replace on the left and right side of application.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (App Expr Id
e1 Expr Id
e2) = Expr Id -> Expr Id -> Expr Id
forall b. Expr b -> Expr b -> Expr b
App ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e1) ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e2)
-- Replace the body of lambda expressions.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Lam Id
id Expr Id
e)  = Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
id ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e)
-- Replace both bindings and the expressions.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Let  CoreBind
b Expr Id
e)  = CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let ([CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreBind
b) ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e)
-- Replace the case_expression and the altenatives.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Case Expr Id
e Id
ev Type
t [Alt Id]
alts) = do
    let new_e :: Expr Id
new_e = [CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e
#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
    let 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 [Id]
ids Expr Id
exprs) -> AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
alt [Id]
ids ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
exprs)) [Alt Id]
alts
#else
    let new_alts = map (\(alt, ids, exprs) -> (alt, ids, replaceIds gstorable_bs other_bs exprs)) alts
#endif
    Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr Id
new_e Id
ev Type
t [Alt Id]
new_alts
-- Replace the expression in Cast
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Cast Expr Id
e CoercionR
c) = Expr Id -> CoercionR -> Expr Id
forall b. Expr b -> CoercionR -> Expr b
Cast ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e) CoercionR
c
-- Replace the expression in ticks.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Tick CoreTickish
t Expr Id
e) = CoreTickish -> Expr Id -> Expr Id
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t ([CoreBind] -> [CoreBind] -> Expr Id -> Expr Id
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e)
-- For anything else - just return it.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs Expr Id
e          = Expr Id
e

-- | Compile ordered binding.
compileGroups :: Flags            -- ^ Error handling.
              -> [[CoreBind]]     -- ^ Ordered gstorable bindings.
              -> [CoreBind]       -- ^ Non-gstorable bindings, used for replacing ids.
              -> CoreM [CoreBind] -- ^ The compiled (or not) bindings.
compileGroups :: Flags -> [[CoreBind]] -> [CoreBind] -> CoreM [CoreBind]
compileGroups Flags
flags [[CoreBind]]
bind_groups [CoreBind]
bind_rest = Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags Int
0 [[CoreBind]]
bind_groups [CoreBind]
bind_rest [] []


-- | The insides of compileGroups method.
compileGroups_rec :: Flags         -- ^ For error handling.
                  -> Int           -- ^ Depth, useful for debugging.
                  -> [[CoreBind]]  -- ^ Ordered GStorable bindings.
                  -> [CoreBind]    -- ^ Other top-level bindings
                  -> [CoreBind]    -- ^ Succesfull substitutions.
                  -> [CoreBind]    -- ^ Unsuccesfull substitutions.
                  -> CoreM [CoreBind] -- ^ Both successfull and unsuccesfull subtitutions.
compileGroups_rec :: Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags Int
_ []       [CoreBind]
bind_rest [CoreBind]
subs [CoreBind]
not_subs = [CoreBind] -> CoreM [CoreBind]
forall a. a -> CoreM a
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 Int
d ([CoreBind]
bg:[[CoreBind]]
bgs) [CoreBind]
bind_rest [CoreBind]
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 then lint.
        compile_and_lint :: CoreBind -> CoreM (Either Error CoreBind)
compile_and_lint CoreBind
bind = do
            Either Error CoreBind
e_compiled <- CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind CoreBind
bind
            -- Monad transformers would be nice here.
            case Either Error CoreBind
e_compiled of
                Right CoreBind
bind' -> CoreBind -> CoreBind -> CoreM (Either Error CoreBind)
lintBind CoreBind
bind (CoreBind -> CoreBind
replaceUnfoldingBind CoreBind
bind')
                Either Error CoreBind
_           -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
e_compiled
    -- Compiled (or not) expressions
    [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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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

    -- Handle errors
    [CoreBind]
not_compiled <- Flags -> Int -> [Error] -> CoreM [CoreBind]
compileGroups_error Flags
flags Int
d [Error]
errors
    -- Next iteration.
    Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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])

-- | Handle errors during the compileGroups stage.
compileGroups_error :: Flags            -- ^ Error handling
                    -> Int              -- ^ Current iteration
                    -> [Error]          -- ^ List of errors
                    -> CoreM [CoreBind] -- ^ Bindings from errors.
compileGroups_error :: Flags -> Int -> [Error] -> CoreM [CoreBind]
compileGroups_error Flags
flags Int
d [Error]
errors = do
   let (Flags Verbosity
verb Bool
to_crash) = Flags
flags
       -- To crash handler
       crasher :: [a] -> m ()
crasher [a]
errs = case [a]
errs of
           []   -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           [a]
_    -> String -> m ()
forall a. HasCallStack => String -> a
error String
"Crashing..."
       -- Print header for this type of errors
       print_header :: SDoc -> SDoc
print_header SDoc
txt = case Verbosity
verb of
           Verbosity
None  -> SDoc
forall doc. IsOutput doc => doc
empty
           Verbosity
other ->    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Errors while compiling and substituting bindings at depth " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
d SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
":"
                    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
txt
       -- Print errors themselves
       printer :: [Error] -> CoreM ()
printer [Error]
errs = case [Error]
errs of
           [] -> () -> CoreM ()
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           -- Print with header
           [Error]
ls ->  SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
print_header ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Error -> SDoc) -> [Error] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Verbosity -> Error -> SDoc
pprError Verbosity
verb) [Error]
errs))
       -- Get the bindings from errors.
       ungroup :: Error -> Maybe CoreBind
ungroup Error
err = case Error
err of
           (CompilationNotSupported CoreBind
bind)   -> CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just CoreBind
bind
           (CompilationError        CoreBind
bind [SDoc]
_) -> CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just CoreBind
bind
           -- If we get Nothing, we will probably get missing symbols.
           -- TODO: Handle such situations.
           Error
_                               -> Maybe CoreBind
forall a. Maybe a
Nothing

   -- Print errors
   [Error] -> CoreM ()
printer [Error]
errors
   -- Crash if conditions are met
   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
   -- Return bindings
   [CoreBind] -> CoreM [CoreBind]
forall a. a -> CoreM a
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