{-|
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

-- 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 MkCore (mkWildValBinder)
-- Printing
import Outputable (cat, ppr, SDoc, showSDocUnsafe)
import Outputable (Outputable(..),($$), ($+$), vcat, empty,text, (<>), (<+>), nest, int, comma) 
import CoreMonad (putMsg, putMsgS)

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

-- Used to create types
import PrelNames (buildIdKey, augmentIdKey)
import DataCon (dataConWorkId)
import BasicTypes (Boxity(..))

import Unsafe.Coerce

import Data.List
import Data.Maybe
import Data.Either
import Debug.Trace
import Control.Monad.IO.Class
import Control.Monad
import Control.Applicative hiding (empty)

import Control.Exception

import Foreign.Storable.Generic.Plugin.Internal.Helpers
import Foreign.Storable.Generic.Plugin.Internal.Error
import Foreign.Storable.Generic.Plugin.Internal.Predicates
import Foreign.Storable.Generic.Plugin.Internal.Types

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

-- | Compile an expression.
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a 
compileExpr :: HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr hsc_env :: HscEnv
hsc_env expr :: CoreExpr
expr src_span :: SrcSpan
src_span = do
    ForeignHValue
foreign_hval <- IO ForeignHValue -> IO ForeignHValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ForeignHValue -> IO ForeignHValue)
-> IO ForeignHValue -> IO ForeignHValue
forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span CoreExpr
expr
    HValue
hval         <- IO HValue -> IO HValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HValue -> IO HValue) -> IO HValue -> IO HValue
forall a b. (a -> b) -> a -> b
$ ForeignHValue -> (RemoteRef HValue -> IO HValue) -> IO HValue
forall a b. ForeignRef a -> (RemoteRef a -> IO b) -> IO b
withForeignRef ForeignHValue
foreign_hval RemoteRef HValue -> IO HValue
forall a. RemoteRef a -> IO a
localRef
    let val :: a
val = HValue -> a
forall a b. a -> b
unsafeCoerce HValue
hval :: a 
    -- 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
id core_expr :: CoreExpr
core_expr  = do
    HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
    Either SomeException a
e_compiled <- IO (Either SomeException a) -> CoreM (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException a) -> CoreM (Either SomeException a))
-> IO (Either SomeException a) -> CoreM (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ 
                    HscEnv -> CoreExpr -> SrcSpan -> IO a
forall a. HscEnv -> CoreExpr -> SrcSpan -> IO a
compileExpr HscEnv
hsc_env CoreExpr
core_expr (Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
id) :: CoreM (Either SomeException a)
    case Either SomeException a
e_compiled of
        Left  se :: SomeException
se  -> Either Error a -> CoreM (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> CoreM (Either Error a))
-> Either Error a -> CoreM (Either Error a)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
core_expr) (String -> SDoc
stringToPpr (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
se)
        Right val :: a
val-> Either Error a -> CoreM (Either Error a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error a -> CoreM (Either Error a))
-> Either Error a -> CoreM (Either Error a)
forall a b. (a -> b) -> a -> b
$ a -> Either Error a
forall a b. b -> Either a b
Right a
val

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

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

-- | Create an expression of form: \x -> 16
intToExpr :: Type -> Int -> CoreExpr
intToExpr :: Type -> Int -> CoreExpr
intToExpr t :: Type
t i :: Int
i = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
wild (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
forall b. Expr b
fun CoreExpr
arg
    where fun :: Expr b
fun = Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Expr b) -> Id -> Expr b
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
intDataCon
          -- arg = Lit $ MachInt $ fromIntegral i
          arg :: CoreExpr
arg = Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
intLiteral Int
i
          wild :: Id
wild= Type -> Id
mkWildValBinder Type
t 

-- | For gsizeOf and galignment - calculate the variables.
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution b :: CoreBind
b@(Rec    _) = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
b
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
#endif
-- For GSTORABLE_SUMTYPES
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Lam l1 :: Id
l1 l :: CoreExpr
l@(Lam l2 :: Id
l2 e :: CoreExpr
e@(Lam l3 :: Id
l3 expr :: CoreExpr
expr)))) = do
    -- 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 t :: Type
