{-|
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(..))
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)
import GHC.Driver.Types (HscEnv,ModGuts(..))
import GHC.Core.Opt.Monad (CoreM,CoreToDo(..),getHscEnv,getDynFlags)
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(..))
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,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

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

-- | Compile an expression.
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a 
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr HscEnv
hsc_env CoreExpr
expr 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 
    -- finalizeForeignRef foreign_hval  -- check whether that's the source of the error
    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 :: Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id 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  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 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

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

-- | A small helper - create an integer literal.
intLiteral :: (Integral a) => a -> CoreExpr
#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
intLiteral i =  Lit $ LitNumber LitNumInt (fromIntegral i)
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
intLiteral :: a -> CoreExpr
intLiteral 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

-- | Create an expression of form: \x -> 16
intToExpr :: Type -> Int -> CoreExpr
intToExpr :: Type -> Int -> CoreExpr
intToExpr Type
t 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 = Lit $ MachInt $ fromIntegral i
          arg :: CoreExpr
arg = Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
intLiteral Int
i
#if MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
          wild= mkWildValBinder Many t 
#else
          wild :: Id
wild= Type -> Id
mkWildValBinder Type
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, CoreExpr)]
_) = 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
-- For GSTORABLE_SUMTYPES
intSubstitution b :: CoreBind
b@(NonRec Id
id (Lam Id
l1 l :: CoreExpr
l@(Lam Id
l2 e :: CoreExpr
e@(Lam Id
l3 CoreExpr
expr)))) = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    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 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)))
        Maybe Type
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 String
"Type not found")
-- Without GSTORABLE_SUMPTYPES
intSubstitution b :: CoreBind
b@(NonRec Id
id (Lam Id
l1 CoreExpr
expr)) = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    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 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)
        Maybe Type
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 String
"Type not found")
-- For GHC <= 8.6.5
intSubstitution b :: CoreBind
b@(NonRec Id
id e :: CoreExpr
e@(App CoreExpr
expr CoreExpr
g)) = case CoreExpr
expr of
     Lam Id
_ (Lam Id
_ (Lam Id
_ 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 CoreExpr
e 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 Id
i (Lam Id
l1 (Lam Id
l2 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)
            Either Error CoreBind
err                                   -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
err
     CoreExpr
_                       -> Id -> CoreExpr -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id CoreExpr
expr
intSubstitution b :: CoreBind
b@(NonRec Id
id (Case CoreExpr
_ 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
_ CoreExpr
_)) = 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 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 CoreExpr
expr = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    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)
    -- 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 (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)
        -- If the compilation error occured, first return it.
        Maybe Type
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 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, CoreExpr)]
_) = 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 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
             -- Add the text from other error.
             Left (OtherError 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
             -- Add the information about uncompiled expr.
             Left err :: Error
err@(CompilationError CoreBind
_ 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 (Verbosity -> Error -> SDoc
pprError Verbosity
Some Error
err)
             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


-- | 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 CoreExpr
_) = Id
id
getScopeId (IntPrimVal   Id
id CoreExpr
_) = Id
id

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

instance Outputable OffsetScope where
    ppr :: OffsetScope -> SDoc
ppr (IntList    Id
id 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 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 Rational
_ OffsetScope
el = OffsetScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr OffsetScope
el


-- | Create a list expression from Haskell list.
intListExpr :: [Int] -> CoreExpr
intListExpr :: [Int] -> CoreExpr
intListExpr [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'  []    CoreExpr
acc = CoreExpr
acc
intListExpr' (Int
l:[Int]
ls) 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

-- | Compile expression to list and then write it back to core expr.
exprToIntList :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList :: Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList Id
id 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

-- | Create a int prim expression.
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr Int
i = Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
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 -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntVal Id
id 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

-- | Return the expression if it's a literal or global.
isLitOrGlobal :: CoreExpr -> Maybe CoreExpr
-- Whether it is a literal.
isLitOrGlobal :: CoreExpr -> Maybe CoreExpr
isLitOrGlobal e :: CoreExpr
e@(Lit Literal
_) = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
-- Whether it is a global id:
isLitOrGlobal e :: CoreExpr
e@(Var Id
id)
    | Id -> Bool
isGlobalId Id
id
    = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
isLitOrGlobal CoreExpr
_ = Maybe CoreExpr
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] -> CoreExpr -> Maybe CoreExpr
inScopeAll (OffsetScope
el:[OffsetScope]
rest) e :: CoreExpr
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)
    = 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 [OffsetScope]
_  CoreExpr
_ = Maybe CoreExpr
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] -> CoreExpr -> Maybe CoreExpr
caseExprIndex [OffsetScope]
scope CoreExpr
expr
    -- A long list of what needs to be inside the expression. 
    | App CoreExpr
beg CoreExpr
lit <- CoreExpr
expr
    -- Substitute or leave the literal be. Otherwise cancel.
    , Just 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 CoreExpr
beg2 CoreExpr
offsets <- CoreExpr
beg
    -- Substitute or leave the offsets list free.
    , Just 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 CoreExpr
ix_var CoreExpr
t_int <- CoreExpr
beg2
    -- Get to the !! var.
    , Var Id
ix_id    <- CoreExpr
ix_var
    -- Check whether types are ok.
    , Type Type
intt <- CoreExpr
t_int
    , Type -> Bool
