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

The core of compile and substitute optimisations.

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

where

import Prelude hiding ((<>))

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



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


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

-- | Try to compile an expression. Perhaps return an error.
tryCompileExpr :: Id -> CoreExpr -> CoreM (Either Error a)
tryCompileExpr :: forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
core_expr  = do
    HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
    Either SomeException a
e_compiled <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ 
                    forall a. HscEnv -> Expr Id -> SrcSpan -> IO a
compileExpr HscEnv
hsc_env Expr Id
core_expr (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
id) :: CoreM (Either SomeException a)
    case Either SomeException a
e_compiled of
        Left  SomeException
se  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CoreBind -> [SDoc] -> Error
CompilationError (forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
core_expr) [String -> SDoc
stringToPpr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
se]
        Right a
val-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
val

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

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

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

-- | For gsizeOf and galignment - calculate the variables.
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution :: CoreBind -> CoreM (Either Error CoreBind)
intSubstitution b :: CoreBind
b@(Rec    [(Id, Expr Id)]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
b
#if MIN_VERSION_GLASGOW_HASKELL(8,8,1,0)
#endif
-- For GSTORABLE_SUMTYPES
intSubstitution b :: CoreBind
b@(NonRec Id
id (Lam Id
l1 l :: Expr Id
l@(Lam Id
l2 e :: Expr Id
e@(Lam Id
l3 Expr Id
expr)))) = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    Either Error Int
the_integer <- forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
expr :: CoreM (Either Error Int)
    let m_t :: Maybe Type
m_t      = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id) 
    case Maybe Type
m_t of
        Just Type
t ->  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. b -> Expr b -> Expr b
Lam Id
l1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall b. b -> Expr b -> Expr b
Lam Id
l2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> Expr Id
intToExpr Type
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)))
        Maybe Type
Nothing -> 
            forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left 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 Expr Id
expr)) = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    Either Error Int
the_integer <- forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
expr :: CoreM (Either Error Int)
    let m_t :: Maybe Type
m_t      = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id) 
    case Maybe Type
m_t of
        Just Type
t ->  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> Expr Id
intToExpr Type
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Int
the_integer)
        Maybe Type
Nothing -> 
            forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left 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 :: Expr Id
e@(App Expr Id
expr Expr Id
g)) = case Expr Id
expr of
     Lam Id
_ (Lam Id
_ (Lam Id
_ Expr Id
e)) -> CoreBind -> CoreM (Either Error CoreBind)
intSubstitution forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
expr
     App Expr Id
e Expr Id
t                 -> do 
        Either Error CoreBind
subs <- CoreBind -> CoreM (Either Error CoreBind)
intSubstitution forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
e
        case Either Error CoreBind
subs of
            Right (NonRec Id
i (Lam Id
l1 (Lam Id
l2 Expr Id
e)) ) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
i Expr Id
e)
            Either Error CoreBind
err                                   -> forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
err
     Expr Id
_                       -> Id -> Expr Id -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id Expr Id
expr
intSubstitution b :: CoreBind
b@(NonRec Id
id (Case Expr Id
_ Id
_ Type
_ [Alt Id]
_)) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"am case"
intSubstitution b :: CoreBind
b@(NonRec Id
id (Let CoreBind
_ Expr Id
_)) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"am let"
intSubstitution b :: CoreBind
b@(NonRec Id
id Expr Id
e) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ SDoc -> String
showSDocUnsafe forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Expr Id
e

intSubstitutionWorker :: Id -> Expr Id -> CoreM (Either Error CoreBind)
intSubstitutionWorker Id
id Expr Id
expr = do
    -- Get HscEnv
    HscEnv
hsc_env     <- CoreM HscEnv
getHscEnv
    -- Try the subtitution.
    Either Error Int
the_integer <- forall a. Id -> Expr Id -> CoreM (Either Error a)
tryCompileExpr Id
id Expr Id
expr :: CoreM (Either Error Int)
    -- Get the type.
    let m_t :: Maybe Type
m_t      = Type -> Maybe Type
getGStorableType (Id -> Type
varType Id
id) 
    case Maybe Type
m_t of
        Just Type
t ->  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Int -> Expr Id
intToExpr Type
t 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 -> 
            forall (m :: * -> *) a. Monad m => a -> m a
return Either Error Int
the_integer forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CoreBind -> [SDoc] -> Error
CompilationError (forall b. b -> Expr b -> Bind b
NonRec Id
id Expr Id
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, Expr Id)]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
b
offsetSubstitution b :: CoreBind
b@(NonRec Id
id Expr Id
expr) = do
    Either Error (Expr Id)
e_subs <- [OffsetScope] -> Expr Id -> CoreM (Either Error (Expr Id))
offsetSubstitutionTree [] Expr Id
expr
    let ne_subs :: Either Error (Expr Id)
ne_subs = case Either Error (Expr Id)
e_subs of
             -- Add the text from other error.
             Left (OtherError SDoc
sdoc) 
                 -> forall a b. a -> Either a b
Left 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]
_) 
                 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CoreBind -> [SDoc] -> Error
CompilationError CoreBind
b [Verbosity -> Error -> SDoc
pprError Verbosity
Some Error
err]
             Either Error (Expr Id)