t ->  Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
l1 (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
l2 (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> CoreExpr
intToExpr Type
t (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)))
        Nothing -> 
            Either Error Int -> Either Error CoreBind -> Either Error Int
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer (Either Error CoreBind -> Either Error Int)
-> (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind
-> CoreM (Either Error CoreBind)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b (String -> SDoc
text "Type not found")
-- Without GSTORABLE_SUMPTYPES
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Lam l1 :: Id
l1 expr :: 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 t :: Type
t ->  Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> CoreExpr
intToExpr Type
t (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
        Nothing -> 
            Either Error Int -> Either Error CoreBind -> Either Error Int
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer (Either Error CoreBind -> Either Error Int)
-> (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind
-> CoreM (Either Error CoreBind)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b (String -> SDoc
text "Type not found")
-- For GHC <= 8.6.5
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id e :: CoreExpr
e@(App expr :: CoreExpr
expr g :: CoreExpr
g)) = case CoreExpr
expr of
     Lam _ (Lam _ (Lam _ e :: CoreExpr
e)) -> CoreBind -> CoreM (Either Error CoreBind)
intSubstitution (CoreBind -> CoreM (Either Error CoreBind))
-> CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
expr
     App e :: CoreExpr
e t :: CoreExpr
t                 -> do 
        Either Error CoreBind
subs <- CoreBind -> CoreM (Either Error CoreBind)
intSubstitution (CoreBind -> CoreM (Either Error CoreBind))
-> CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
e
        case Either Error CoreBind
subs of
            Right (NonRec i :: Id
i (Lam l1 :: Id
l1 (Lam l2 :: Id
l2 e :: CoreExpr
e)) ) -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right (CoreBind -> Either Error CoreBind)
-> CoreBind -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
i CoreExpr
e)
            err :: Either Error CoreBind
err                                   -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
err
     _                       -> Id -> CoreExpr -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id CoreExpr
expr
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Case _ _ _ _)) = String -> CoreM (Either Error CoreBind)
forall a. HasCallStack => String -> a
error (String -> CoreM (Either Error CoreBind))
-> String -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ "am case"
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id (Let _ _)) = String -> CoreM (Either Error CoreBind)
forall a. HasCallStack => String -> a
error (String -> CoreM (Either Error CoreBind))
-> String -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ "am let"
intSubstitution b :: CoreBind
b@(NonRec id :: Id
id e :: CoreExpr
e) = String -> CoreM (Either Error CoreBind)
forall a. HasCallStack => String -> a
error (String -> CoreM (Either Error CoreBind))
-> String -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e

intSubstitutionWorker :: Id -> CoreExpr -> CoreM (Either Error CoreBind)
intSubstitutionWorker id :: Id
id expr :: CoreExpr
expr = do
    -- 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 t :: Type
t ->  Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> CoreExpr
intToExpr Type
t (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
        -- If the compilation error occured, first return it.
        Nothing -> 
            Either Error Int -> Either Error CoreBind -> Either Error Int
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer (Either Error CoreBind -> Either Error Int)
-> (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind
-> CoreM (Either Error CoreBind)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id CoreExpr
expr) (String -> SDoc
text "Type not found")
-----------------------
-- peek substitution --
-----------------------

-- | Try to substitute the offsets.
offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution b :: CoreBind
b@(Rec _) = Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
b
offsetSubstitution b :: CoreBind
b@(NonRec id :: Id
id expr :: CoreExpr
expr) = do
    Either Error CoreExpr
e_subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [] CoreExpr
expr
    let ne_subs :: Either Error CoreExpr
ne_subs = case Either Error CoreExpr
e_subs of
             -- Add the text from other error.
             Left (OtherError sdoc :: SDoc
sdoc) 
                 -> Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b SDoc
sdoc
             -- Add the information about uncompiled expr.
             Left err :: Error
err@(CompilationError _ _) 
                 -> Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b (Verbosity -> Error -> SDoc
pprError Verbosity
Some Error
err)
             a :: Either Error CoreExpr
a   -> Either Error CoreExpr
a

    Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
e_subs


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

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

instance Outputable OffsetScope where
    ppr :: OffsetScope -> SDoc
ppr (IntList    id :: Id
id expr :: CoreExpr
expr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
id) SDoc -> SDoc -> SDoc
<+> SDoc
comma SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
    ppr (IntPrimVal id :: Id
id expr :: CoreExpr
expr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
id) SDoc -> SDoc -> SDoc
<+> SDoc
comma SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr
    pprPrec :: Rational -> OffsetScope -> SDoc
pprPrec _ el :: OffsetScope
el = OffsetScope -> SDoc
forall a. Outputable a => a -> SDoc
ppr OffsetScope
el


-- | Create a list expression from Haskell list.
intListExpr :: [Int] -> CoreExpr
intListExpr :: [Int] -> CoreExpr
intListExpr list :: [Int]
list = [Int] -> CoreExpr -> CoreExpr
intListExpr' ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
list) CoreExpr
forall b. Expr b
empty_list 
    where empty_list :: Expr b