isIntType Type
intt
    , Id -> Bool
isIndexer Id
ix_id
    -- New expression.
    = 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


{- 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] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(Lit  Literal
_  )    = 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
-- Do substitutions for both left and right side of an application.
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(App  CoreExpr
e1  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
-- Do substitution for the expressions in Cast
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(Cast CoreExpr
expr 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
-- Do substitution for the expressions in Tick
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(Tick Tickish Id
t 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
-- Leave types alone.
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(Type 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
-- And coercions too.
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(Coercion 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
-- Do substitutions for the lambda body.
offsetSubstitutionTree [OffsetScope]
scope e :: CoreExpr
e@(Lam  Id
b 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
-- Other substitutions: For Case, Let, and Var.
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
    -- Parse let offsets = ... in ... expressions.
    -- Compile offsets and put it in scope for further substitution.
    | Let    CoreBind
offset_bind CoreExpr
in_expr     <- CoreExpr
expr
    , NonRec Id
offset_id   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 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 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
    -- Normal let bindings 
    | Let CoreBind
bind CoreExpr
in_expr <- CoreExpr
expr
    = do 
      Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
in_expr
      -- Substitution for the bindings
      let sub_idexpr :: (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
sub_idexpr (a
id,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 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 [(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)
                  (Error
err:[Error]
_) -> 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
    -- 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 CoreExpr
case_expr Id
_ Type
_ [Alt Id
alt0] <- CoreExpr
expr
    , (DataAlt DataCon
i_prim_con, [Id
x_id], CoreExpr
alt_expr) <- Alt Id
alt0
    , DataCon
i_prim_con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
intDataCon
    , Just 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 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 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 
      
    -- Normal case expressions. 
    | Case CoreExpr
case_expr Id
cb Type
t [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 (\(AltCon
a, [Id]
args, 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
        -- Find the first error in alternative compilation
        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 (\(AltCon
_,[Id]
_,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
            Maybe (AltCon, [Id], Either Error CoreExpr)
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) | (AltCon
a,[Id]
b,Right CoreExpr
ne)  <- [(AltCon, [Id], Either Error CoreExpr)]
e_new_alts]
            Just (AltCon
_,[Id]
_,Either Error CoreExpr
err) -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreExpr
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 <- 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 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
          Maybe CoreExpr
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  String
"This shouldn't happen."
                                      SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"`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 String
"Unsupported expression:" SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)

-----------------
-- 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 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
    -- Substitute galignment
    | (NonRec Id
id 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
    -- Substitute offsets in peeks.
    | (NonRec Id
id 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
    -- Substitute offsets in pokes.
    | (NonRec Id
id 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
    -- Everything else - nope.
    | 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

-- | Put the expression back into the unfolding core expr.
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind b :: CoreBind
b@(NonRec Id
id CoreExpr
expr)
    | NonRec Id
id 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
    

-- | 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 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 -> (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)
        Maybe 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 CoreBind
b_old b :: CoreBind
b@(Rec [(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 (\(Id
_,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
        [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
vcat [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 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 [CoreBind]
gstorable_bs [CoreBind]
other_bs (Rec    [(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,CoreExpr
e) -> (Id
id,[CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)) [(Id, CoreExpr)]
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] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs e :: CoreExpr
e@(Var Id
id)
    -- For non recs.
    | Id -> Bool
isLocalId Id
id
    , Just (Id
_,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 CoreExpr
expr <- [CoreBind]
gstorable_bs]
    = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
expr
    | Id -> Bool
isLocalId Id
id
    , Just (Id
_,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 CoreExpr
expr <- [CoreBind]
other_bs]
    = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
expr
    -- For recs. The substituted component has to be removed.
    | Id -> Bool
isLocalId Id
id
    , ([[(Id, CoreExpr)]
id_here],[[(Id, CoreExpr)]]
rest) <- ([(Id, CoreExpr)] -> Bool)
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(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 [(Id, CoreExpr)]
bs <- [CoreBind]
gstorable_bs] 
    , Just (Id
_,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, CoreExpr)]
id_here],[[(Id, CoreExpr)]]
rest) <- ([(Id, CoreExpr)] -> Bool)
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(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 [(Id, CoreExpr)]
bs <- [CoreBind]
other_bs] 
    , Just (Id
_,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
    -- If is a global id, or id was not found (local inside the expression) - leave it alone.
    | Bool
otherwise = CoreExpr
e
-- Replace on the left and right side of application.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (App CoreExpr
e1 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)
-- Replace the body of lambda expressions.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Lam Id
id 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)
-- Replace both bindings and the expressions.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Let  CoreBind
b 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)
-- Replace the case_expression and the altenatives.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Case CoreExpr
e Id
ev Type
t [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 (\(AltCon
alt, [Id]
ids, 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
-- Replace the expression in Cast
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Cast CoreExpr
e 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
-- Replace the expression in ticks.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs (Tick Tickish Id
t 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)
-- For anything else - just return it.
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e          = CoreExpr
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 (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 (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)
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 (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
empty
           Verbosity
other ->    String -> SDoc
text String
"Errors while compiling and substituting bindings at depth " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
d SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
":" 
                    SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 SDoc
txt 
       -- Print errors themselves
       printer :: [Error] -> CoreM ()
printer [Error]
errs = case [Error]
errs of
           [] -> () -> CoreM ()
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
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 (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