a   -> Either Error (Expr Id)
a

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


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

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

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

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

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

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

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

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

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

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

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

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


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

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


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

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

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

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

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


-- | Compile the expression in Core Bind and replace it.
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind) 
compileGStorableBind :: CoreBind -> CoreM (Either Error CoreBind)
compileGStorableBind CoreBind
core_bind
    -- Substitute gsizeOf
    | (NonRec Id
id Expr Id
expr) <- CoreBind
core_bind
    , Id -> Bool
isSizeOfId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecSizeOfId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoiceSizeOfId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
intSubstitution CoreBind
core_bind
    -- Substitute galignment
    | (NonRec Id
id Expr Id
expr) <- CoreBind
core_bind
    , Id -> Bool
isAlignmentId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isSpecAlignmentId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoiceAlignmentId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
intSubstitution CoreBind
core_bind
    -- Substitute offsets in peeks.
    | (NonRec Id
id Expr Id
expr) <- CoreBind
core_bind
    , Id -> Bool
isPeekId Id
id      Bool -> Bool -> Bool
|| Id -> Bool
isSpecPeekId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoicePeekId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution CoreBind
core_bind
    -- Substitute offsets in pokes.
    | (NonRec Id
id Expr Id
expr) <- CoreBind
core_bind
    , Id -> Bool
isPokeId Id
id      Bool -> Bool -> Bool
|| Id -> Bool
isSpecPokeId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isChoicePokeId Id
id
    = CoreBind -> CoreM (Either Error CoreBind)
offsetSubstitution CoreBind
core_bind
    -- Everything else - nope.
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ CoreBind -> Error
CompilationNotSupported CoreBind
core_bind

-- | Put the expression back into the unfolding core expr.
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind :: CoreBind -> CoreBind
replaceUnfoldingBind b :: CoreBind
b@(NonRec Id
id Expr Id
expr)
    | NonRec Id
id Expr Id
expr <- CoreBind
b
    , Id -> Bool
isId Id
id
    , IdInfo
id_info <- HasDebugCallStack => Id -> IdInfo
idInfo Id
id
    , Unfolding
unfolding <- IdInfo -> Unfolding
unfoldingInfo IdInfo
id_info
    , Unfolding -> Expr Id
_ <- Unfolding -> Expr Id
uf_tmpl
    = forall b. b -> Expr b -> Bind b
NonRec (Id -> IdInfo -> Id
setIdInfo Id
id forall a b. (a -> b) -> a -> b
$ IdInfo -> Unfolding -> IdInfo
setUnfoldingInfo IdInfo
id_info Unfolding
unfolding{uf_tmpl :: Expr Id
uf_tmpl = Expr Id
expr} ) Expr Id
expr
    | Bool
otherwise
    = CoreBind
b
    

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

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

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

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


-- | The insides of compileGroups method.
compileGroups_rec :: Flags         -- ^ For error handling.
                  -> Int           -- ^ Depth, useful for debugging.
                  -> [[CoreBind]]  -- ^ Ordered GStorable bindings. 
                  -> [CoreBind]    -- ^ Other top-level bindings
                  -> [CoreBind]    -- ^ Succesfull substitutions.
                  -> [CoreBind]    -- ^ Unsuccesfull substitutions.
                  -> CoreM [CoreBind] -- ^ Both successfull and unsuccesfull subtitutions.
compileGroups_rec :: Flags
-> Int
-> [[CoreBind]]
-> [CoreBind]
-> [CoreBind]
-> [CoreBind]
-> CoreM [CoreBind]
compileGroups_rec Flags
flags Int
_ []       [CoreBind]
bind_rest [CoreBind]
subs [CoreBind]
not_subs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = 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
_           -> forall (m :: * -> *) a. Monad m => a -> m a
return Either Error CoreBind
e_compiled 
    -- Compiled (or not) expressions
    [Either Error CoreBind]
e_compiled <- 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 = forall a b. [Either a b] -> [a]
lefts [Either Error CoreBind]
e_compiled
        compiled :: [CoreBind]
compiled  = 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
dforall a. Num a => a -> a -> a
+Int
1) [[CoreBind]]
bgs [CoreBind]
bind_rest (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreBind]
compiled,[CoreBind]
subs]) (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
           []   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           [a]
_    -> 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
           [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           -- Print with header
           [Error]
ls ->  SDoc -> CoreM ()
putMsg forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
print_header ([SDoc] -> SDoc
vcat (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)   -> forall a. a -> Maybe a
Just CoreBind
bind
           (CompilationError        CoreBind
bind [SDoc]
_) -> forall a. a -> Maybe a
Just CoreBind
bind
           -- If we get Nothing, we will probably get missing symbols.
           -- TODO: Handle such situations.
           Error
_                               -> forall a. Maybe a
Nothing

   -- Print errors
   [Error] -> CoreM ()
printer [Error]
errors
   -- Crash if conditions are met
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
to_crash forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. Monad m => [a] -> m ()
crasher [Error]
errors
   -- Return bindings
   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Error -> Maybe CoreBind
ungroup [Error]
errors