empty_list = Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App ( Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Expr b) -> Id -> Expr b
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
nilDataCon) (Type -> Expr b
forall b. Type -> Expr b
Type Type
intTy)

intListExpr' :: [Int] -> CoreExpr -> CoreExpr
intListExpr' :: [Int] -> CoreExpr -> CoreExpr
intListExpr'  []    acc :: CoreExpr
acc = CoreExpr
acc
intListExpr' (l :: Int
l:ls :: [Int]
ls) acc :: CoreExpr
acc = [Int] -> CoreExpr -> CoreExpr
intListExpr' [Int]
ls (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
int_cons CoreExpr
acc
    where int_t_cons :: Expr b
int_t_cons = Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App (Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Expr b) -> Id -> Expr b
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
consDataCon) (Type -> Expr b
forall b. Type -> Expr b
Type Type
intTy) 
          int_val :: CoreExpr
int_val    = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> Id -> CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> Id
dataConWorkId DataCon
intDataCon ) (Int -> CoreExpr
forall a. Integral a => a -> CoreExpr
intLiteral Int
l)
          int_cons :: CoreExpr
int_cons   = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
forall b. Expr b
int_t_cons CoreExpr
int_val

-- | 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
id core_expr :: CoreExpr
core_expr = do
    Either Error [Int]
int_list <- Id -> CoreExpr -> CoreM (Either Error [Int])
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
core_expr
    let new_expr :: Either Error CoreExpr
new_expr = [Int] -> CoreExpr
intListExpr ([Int] -> CoreExpr) -> Either Error [Int] -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error [Int]
int_list
    Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error OffsetScope -> CoreM (Either Error OffsetScope))
-> Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> OffsetScope
IntList Id
id (CoreExpr -> OffsetScope)
-> Either Error CoreExpr -> Either Error OffsetScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
new_expr

-- | Create a int prim expression.
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr :: Int -> CoreExpr
intPrimValExpr i :: 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
id core_expr :: CoreExpr
core_expr = do
    Either Error Int
int_val <- Id -> CoreExpr -> CoreM (Either Error Int)
forall a. Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr Id
id CoreExpr
core_expr
    let new_expr :: Either Error CoreExpr
new_expr = Int -> CoreExpr
intPrimValExpr (Int -> CoreExpr) -> Either Error Int -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
int_val
    Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error OffsetScope -> CoreM (Either Error OffsetScope))
-> Either Error OffsetScope -> CoreM (Either Error OffsetScope)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> OffsetScope
IntPrimVal Id
id (CoreExpr -> OffsetScope)
-> Either Error CoreExpr -> Either Error OffsetScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
new_expr

-- | 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 _) = 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)
    | Id -> Bool
isGlobalId Id
id
    = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e
isLitOrGlobal _ = 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 (el :: OffsetScope
el:rest :: [OffsetScope]
rest) e :: CoreExpr
e@(Var v_id :: 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 _  _ = Maybe CoreExpr
forall a. Maybe a
Nothing


-- | Is an "$w!!" identifier
isIndexer :: Id   
          -> Bool
isIndexer :: Id -> Bool
isIndexer id :: Id
id = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Id -> Name
varName Id
id) OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== NameSpace -> String -> OccName
mkOccName NameSpace
N.varName "$w!!"

-- | 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 scope :: [OffsetScope]
scope expr :: CoreExpr
expr
    -- A long list of what needs to be inside the expression. 
    | App beg :: CoreExpr
beg lit :: CoreExpr
lit <- CoreExpr
expr
    -- Substitute or leave the literal be. Otherwise cancel.
    , Just lit_expr :: CoreExpr
