{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE ViewPatterns #-}

module Clash.GHC.LoadInterfaceFiles
  ( loadExternalExprs
  , unresolvedPrimitives
  )
where

-- External Modules
import           Control.Monad.IO.Class      (MonadIO (..))
import qualified Data.ByteString.Lazy.UTF8   as BLU
import qualified Data.ByteString.Lazy        as BL
import           Data.Either                 (partitionEithers)
import           Data.List                   (elemIndex, foldl', partition)
import qualified Data.Text                   as Text
import           Data.Maybe                  (isJust, isNothing,
                                              mapMaybe, catMaybes)
import           Data.Word                   (Word8)

-- GHC API
import           Annotations (Annotation(..), getAnnTargetName_maybe)
import qualified Annotations
import qualified Class
import qualified CoreFVs
import qualified CoreSyn
import qualified Demand
import           DynFlags                    (unsafeGlobalDynFlags)
import qualified GHC
import qualified Id
import qualified IdInfo
import qualified IfaceSyn
import qualified LoadIface
import qualified Maybes
import qualified MkCore
import qualified Module
import qualified MonadUtils
import qualified Name
import           Outputable                  (showPpr, showSDoc, text)
import qualified GhcPlugins                  (deserializeWithData, fromSerialized)
import qualified TcIface
import qualified TcRnMonad
import qualified TcRnTypes
import qualified UniqFM
import qualified UniqSet
import qualified Var

-- Internal Modules
import           Clash.Annotations.BitRepresentation.Internal
  (DataRepr', dataReprAnnToDataRepr')
import           Clash.Annotations.Primitive
import           Clash.Annotations.BitRepresentation (DataReprAnn)
import           Clash.Primitives.Types              (UnresolvedPrimitive, name)
import           Clash.Primitives.Util               (decodeOrErr)
import           Clash.GHC.GHC2Core                  (qualifiedNameString')
import           Clash.Util                          (curLoc, traceIf)

runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a
runIfl :: Module -> IfL a -> m a
runIfl modName :: Module
modName action :: IfL a
action = do
  HscEnv
hscEnv <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  let localEnv :: IfLclEnv
localEnv = Module
-> Bool
-> SDoc
-> Maybe NameShape
-> Maybe TypeEnv
-> FastStringEnv TyVar
-> FastStringEnv TyVar
-> IfLclEnv
TcRnTypes.IfLclEnv Module
modName Bool
False (String -> SDoc
text "runIfl") Maybe NameShape
forall a. Maybe a
Nothing
                   Maybe TypeEnv
forall a. Maybe a
Nothing FastStringEnv TyVar
forall elt. UniqFM elt
UniqFM.emptyUFM FastStringEnv TyVar
forall elt. UniqFM elt
UniqFM.emptyUFM
  let globalEnv :: IfGblEnv
globalEnv = SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
TcRnTypes.IfGblEnv (String -> SDoc
text "Clash.runIfl") Maybe (Module, IfG TypeEnv)
forall a. Maybe a
Nothing
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Char -> HscEnv -> IfGblEnv -> IfLclEnv -> IfL a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
TcRnMonad.initTcRnIf 'r' HscEnv
hscEnv IfGblEnv
globalEnv
                        IfLclEnv
localEnv IfL a
action

loadDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL GHC.TyThing
loadDecl :: IfaceDecl -> IfL TyThing
loadDecl = Bool -> IfaceDecl -> IfL TyThing
TcIface.tcIfaceDecl Bool
False

loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)
loadIface :: Module -> IfL (Maybe ModIface)
loadIface foundMod :: Module
foundMod = do
  MaybeErr SDoc (ModIface, String)
ifaceFailM <- SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf IfGblEnv IfLclEnv (MaybeErr SDoc (ModIface, String))
forall gbl lcl.
SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, String))
LoadIface.findAndReadIface (String -> SDoc
Outputable.text "loadIface")
                  ((InstalledModule, Maybe IndefModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe IndefModule)
Module.splitModuleInsts Module
foundMod)) Module
foundMod Bool
False
  case MaybeErr SDoc (ModIface, String)
ifaceFailM of
    Maybes.Succeeded (modInfo :: ModIface
modInfo,_) -> Maybe ModIface -> IfL (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
modInfo)
    Maybes.Failed msg :: SDoc
msg -> let msg' :: String
msg' = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ $(curLoc)
                                           , "Failed to load interface for module: "
                                           , DynFlags -> Module -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