lit_expr <- [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
scope CoreExpr
lit Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> Maybe CoreExpr
isLitOrGlobal CoreExpr
lit
    , App beg2 :: CoreExpr
beg2 offsets :: CoreExpr
offsets <- CoreExpr
beg
    -- Substitute or leave the offsets list free.
    , Just list_expr :: CoreExpr
list_expr <- [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
scope CoreExpr
offsets Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
offsets
    , App ix_var :: CoreExpr
ix_var t_int :: CoreExpr
t_int <- CoreExpr
beg2
    -- Get to the !! var.
    , Var ix_id :: Id
ix_id    <- CoreExpr
ix_var
    -- Check whether types are ok.
    , Type intt :: 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 scope :: [OffsetScope]
scope e :: CoreExpr
e@(Lit  _  )    = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
-- Do substitutions for both left and right side of an application.
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(App  e1 :: CoreExpr
e1  e2 :: CoreExpr
e2) = do
    Either Error CoreExpr
subs1 <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e1
    Either Error CoreExpr
subs2 <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e2
    Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs1 Either Error (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error CoreExpr
subs2
-- Do substitution for the expressions in Cast
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Cast expr :: CoreExpr
expr c :: Coercion
c) = do
    Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
    Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> Coercion -> CoreExpr)
-> Either Error CoreExpr -> Either Error (Coercion -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs Either Error (Coercion -> CoreExpr)
-> Either Error Coercion -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coercion -> Either Error Coercion
forall (f :: * -> *) a. Applicative f => a -> f a
pure Coercion
c
-- Do substitution for the expressions in Tick
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Tick t :: Tickish Id
t expr :: CoreExpr
expr) = do
    Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
    Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs
-- Leave types alone.
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Type _  )    = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
-- And coercions too.
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Coercion _)    = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
-- Do substitutions for the lambda body.
offsetSubstitutionTree scope :: [OffsetScope]
scope e :: CoreExpr
e@(Lam  b :: Id
b expr :: CoreExpr
expr) = do
    Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
expr
    Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
b (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
subs
-- Other substitutions: For Case, Let, and Var.
offsetSubstitutionTree scope :: [OffsetScope]
scope expr :: CoreExpr
expr
    -- Parse let offsets = ... in ... expressions.
    -- Compile offsets and put it in scope for further substitution.
    | Let    offset_bind :: CoreBind
offset_bind in_expr :: CoreExpr
in_expr     <- CoreExpr
expr
    , NonRec offset_id :: Id
offset_id   offset_expr :: CoreExpr
offset_expr <- CoreBind
offset_bind
    , Id -> Bool
isOffsetsId Id
offset_id
    = do 
      Either Error OffsetScope
e_new_s <- Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntList Id
offset_id CoreExpr
offset_expr
      case Either Error OffsetScope
e_new_s of
          Left err :: Error
err       -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left Error
err
          Right int_list :: OffsetScope
int_list -> [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree (OffsetScope
int_listOffsetScope -> [OffsetScope] -> [OffsetScope]
forall a. a -> [a] -> [a]
:[OffsetScope]
scope) CoreExpr
in_expr
    -- Normal let bindings 
    | Let bind :: CoreBind
bind in_expr :: CoreExpr
in_expr <- CoreExpr
expr
    = do 
      Either Error CoreExpr
subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
in_expr
      -- Substitution for the bindings
      let sub_idexpr :: (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
sub_idexpr (id :: a
id,e :: CoreExpr
e) = do
              Either Error CoreExpr
inner_subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e
              Either Error (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr)))
-> Either Error (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
forall a b. (a -> b) -> a -> b
$ (,) a
id (CoreExpr -> (a, CoreExpr))
-> Either Error CoreExpr -> Either Error (a, CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
inner_subs
          sub_bind :: CoreBind -> CoreM (Either Error CoreBind)
sub_bind (NonRec id :: Id
id e :: CoreExpr
e) = do
              Either Error CoreExpr
inner_subs <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
e
              Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (CoreExpr -> CoreBind)
-> Either Error CoreExpr -> Either Error CoreBind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
inner_subs 
          sub_bind (Rec bs :: [(Id, CoreExpr)]
bs) = do
              [Either Error (Id, CoreExpr)]
inner_subs <- ((Id, CoreExpr) -> CoreM (Either Error (Id, CoreExpr)))
-> [(Id, CoreExpr)] -> CoreM [Either Error (Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, CoreExpr) -> CoreM (Either Error (Id, CoreExpr))
forall a. (a, CoreExpr) -> CoreM (Either Error (a, CoreExpr))
sub_idexpr [(Id, CoreExpr)]
bs
              case [Either Error (Id, CoreExpr)] -> [Error]
forall a b. [Either a b] -> [a]
lefts [Either Error (Id, CoreExpr)]
inner_subs of
                  []      -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right (CoreBind -> Either Error CoreBind)
-> CoreBind -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Either Error (Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. [Either a b] -> [b]
rights [Either Error (Id, CoreExpr)]
inner_subs)
                  (err :: Error
err:_) -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left Error
err
      Either Error CoreBind
bind_subs <- CoreBind -> CoreM (Either Error CoreBind)
sub_bind CoreBind
bind
      --
      Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBind -> CoreExpr -> CoreExpr)
-> Either Error CoreBind -> Either Error (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreBind
bind_subs Either Error (CoreExpr -> CoreExpr)
-> Either Error CoreExpr -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Error CoreExpr
subs
    -- 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 case_expr :: CoreExpr
case_expr _ _ [alt0 :: Alt Id
alt0] <- CoreExpr
expr
    , (DataAlt i_prim_con :: DataCon
i_prim_con, [x_id :: Id
x_id], alt_expr :: CoreExpr
alt_expr) <- Alt Id
alt0
    , DataCon
i_prim_con DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
intDataCon
    , Just new_case_expr :: CoreExpr
new_case_expr <- [OffsetScope] -> CoreExpr -> Maybe CoreExpr
caseExprIndex [OffsetScope]
scope CoreExpr
case_expr
    = do 
      Either Error OffsetScope
e_new_s <- Id -> CoreExpr -> CoreM (Either Error OffsetScope)
exprToIntVal Id
x_id CoreExpr
new_case_expr 
      case Either Error OffsetScope
e_new_s of
          Left err :: Error
err       -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left Error
err
          Right int_val :: OffsetScope
int_val  -> [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree (OffsetScope
int_valOffsetScope -> [OffsetScope] -> [OffsetScope]
forall a. a -> [a] -> [a]
:[OffsetScope]
scope) CoreExpr
alt_expr 
      
    -- Normal case expressions. 
    | Case case_expr :: CoreExpr
case_expr cb :: Id
cb t :: Type
t alts :: [Alt Id]
alts <- CoreExpr
expr
    = do
        [(AltCon, [Id], Either Error CoreExpr)]
e_new_alts <- (Alt Id -> CoreM (AltCon, [Id], Either Error CoreExpr))
-> [Alt Id] -> CoreM [(AltCon, [Id], Either Error CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(a :: AltCon
a, args :: [Id]
args, a_expr :: CoreExpr
a_expr) -> (,,) AltCon
a [Id]
args (Either Error CoreExpr -> (AltCon, [Id], Either Error CoreExpr))
-> CoreM (Either Error CoreExpr)
-> CoreM (AltCon, [Id], Either Error CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
a_expr) [Alt Id]
alts
        Either Error CoreExpr
new_case_expr <- [OffsetScope] -> CoreExpr -> CoreM (Either Error CoreExpr)
offsetSubstitutionTree [OffsetScope]
scope CoreExpr
case_expr
        -- 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 (\(_,_,e :: Either Error CoreExpr
e) -> Either Error CoreExpr -> Bool
forall a b. Either a b -> Bool
isLeft Either Error CoreExpr
e) [(AltCon, [Id], Either Error CoreExpr)]
e_new_alts
        case Maybe (AltCon, [Id], Either Error CoreExpr)
c_err of
            Nothing -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr)
-> Either Error CoreExpr
-> Either Error (Id -> Type -> [Alt Id] -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error CoreExpr
new_case_expr 
                Either Error (Id -> Type -> [Alt Id] -> CoreExpr)
-> Either Error Id -> Either Error (Type -> [Alt Id] -> CoreExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Id -> Either Error Id
forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
cb Either Error (Type -> [Alt Id] -> CoreExpr)
-> Either Error Type -> Either Error ([Alt Id] -> CoreExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Error Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t Either Error ([Alt Id] -> CoreExpr)
-> Either Error [Alt Id] -> Either Error CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Alt Id] -> Either Error [Alt Id]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(AltCon
a,[Id]
b,CoreExpr
ne) | (a :: AltCon
a,b :: [Id]
b,Right ne :: CoreExpr
ne)  <- [(AltCon, [Id], Either Error CoreExpr)]
e_new_alts]
            Just (_,_,err :: Either Error CoreExpr
err) -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreExpr
err
    -- 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
id <- CoreExpr
expr
    = do
      let m_subs :: Maybe CoreExpr
m_subs = [OffsetScope] -> CoreExpr -> Maybe CoreExpr
inScopeAll [OffsetScope]
scope CoreExpr
expr
          new_e :: Maybe CoreExpr
new_e = Maybe CoreExpr
m_subs Maybe CoreExpr -> Maybe CoreExpr -> Maybe CoreExpr
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
expr
      case Maybe CoreExpr
new_e of
          Just e :: CoreExpr
e -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> Either Error CoreExpr
forall a b. b -> Either a b
Right CoreExpr
e
          Nothing -> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError  (String -> SDoc
text  "This shouldn't happen."
                                      SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "`m_subs <|> Just e` cannot be `Nothing`.")
    | Bool
otherwise = Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreExpr -> CoreM (Either Error CoreExpr))
-> Either Error CoreExpr -> CoreM (Either Error CoreExpr)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreExpr
forall a b. a -> Either a b
Left (Error -> Either Error CoreExpr) -> Error -> Either Error CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> Error
OtherError (SDoc -> Error) -> SDoc -> Error
forall a b. (a -> b) -> a -> b
$ (String -> SDoc
text "Unsupported expression:" SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr)

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


-- | Compile the expression in Core Bind and replace it.
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind) 
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind core_bind :: CoreBind
core_bind
    -- Substitute gsizeOf
    | (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
    , Id -> Bool
isSizeOfId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecSizeOfId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoiceSizeOfId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
intSubstitution CoreBind
core_bind
    -- Substitute galignment
    | (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
    , Id -> Bool
isAlignmentId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecAlignmentId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoiceAlignmentId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
intSubstitution CoreBind
core_bind
    -- Substitute offsets in peeks.
    | (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
    , Id -> Bool
isPeekId Id
id      Bool -> Bool -> Bool
|| Id -> Bool
isSpecPeekId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoicePeekId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution CoreBind
core_bind
    -- Substitute offsets in pokes.
    | (NonRec id :: Id
id expr :: CoreExpr
expr) <- CoreBind
core_bind
    , Id -> Bool
isPokeId Id
id      Bool -> Bool -> Bool
|| Id -> Bool
isSpecPokeId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoicePokeId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution CoreBind
core_bind
    -- 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
id expr :: CoreExpr
expr)
    | NonRec id :: Id
id expr :: CoreExpr
expr <- CoreBind
b
    , Id -> Bool
isId Id
id
    , IdInfo
id_info <- HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
    , Unfolding
unfolding <- IdInfo -> Unfolding
unfoldingInfo IdInfo
id_info
    , Unfolding -> CoreExpr
_ <- Unfolding -> CoreExpr
uf_tmpl
    = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (Id -> IdInfo -> Id
setIdInfo Id
id (IdInfo -> Id) -> IdInfo -> Id
forall a b. (a -> b) -> a -> b
$ IdInfo
id_info {unfoldingInfo :: Unfolding
unfoldingInfo = Unfolding
unfolding{uf_tmpl :: CoreExpr
uf_tmpl = CoreExpr
expr} } ) CoreExpr
expr
    | Bool
otherwise 
    = CoreBind
b
    

-- | 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 b_old :: CoreBind
b_old b :: CoreBind
b@(NonRec id :: Id
id expr :: CoreExpr
expr) = do
    DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    case DynFlags -> [Id] -> CoreExpr -> Maybe SDoc
lintExpr DynFlags
dyn_flags [] CoreExpr
expr of
        Just sdoc :: SDoc
sdoc -> (Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b_old SDoc
sdoc)
        Nothing   -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right CoreBind
b
lintBind b_old :: CoreBind
b_old b :: CoreBind
b@(Rec bs :: [(Id, CoreExpr)]
bs) = do
    DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let errs :: [SDoc]
errs = ((Id, CoreExpr) -> Maybe SDoc) -> [(Id, CoreExpr)] -> [SDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(_,expr :: CoreExpr
expr) -> DynFlags -> [Id] -> CoreExpr -> Maybe SDoc
lintExpr DynFlags
dyn_flags [] CoreExpr
expr) [(Id, CoreExpr)]
bs
    case [SDoc]
errs of
        [] -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ CoreBind -> Either Error CoreBind
forall a b. b -> Either a b
Right CoreBind
b
        _  -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Error CoreBind -> CoreM (Either Error CoreBind))
-> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall a b. (a -> b) -> a -> b
$ Error -> Either Error CoreBind
forall a b. a -> Either a b
Left (Error -> Either Error CoreBind) -> Error -> Either Error CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBind -> SDoc -> Error
CompilationError CoreBind
b_old ([SDoc] -> SDoc
vcat [SDoc]
errs)

-- | 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 gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (NonRec id :: Id
id e :: CoreExpr
e) = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
replaceIdsBind gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Rec    recs :: [(Id, CoreExpr)]
recs) = [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, CoreExpr)] -> CoreBind) -> [(Id, CoreExpr)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ ((Id, CoreExpr) -> (Id, CoreExpr))
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(id :: Id
id,e :: CoreExpr
e) -> (Id
id,[CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)) [(Id, CoreExpr)]
recs

-- | 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 gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs e :: CoreExpr
e@(Var id :: Id
id)
    -- For non recs.
    | Id -> Bool
isLocalId Id
id
    , Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) ([(Id, CoreExpr)] -> Maybe (Id, CoreExpr))
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall a b. (a -> b) -> a -> b
$ [(Id
id,CoreExpr
expr) | NonRec id :: Id
id expr :: CoreExpr
expr <- [CoreBind]
gstorable_bs]
    = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
expr
    | Id -> Bool
isLocalId Id
id
    , Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) ([(Id, CoreExpr)] -> Maybe (Id, CoreExpr))
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall a b. (a -> b) -> a -> b
$ [(Id
id,CoreExpr
expr) | NonRec id :: Id
id expr :: CoreExpr
expr <- [CoreBind]
other_bs]
    = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
expr
    -- For recs. The substituted component has to be removed.
    | Id -> Bool
isLocalId Id
id
    , ([id_here :: [(Id, CoreExpr)]
id_here],rest :: [[(Id, CoreExpr)]]
rest) <- ([(Id, CoreExpr)] -> Bool)
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\x :: [(Id, CoreExpr)]
x -> Id
id Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
x)) ([[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]]))
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a b. (a -> b) -> a -> b
$ [[(Id, CoreExpr)]
bs | Rec bs :: [(Id, CoreExpr)]
bs <- [CoreBind]
gstorable_bs] 
    , Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