unsafeGlobalDynFlags Module
foundMod
                                           , "\nReason: "
                                           , DynFlags -> SDoc -> String
showSDoc DynFlags
unsafeGlobalDynFlags SDoc
msg
                                           ]
                         in Bool -> String -> IfL (Maybe ModIface) -> IfL (Maybe ModIface)
forall a. Bool -> String -> a -> a
traceIf Bool
True String
msg' (Maybe ModIface -> IfL (Maybe ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing)

loadExternalExprs
  :: GHC.GhcMonad m
  => HDL
  -> UniqSet.UniqSet CoreSyn.CoreBndr
  -> [CoreSyn.CoreBind]
  -> m ( [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)] -- Binders
       , [(CoreSyn.CoreBndr,Int)]              -- Class Ops
       , [CoreSyn.CoreBndr]                    -- Unlocatable
       , [Either UnresolvedPrimitive FilePath]
       , [DataRepr']
       )
loadExternalExprs :: HDL
-> UniqSet TyVar
-> [CoreBind]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
loadExternalExprs hdl :: HDL
hdl = [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreBind]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *).
GhcMonad m =>
[(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreBind]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
go [] [] [] [] []
  where
    go :: [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreBind]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
go locatedExprs :: [(TyVar, CoreExpr)]
locatedExprs clsOps :: [(TyVar, Int)]
clsOps unlocated :: [TyVar]
unlocated pFP :: [Either UnresolvedPrimitive String]
pFP reprs :: [DataRepr']
reprs _ [] =
      ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
 [Either UnresolvedPrimitive String], [DataRepr'])
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVar, CoreExpr)]
locatedExprs,[(TyVar, Int)]
clsOps,[TyVar]
unlocated,[Either UnresolvedPrimitive String]
pFP,[DataRepr']
reprs)

    go locatedExprs :: [(TyVar, CoreExpr)]
locatedExprs clsOps :: [(TyVar, Int)]
clsOps unlocated :: [TyVar]
unlocated pFP :: [Either UnresolvedPrimitive String]
pFP reprs :: [DataRepr']
reprs visited :: UniqSet TyVar
visited (CoreSyn.NonRec _ e :: CoreExpr
e:bs :: [CoreBind]
bs) = do
      (locatedExprs' :: [(TyVar, CoreExpr)]
locatedExprs',clsOps' :: [(TyVar, Int)]
clsOps',unlocated' :: [TyVar]
unlocated',pFP' :: [Either UnresolvedPrimitive String]
pFP',reprs' :: [DataRepr']
reprs',visited' :: UniqSet TyVar
visited') <-
        [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreExpr]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
forall (m :: * -> *).
GhcMonad m =>
[(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreExpr]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
go' [(TyVar, CoreExpr)]
locatedExprs [(TyVar, Int)]
clsOps [TyVar]
unlocated [Either UnresolvedPrimitive String]
pFP [DataRepr']
reprs UniqSet TyVar
visited [CoreExpr
e]
      [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreBind]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
go [(TyVar, CoreExpr)]
locatedExprs' [(TyVar, Int)]
clsOps' [TyVar]
unlocated' [Either UnresolvedPrimitive String]
pFP' [DataRepr']
reprs' UniqSet TyVar
visited' [CoreBind]
bs

    go locatedExprs :: [(TyVar, CoreExpr)]
locatedExprs clsOps :: [(TyVar, Int)]
clsOps unlocated :: [TyVar]
unlocated pFP :: [Either UnresolvedPrimitive String]
pFP reprs :: [DataRepr']
reprs visited :: UniqSet TyVar
visited (CoreSyn.Rec bs :: [(TyVar, CoreExpr)]
bs:bs' :: [CoreBind]
bs') = do
      (locatedExprs' :: [(TyVar, CoreExpr)]
locatedExprs',clsOps' :: [(TyVar, Int)]
clsOps',unlocated' :: [TyVar]
unlocated',pFP' :: [Either UnresolvedPrimitive String]
pFP',reprs' :: [DataRepr']
reprs',visited' :: UniqSet TyVar
visited') <-
        [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreExpr]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
forall (m :: * -> *).
GhcMonad m =>
[(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreExpr]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
go' [(TyVar, CoreExpr)]
locatedExprs [(TyVar, Int)]
clsOps [TyVar]
unlocated [Either UnresolvedPrimitive String]
pFP [DataRepr']
reprs UniqSet TyVar
visited (((TyVar, CoreExpr) -> CoreExpr)
-> [(TyVar, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd [(TyVar, CoreExpr)]
bs)
      [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreBind]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'])
go [(TyVar, CoreExpr)]
locatedExprs' [(TyVar, Int)]
clsOps' [TyVar]
unlocated' [Either UnresolvedPrimitive String]
pFP' [DataRepr']
reprs' UniqSet TyVar
visited' [CoreBind]
bs'

    go' :: [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreExpr]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
go' locatedExprs :: [(TyVar, CoreExpr)]
locatedExprs clsOps :: [(TyVar, Int)]
clsOps unlocated :: [TyVar]
unlocated pFP :: [Either UnresolvedPrimitive String]
pFP reprs :: [DataRepr']
reprs visited :: UniqSet TyVar
visited [] =
      ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
 [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TyVar, CoreExpr)]
locatedExprs,[(TyVar, Int)]
clsOps,[TyVar]
unlocated,[Either UnresolvedPrimitive String]
pFP,[DataRepr']
reprs,UniqSet TyVar
visited)

    go' locatedExprs :: [(TyVar, CoreExpr)]
locatedExprs clsOps :: [(TyVar, Int)]
clsOps unlocated :: [TyVar]
unlocated pFP :: [Either UnresolvedPrimitive String]
pFP reprs :: [DataRepr']
reprs visited :: UniqSet TyVar
visited (e :: CoreExpr
e:es :: [CoreExpr]
es) = do
      let fvs :: [TyVar]
fvs = InterestingVarFun -> CoreExpr -> [TyVar]
CoreFVs.exprSomeFreeVarsList
                  (\v :: TyVar
v -> InterestingVarFun
Var.isId TyVar
v Bool -> Bool -> Bool
&&
                         Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isNothing (TyVar -> Maybe DataCon
Id.isDataConId_maybe TyVar
v) Bool -> Bool -> Bool
&&
                         Bool -> Bool
not (TyVar
v TyVar -> UniqSet TyVar -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`UniqSet.elementOfUniqSet` UniqSet TyVar
visited)
                  ) CoreExpr
e

          (clsOps' :: [TyVar]
clsOps',fvs' :: [TyVar]
fvs') = InterestingVarFun -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Maybe Class -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Class -> Bool)
-> (TyVar -> Maybe Class) -> InterestingVarFun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Maybe Class
Id.isClassOpId_maybe) [TyVar]
fvs

          clsOps'' :: [(TyVar, Int)]
clsOps'' = (TyVar -> (TyVar, Int)) -> [TyVar] -> [(TyVar, Int)]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \v :: TyVar
v -> ((Class -> (TyVar, Int)) -> Maybe Class -> (TyVar, Int))
-> Maybe Class -> (Class -> (TyVar, Int)) -> (TyVar, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((TyVar, Int)
-> (Class -> (TyVar, Int)) -> Maybe Class -> (TyVar, Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> (TyVar, Int)
forall a. HasCallStack => String -> a
error (String -> (TyVar, Int)) -> String -> (TyVar, Int)
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Not a class op")) (TyVar -> Maybe Class
Id.isClassOpId_maybe TyVar
v) ((Class -> (TyVar, Int)) -> (TyVar, Int))
-> (Class -> (TyVar, Int)) -> (TyVar, Int)
forall a b. (a -> b) -> a -> b
$ \c :: Class
c ->
                let clsIds :: [TyVar]
clsIds = Class -> [TyVar]
Class.classAllSelIds Class
c
                in  (TyVar, Int) -> (Int -> (TyVar, Int)) -> Maybe Int -> (TyVar, Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> (TyVar, Int)
forall a. HasCallStack => String -> a
error (String -> (TyVar, Int)) -> String -> (TyVar, Int)
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Index not found")
                          (TyVar
v,)
                          (TyVar -> [TyVar] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex TyVar
v [TyVar]
clsIds)
            ) [TyVar]
clsOps'

      (locatedAndUnlocated :: [Either (TyVar, CoreExpr) TyVar]
locatedAndUnlocated, pFP' :: [[Either UnresolvedPrimitive String]]
pFP', reprs' :: [[DataRepr']]
reprs') <- [(Either (TyVar, CoreExpr) TyVar,
  [Either UnresolvedPrimitive String], [DataRepr'])]
-> ([Either (TyVar, CoreExpr) TyVar],
    [[Either UnresolvedPrimitive String]], [[DataRepr']])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Either (TyVar, CoreExpr) TyVar,
   [Either UnresolvedPrimitive String], [DataRepr'])]
 -> ([Either (TyVar, CoreExpr) TyVar],
     [[Either UnresolvedPrimitive String]], [[DataRepr']]))
-> m [(Either (TyVar, CoreExpr) TyVar,
       [Either UnresolvedPrimitive String], [DataRepr'])]
-> m ([Either (TyVar, CoreExpr) TyVar],
      [[Either UnresolvedPrimitive String]], [[DataRepr']])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVar
 -> m (Either (TyVar, CoreExpr) TyVar,
       [Either UnresolvedPrimitive String], [DataRepr']))
-> [TyVar]
-> m [(Either (TyVar, CoreExpr) TyVar,
       [Either UnresolvedPrimitive String], [DataRepr'])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HDL
-> TyVar
-> m (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *).
GhcMonad m =>
HDL
-> TyVar
-> m (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
loadExprFromIface HDL
hdl) [TyVar]
fvs'
      let (locatedExprs' :: [(TyVar, CoreExpr)]
locatedExprs', unlocated' :: [TyVar]
unlocated') = [Either (TyVar, CoreExpr) TyVar] -> ([(TyVar, CoreExpr)], [TyVar])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (TyVar, CoreExpr) TyVar]
locatedAndUnlocated

      let visited' :: UniqSet TyVar
visited' = (UniqSet TyVar -> [TyVar] -> UniqSet TyVar)
-> UniqSet TyVar -> [[TyVar]] -> UniqSet TyVar
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqSet TyVar -> [TyVar] -> UniqSet TyVar
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
UniqSet.addListToUniqSet UniqSet TyVar
visited
                       [ ((TyVar, CoreExpr) -> TyVar) -> [(TyVar, CoreExpr)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar, CoreExpr) -> TyVar
forall a b. (a, b) -> a
fst [(TyVar, CoreExpr)]
locatedExprs'
                       , [TyVar]
unlocated'
                       , [TyVar]
clsOps'
                       ]

      [(TyVar, CoreExpr)]
-> [(TyVar, Int)]
-> [TyVar]
-> [Either UnresolvedPrimitive String]
-> [DataRepr']
-> UniqSet TyVar
-> [CoreExpr]
-> m ([(TyVar, CoreExpr)], [(TyVar, Int)], [TyVar],
      [Either UnresolvedPrimitive String], [DataRepr'], UniqSet TyVar)
go' ([(TyVar, CoreExpr)]
locatedExprs'[(TyVar, CoreExpr)] -> [(TyVar, CoreExpr)] -> [(TyVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++[(TyVar, CoreExpr)]
locatedExprs)
          ([(TyVar, Int)]
clsOps''[(TyVar, Int)] -> [(TyVar, Int)] -> [(TyVar, Int)]
forall a. [a] -> [a] -> [a]
++[(TyVar, Int)]
clsOps)
          ([TyVar]
unlocated'[TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++[TyVar]
unlocated)
          ([[Either UnresolvedPrimitive String]]
-> [Either UnresolvedPrimitive String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Either UnresolvedPrimitive String]]
pFP'[Either UnresolvedPrimitive String]
-> [Either UnresolvedPrimitive String]
-> [Either UnresolvedPrimitive String]
forall a. [a] -> [a] -> [a]
++[Either UnresolvedPrimitive String]
pFP)
          ([[DataRepr']] -> [DataRepr']
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DataRepr']]
reprs'[DataRepr'] -> [DataRepr'] -> [DataRepr']
forall a. [a] -> [a] -> [a]
++[DataRepr']
reprs)
          UniqSet TyVar
visited'
          ([CoreExpr]
es [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ ((TyVar, CoreExpr) -> CoreExpr)
-> [(TyVar, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd [(TyVar, CoreExpr)]
locatedExprs')

loadExprFromIface ::
  GHC.GhcMonad m
  => HDL
  -> CoreSyn.CoreBndr
  -> m (Either
          (CoreSyn.CoreBndr,CoreSyn.CoreExpr) -- Located
          CoreSyn.CoreBndr                    -- Unlocated
       ,[Either UnresolvedPrimitive FilePath]
       ,[DataRepr']
       )
loadExprFromIface :: HDL
-> TyVar
-> m (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
loadExprFromIface hdl :: HDL
hdl bndr :: TyVar
bndr = do
  let moduleM :: Maybe Module
moduleM = Name -> Maybe Module
Name.nameModule_maybe (Name -> Maybe Module) -> Name -> Maybe Module
forall a b. (a -> b) -> a -> b
$ TyVar -> Name
Var.varName TyVar
bndr
  case Maybe Module
moduleM of
    Just nameMod :: Module
nameMod -> Module
-> IfL
     (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
-> m (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *) a. GhcMonad m => Module -> IfL a -> m a
runIfl Module
nameMod (IfL
   (Either (TyVar, CoreExpr) TyVar,
    [Either UnresolvedPrimitive String], [DataRepr'])
 -> m (Either (TyVar, CoreExpr) TyVar,
       [Either UnresolvedPrimitive String], [DataRepr']))
-> IfL
     (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
-> m (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall a b. (a -> b) -> a -> b
$ do
      Maybe ModIface
ifaceM <- Module -> IfL (Maybe ModIface)
loadIface Module
nameMod
      case Maybe ModIface
ifaceM of
        Nothing    -> (Either (TyVar, CoreExpr) TyVar,
 [Either UnresolvedPrimitive String], [DataRepr'])
-> IfL
     (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Either (TyVar, CoreExpr) TyVar
forall a b. b -> Either a b
Right TyVar
bndr,[],[])
        Just iface :: ModIface
iface -> do
          let decls :: [IfaceDecl]
decls = ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> [(Fingerprint, IfaceDecl)] -> [IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd (ModIface -> [(Fingerprint, IfaceDecl)]
GHC.mi_decls ModIface
iface)
          let nameFun :: OccName
nameFun = Name -> OccName
forall a. NamedThing a => a -> OccName
GHC.getOccName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ TyVar -> Name
Var.varName TyVar
bndr
          let declM :: [IfaceDecl]
declM = (IfaceDecl -> Bool) -> [IfaceDecl] -> [IfaceDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter ((OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
nameFun) (OccName -> Bool) -> (IfaceDecl -> OccName) -> IfaceDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
Name.nameOccName (Name -> OccName) -> (IfaceDecl -> Name) -> IfaceDecl -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceDecl -> Name
IfaceSyn.ifName) [IfaceDecl]
decls
          [Annotation]
anns <- [IfaceAnnotation] -> IfL [Annotation]
TcIface.tcIfaceAnnotations (ModIface -> [IfaceAnnotation]
GHC.mi_anns ModIface
iface)
          [Either UnresolvedPrimitive String]
primFPs   <- HDL
-> [Annotation]
-> IOEnv
     (Env IfGblEnv IfLclEnv) [Either UnresolvedPrimitive String]
forall (m :: * -> *).
MonadIO m =>
HDL -> [Annotation] -> m [Either UnresolvedPrimitive String]
loadPrimitiveAnnotations HDL
hdl [Annotation]
anns
          let reprs :: [DataRepr']
reprs  = [Annotation] -> [DataRepr']
loadCustomReprAnnotations [Annotation]
anns
          case [IfaceDecl]
declM of
            [namedDecl :: IfaceDecl
namedDecl] -> do
              TyThing
tyThing <- IfaceDecl -> IfL TyThing
loadDecl IfaceDecl
namedDecl
              (Either (TyVar, CoreExpr) TyVar,
 [Either UnresolvedPrimitive String], [DataRepr'])
-> IfL
     (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> TyThing -> Either (TyVar, CoreExpr) TyVar
loadExprFromTyThing TyVar
bndr TyThing
tyThing,[Either UnresolvedPrimitive String]
primFPs,[DataRepr']
reprs)
            _ -> (Either (TyVar, CoreExpr) TyVar,
 [Either UnresolvedPrimitive String], [DataRepr'])
-> IfL
     (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Either (TyVar, CoreExpr) TyVar
forall a b. b -> Either a b
Right TyVar
bndr,[Either UnresolvedPrimitive String]
primFPs,[DataRepr']
reprs)
    Nothing -> (Either (TyVar, CoreExpr) TyVar,
 [Either UnresolvedPrimitive String], [DataRepr'])
-> m (Either (TyVar, CoreExpr) TyVar,
      [Either UnresolvedPrimitive String], [DataRepr'])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Either (TyVar, CoreExpr) TyVar
forall a b. b -> Either a b
Right TyVar
bndr,[],[])


loadCustomReprAnnotations
  :: [Annotations.Annotation]
  -> [DataRepr']
loadCustomReprAnnotations :: [Annotation] -> [DataRepr']
loadCustomReprAnnotations anns :: [Annotation]
anns =
  [Maybe DataRepr'] -> [DataRepr']
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DataRepr'] -> [DataRepr'])
-> [Maybe DataRepr'] -> [DataRepr']
forall a b. (a -> b) -> a -> b
$ ((Name, [DataReprAnn]) -> Maybe DataRepr')
-> [(Name, [DataReprAnn])] -> [Maybe DataRepr']
forall a b. (a -> b) -> [a] -> [b]
map (Name, [DataReprAnn]) -> Maybe DataRepr'
go ([(Name, [DataReprAnn])] -> [Maybe DataRepr'])
-> [(Name, [DataReprAnn])] -> [Maybe DataRepr']
forall a b. (a -> b) -> a -> b
$ [Maybe (Name, [DataReprAnn])] -> [(Name, [DataReprAnn])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Name, [DataReprAnn])] -> [(Name, [DataReprAnn])])
-> [Maybe (Name, [DataReprAnn])] -> [(Name, [DataReprAnn])]
forall a b. (a -> b) -> a -> b
$ (Annotation -> [DataReprAnn] -> Maybe (Name, [DataReprAnn]))
-> [Annotation] -> [[DataReprAnn]] -> [Maybe (Name, [DataReprAnn])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Annotation -> [DataReprAnn] -> Maybe (Name, [DataReprAnn])
filterNameless [Annotation]
anns [[DataReprAnn]]
reprs
    where
        env :: AnnEnv
env         = [Annotation] -> AnnEnv
Annotations.mkAnnEnv [Annotation]
anns
        deserialize :: [Word8] -> DataReprAnn
deserialize = [Word8] -> DataReprAnn
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData :: [Word8] -> DataReprAnn
        reprs :: [[DataReprAnn]]
reprs       = UniqFM [DataReprAnn] -> [[DataReprAnn]]
forall elt. UniqFM elt -> [elt]
UniqFM.eltsUFM (([Word8] -> DataReprAnn) -> AnnEnv -> UniqFM [DataReprAnn]
forall a. Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
Annotations.deserializeAnns [Word8] -> DataReprAnn
deserialize AnnEnv
env)

        filterNameless
          :: Annotation
          -> [DataReprAnn]
          -> Maybe (Name.Name, [DataReprAnn])
        filterNameless :: Annotation -> [DataReprAnn] -> Maybe (Name, [DataReprAnn])
filterNameless (Annotation ann_target :: CoreAnnTarget
ann_target _) reprs' :: [DataReprAnn]
reprs' =
          (,[DataReprAnn]
reprs') (Name -> (Name, [DataReprAnn]))
-> Maybe Name -> Maybe (Name, [DataReprAnn])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreAnnTarget -> Maybe Name
forall name. AnnTarget name -> Maybe name
getAnnTargetName_maybe CoreAnnTarget
ann_target

        go
          :: (Name.Name, [DataReprAnn])
          -> Maybe DataRepr'
        go :: (Name, [DataReprAnn]) -> Maybe DataRepr'
go (_name :: Name
_name, [])      = Maybe DataRepr'
forall a. Maybe a
Nothing
        go (_name :: Name
_name,  [repr :: DataReprAnn
repr]) = DataRepr' -> Maybe DataRepr'
forall a. a -> Maybe a
Just (DataRepr' -> Maybe DataRepr') -> DataRepr' -> Maybe DataRepr'
forall a b. (a -> b) -> a -> b
$ DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' DataReprAnn
repr
        go (name :: Name
name, reprs' :: [DataReprAnn]
reprs')   =
          String -> Maybe DataRepr'
forall a. HasCallStack => String -> a
error (String -> Maybe DataRepr') -> String -> Maybe DataRepr'
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Multiple DataReprAnn annotations for same type: \n\n"
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ (DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
Outputable.showPpr DynFlags
DynFlags.unsafeGlobalDynFlags Name
name)
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\nReprs:\n\n"
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ [DataReprAnn] -> String
forall a. Show a => a -> String
show [DataReprAnn]
reprs'

loadPrimitiveAnnotations ::
  MonadIO m
  => HDL
  -> [Annotations.Annotation]
  -> m [Either UnresolvedPrimitive FilePath]
loadPrimitiveAnnotations :: HDL -> [Annotation] -> m [Either UnresolvedPrimitive String]
loadPrimitiveAnnotations hdl :: HDL
hdl anns :: [Annotation]
anns =
  [[Either UnresolvedPrimitive String]]
-> [Either UnresolvedPrimitive String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either UnresolvedPrimitive String]]
 -> [Either UnresolvedPrimitive String])
-> m [[Either UnresolvedPrimitive String]]
-> m [Either UnresolvedPrimitive String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreAnnTarget, Primitive)
 -> m [Either UnresolvedPrimitive String])
-> [(CoreAnnTarget, Primitive)]
-> m [[Either UnresolvedPrimitive String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive String]
forall (m :: * -> *).
MonadIO m =>
HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive String]
unresolvedPrimitives HDL
hdl) [(CoreAnnTarget, Primitive)]
prims
  where
    prims :: [(CoreAnnTarget, Primitive)]
prims = (Annotation -> Maybe (CoreAnnTarget, Primitive))
-> [Annotation] -> [(CoreAnnTarget, Primitive)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Annotation -> Maybe (CoreAnnTarget, Primitive)
filterPrim [Annotation]
anns
    filterPrim :: Annotation -> Maybe (CoreAnnTarget, Primitive)
filterPrim (Annotations.Annotation target :: CoreAnnTarget
target value :: AnnPayload
value) =
      (CoreAnnTarget
target,) (Primitive -> (CoreAnnTarget, Primitive))
-> Maybe Primitive -> Maybe (CoreAnnTarget, Primitive)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnPayload -> Maybe Primitive
deserialize AnnPayload
value
    deserialize :: AnnPayload -> Maybe Primitive
deserialize =
      ([Word8] -> Primitive) -> AnnPayload -> Maybe Primitive
forall a. Typeable a => ([Word8] -> a) -> AnnPayload -> Maybe a
GhcPlugins.fromSerialized
        ([Word8] -> Primitive
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData :: [Word8] -> Primitive)

unresolvedPrimitives
  :: MonadIO m
  => HDL
  -> (Annotations.CoreAnnTarget, Primitive)
  -> m ([Either UnresolvedPrimitive FilePath])
unresolvedPrimitives :: HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive String]
unresolvedPrimitives hdl :: HDL
hdl targetPrim :: (CoreAnnTarget, Primitive)
targetPrim =
  case (CoreAnnTarget, Primitive)
targetPrim of
    (_, Primitive hdl' :: HDL
hdl' fp :: String
fp) | HDL
hdl HDL -> HDL -> Bool
forall a. Eq a => a -> a -> Bool
== HDL
hdl' -> [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String -> Either UnresolvedPrimitive String
forall a b. b -> Either a b
Right String
fp]

    (target :: CoreAnnTarget
target, InlinePrimitive hdl' :: HDL
hdl' contentOrFp :: String
contentOrFp) | HDL
hdl HDL -> HDL -> Bool
forall a. Eq a => a -> a -> Bool
== HDL
hdl' ->
      case CoreAnnTarget
target of
        -- Module annotation, can house many primitives
        Annotations.ModuleTarget _ ->
          IO [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> [Either UnresolvedPrimitive String]
forall a. (HasCallStack, FromJSON a) => String -> ByteString -> a
decodeOrErr String
contentOrFp (ByteString -> [Either UnresolvedPrimitive String])
-> IO ByteString -> IO [Either UnresolvedPrimitive String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BL.readFile String
contentOrFp)
        Annotations.NamedTarget targetName0 :: Name
targetName0 ->
          let targetName1 :: String
targetName1 = Text -> String
Text.unpack (Name -> Text
qualifiedNameString' Name
targetName0)
              prim :: UnresolvedPrimitive
prim =
                case String -> ByteString -> [UnresolvedPrimitive]
forall a. (HasCallStack, FromJSON a) => String -> ByteString -> a
decodeOrErr String
targetName1 (String -> ByteString
BLU.fromString String
contentOrFp) of
                  [] -> String -> UnresolvedPrimitive
forall a. HasCallStack => String -> a
error (String -> UnresolvedPrimitive) -> String -> UnresolvedPrimitive
forall a b. (a -> b) -> a -> b
$ "No annotations found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetName1
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ " even though it had an InlinePrimitive annotation."
                  [p :: UnresolvedPrimitive
p] -> UnresolvedPrimitive
p
                  _ -> String -> UnresolvedPrimitive
forall a. HasCallStack => String -> a
error (String -> UnresolvedPrimitive) -> String -> UnresolvedPrimitive
forall a b. (a -> b) -> a -> b
$ "Multiple primitive definitions found in "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "InlinePrimitive annotation for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetName1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Expected a single one."

              primName :: String
primName = Text -> String
Text.unpack (UnresolvedPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name UnresolvedPrimitive
prim) in

          if String
primName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
targetName1 then
            String -> m [Either UnresolvedPrimitive String]
forall a. HasCallStack => String -> a
error (String -> m [Either UnresolvedPrimitive String])
-> String -> m [Either UnresolvedPrimitive String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ "Function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetName1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ " was annotated with an inline "
              , "primitive for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
primName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ". These names "
              , "should be the same." ]
          else
            [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnresolvedPrimitive -> Either UnresolvedPrimitive String
forall a b. a -> Either a b
Left UnresolvedPrimitive
prim]
    _ ->
      -- Only consider the HDL (Verilog/SystemVerilog/VHDL) annotation we're
      -- currently targeting.
      [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

loadExprFromTyThing
  :: CoreSyn.CoreBndr
  -> GHC.TyThing
  -> Either
       (CoreSyn.CoreBndr,CoreSyn.CoreExpr)  -- Located Binder
       CoreSyn.CoreBndr                     -- unlocatable Var
loadExprFromTyThing :: TyVar -> TyThing -> Either (TyVar, CoreExpr) TyVar
loadExprFromTyThing bndr :: TyVar
bndr tyThing :: TyThing
tyThing = case TyThing
tyThing of
  GHC.AnId _id :: TyVar
_id | InterestingVarFun
Var.isId TyVar
_id ->
    let _idInfo :: IdInfo
_idInfo    = HasDebugCallStack => TyVar -> IdInfo
TyVar -> IdInfo
Var.idInfo TyVar
_id
        unfolding :: Unfolding
unfolding  = IdInfo -> Unfolding
IdInfo.unfoldingInfo IdInfo
_idInfo
    in case Unfolding
unfolding of
      CoreSyn.CoreUnfolding {} ->
        (TyVar, CoreExpr) -> Either (TyVar, CoreExpr) TyVar
forall a b. a -> Either a b
Left (TyVar
bndr, Unfolding -> CoreExpr
CoreSyn.unfoldingTemplate Unfolding
unfolding)
      (CoreSyn.DFunUnfolding dfbndrs :: [TyVar]
dfbndrs dc :: DataCon
dc es :: [CoreExpr]
es) ->
        let dcApp :: CoreExpr
dcApp  = DataCon -> [CoreExpr] -> CoreExpr
MkCore.mkCoreConApps DataCon
dc [CoreExpr]
es
            dfExpr :: CoreExpr
dfExpr = [TyVar] -> CoreExpr -> CoreExpr
MkCore.mkCoreLams [TyVar]
dfbndrs CoreExpr
dcApp
        in (TyVar, CoreExpr) -> Either (TyVar, CoreExpr) TyVar
forall a b. a -> Either a b
Left (TyVar
bndr,CoreExpr
dfExpr)
      CoreSyn.NoUnfolding
        | StrictSig -> Bool
Demand.isBottomingSig (StrictSig -> Bool) -> StrictSig -> Bool
forall a b. (a -> b) -> a -> b
$ IdInfo -> StrictSig
IdInfo.strictnessInfo IdInfo
_idInfo
        -> (TyVar, CoreExpr) -> Either (TyVar, CoreExpr) TyVar
forall a b. a -> Either a b
Left
            ( TyVar
bndr
#if MIN_VERSION_ghc(8,2,2)
            , Type -> String -> CoreExpr
MkCore.mkAbsentErrorApp
#else
            , MkCore.mkRuntimeErrorApp
                MkCore.aBSENT_ERROR_ID
#endif
                (TyVar -> Type
Var.varType TyVar
_id)
                ("no_unfolding " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> TyVar -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
unsafeGlobalDynFlags TyVar
bndr)
            )
      _ -> TyVar -> Either (TyVar, CoreExpr) TyVar
forall a b. b -> Either a b
Right TyVar
bndr
  _ -> TyVar -> Either (TyVar, CoreExpr) TyVar
forall a b. b -> Either a b
Right TyVar
bndr