id_here
    = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds (([(Id, CoreExpr)] -> CoreBind) -> [[(Id, CoreExpr)]] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [[(Id, CoreExpr)]]
rest) [CoreBind]
other_bs CoreExpr
expr
    | Id -> Bool
isLocalId Id
id
    , ([id_here :: [(Id, CoreExpr)]
id_here],rest :: [[(Id, CoreExpr)]]
rest) <- ([(Id, CoreExpr)] -> Bool)
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\x :: [(Id, CoreExpr)]
x -> Id
id Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
x)) ([[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]]))
-> [[(Id, CoreExpr)]] -> ([[(Id, CoreExpr)]], [[(Id, CoreExpr)]])
forall a b. (a -> b) -> a -> b
$ [[(Id, CoreExpr)]
bs | Rec bs :: [(Id, CoreExpr)]
bs <- [CoreBind]
other_bs] 
    , Just (_,expr :: CoreExpr
expr) <- ((Id, CoreExpr) -> Bool)
-> [(Id, CoreExpr)] -> Maybe (Id, CoreExpr)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Id
idId -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==)(Id -> Bool) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
id_here
    = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs (([(Id, CoreExpr)] -> CoreBind) -> [[(Id, CoreExpr)]] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [[(Id, CoreExpr)]]
rest) CoreExpr
expr
    -- 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 gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (App e1 :: CoreExpr
e1 e2 :: CoreExpr
e2) = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e1) ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e2)
-- Replace the body of lambda expressions.
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Lam id :: Id
id e :: CoreExpr
e)  = Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
id ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
-- Replace both bindings and the expressions.
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Let  b :: CoreBind
b e :: CoreExpr
e)  = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreBind
b) ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
-- Replace the case_expression and the altenatives.
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Case e :: CoreExpr
e ev :: Id
ev t :: Type
t alts :: [Alt Id]
alts) = do
    let new_e :: CoreExpr
new_e = [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e
        new_alts :: [Alt Id]
new_alts = (Alt Id -> Alt Id) -> [Alt Id] -> [Alt Id]
forall a b. (a -> b) -> [a] -> [b]
map (\(alt :: AltCon
alt, ids :: [Id]
ids, exprs :: CoreExpr
exprs) -> (AltCon
alt,[Id]
ids, [CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
exprs)) [Alt Id]
alts
    CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
new_e Id
ev Type
t [Alt Id]
new_alts
-- Replace the expression in Cast
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Cast e :: CoreExpr
e c :: Coercion
c) = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e) Coercion
c
-- Replace the expression in ticks.
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs (Tick t :: Tickish Id
t e :: CoreExpr
e) = Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t ([CoreBind] -> [CoreBind] -> CoreExpr -> CoreExpr
replaceIds [CoreBind]
gstorable_bs [CoreBind]
other_bs CoreExpr
e)
-- For anything else - just return it.
replaceIds gstorable_bs :: [CoreBind]
gstorable_bs other_bs :: [CoreBind]
other_bs e :: 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
flags bind_groups :: [[CoreBind]]
bind_groups bind_rest :: [CoreBind]
bind_rest = Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags 0 [[CoreBind]]
bind_groups [CoreBind]
bind_rest [] []


-- | 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
flags _ []       bind_rest :: [CoreBind]
bind_rest subs :: [CoreBind]
subs not_subs :: [CoreBind]
not_subs = [CoreBind] -> CoreM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreM [CoreBind]) -> [CoreBind] -> CoreM [CoreBind]
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> [CoreBind]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreBind]
subs,[CoreBind]
not_subs]
compileGroups_rec flags :: Flags
flags d :: Int
d (bg :: [CoreBind]
bg:bgs :: [[CoreBind]]
bgs) bind_rest :: [CoreBind]
bind_rest subs :: [CoreBind]
subs not_subs :: [CoreBind]
not_subs = do
    let layer_replaced :: [CoreBind]
layer_replaced = (CoreBind -> CoreBind) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map ([CoreBind] -> [CoreBind] -> CoreBind -> CoreBind
replaceIdsBind [CoreBind]
bind_rest [CoreBind]
subs) [CoreBind]
bg
    -- Compile and then lint.
        compile_and_lint :: CoreBind -> CoreM (Either Error CoreBind)
compile_and_lint bind :: CoreBind
bind = do
            Either Error CoreBind
e_compiled <- CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind CoreBind
bind
            -- Monad transformers would be nice here.
            case Either Error CoreBind
e_compiled of
                Right bind' :: CoreBind
bind' -> CoreBind -> CoreBind -> CoreM (Either Error CoreBind)
lintBind CoreBind
bind (CoreBind -> CoreBind
replaceUnfoldingBind CoreBind
bind')
                _           -> Either Error CoreBind -> CoreM (Either Error CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
e_compiled 
    -- 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
+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
flags d :: Int
d errors :: [Error]
errors = do
   let (Flags verb :: Verbosity
verb to_crash :: Bool
to_crash) = Flags
flags
       -- To crash handler
       crasher :: [a] -> m ()
crasher errs :: [a]
errs = case [a]
errs of
           []   -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           _    -> String -> m ()
forall a. HasCallStack => String -> a
error "Crashing..."
       -- Print header for this type of errors
       print_header :: SDoc -> SDoc
print_header txt :: SDoc
txt = case Verbosity
verb of
           None  -> SDoc
empty
           other :: Verbosity
other ->    String -> SDoc
text "Errors while compiling and substituting bindings at depth " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
d SDoc -> SDoc -> SDoc
<> String -> SDoc
text ":" 
                    SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 4 SDoc
txt 
       -- Print errors themselves
       printer :: [Error] -> CoreM ()
printer errs :: [Error]
errs = case [Error]
errs of
           [] -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           -- Print with header
           ls :: [Error]
ls ->  SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
print_header ([SDoc] -> SDoc
vcat ((Error -> SDoc) -> [Error] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Verbosity -> Error -> SDoc
pprError Verbosity
verb) [Error]
errs)) 
       -- Get the bindings from errors.
       ungroup :: Error -> Maybe CoreBind
ungroup err :: Error
err = case Error
err of
           (CompilationNotSupported bind :: CoreBind
bind)   -> CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just CoreBind
bind
           (CompilationError        bind :: CoreBind
bind _) -> CoreBind -> Maybe CoreBind
forall a. a -> Maybe a
Just CoreBind
bind
           -- If we get Nothing, we will probably get missing symbols.
           -- TODO: Handle such situations.
           _                               -> 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