Permalink
Browse files

Support "primitive directory" annotations

This means that primitive definitions can be bundled with libraries
and CLaSH can find them.

i.e. give a foobar.cabal file with:

> data-files: primitives/vhdl/Foo.json
>             primitives/verilog/Foo.json
>             primitives/systemverilog/Foo.json

and a Foo.hs file:

> module Foo where
>
> import qualified Paths_foobar
> import           System.FilePath
> import           System.IO.Unsafe
>
> {-# ANN module (Primitive VHDL (unsafePerformIO Paths.getDataDir </> "primitives </> "vhdl")) #-}
> {-# ANN module (Primitive Verilog (unsafePerformIO Paths.getDataDir </> "primitives </> "verilog")) #-}
> {-# ANN module (Primitive SystemVerilog (unsafePerformIO Paths.getDataDir </> "primitives </> "systemverilog")) #-}

the CLaSH compiler can figure out that the BlackBox definitions
corresponding to the primitives defined in Foo.hs can be found
in the `datadir` directories of the installed `foobar` package.
  • Loading branch information...
christiaanb committed Jan 23, 2017
1 parent 91aa301 commit 82cd31863aafcbaf3bdbf7746d89d13859af5aaf
View
@@ -37,7 +37,7 @@ doHDL :: Backend s
doHDL b src = do
startTime <- Clock.getCurrentTime
pd <- primDir b
(bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM,primMap) <- generateBindings pd src Nothing
(bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM,primMap) <- generateBindings pd (hdlKind b) src Nothing
prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime
let prepStartDiff = Clock.diffUTCTime prepTime startTime
putStrLn $ "Loading dependencies took " ++ show prepStartDiff
@@ -1750,13 +1750,15 @@ makeHDL backend optsRef srcs = do
then Just odir
else Nothing
opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)}
primDir <- CLaSH.Backend.primDir (backend iw syn)
backend' = backend iw syn
primDir <- CLaSH.Backend.primDir backend'
forM_ srcs $ \src -> do
(bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM,primMap) <- generateBindings primDir src (Just dflags)
(bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM,primMap) <-
generateBindings primDir (CLaSH.Backend.hdlKind backend') src (Just dflags)
prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime
let prepStartDiff = Clock.diffUTCTime prepTime startTime
putStrLn $ "Loading dependencies took " ++ show prepStartDiff
CLaSH.Driver.generateHDL bindingsMap (Just (backend iw syn)) primMap tcm
CLaSH.Driver.generateHDL bindingsMap (Just backend') primMap tcm
tupTcm (ghcTypeToHWType iw fp) reduceConstant topEnt testInpM expOutM opts' (startTime,prepTime)
makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()
@@ -31,6 +31,7 @@ import qualified Var as GHC
import qualified SrcLoc as GHC
import CLaSH.Annotations.TopEntity (TopEntity)
import CLaSH.Annotations.Primitive (HDL)
import CLaSH.Core.FreeVars (termFreeIds)
import CLaSH.Core.Term (Term (..), TmName)
import CLaSH.Core.Type (Type, TypeView (..), mkFunTy, splitFunForallTy, tyView)
@@ -51,16 +52,17 @@ import CLaSH.Util ((***),first)
generateBindings ::
FilePath
-> HDL
-> String
-> Maybe (GHC.DynFlags)
-> IO (BindingMap,HashMap TyConName TyCon,IntMap TyConName
,(TmName, Maybe TopEntity) -- topEntity bndr + (maybe) TopEntity annotation
,Maybe TmName -- testInput bndr
,Maybe TmName -- expectedOutput bndr
,PrimMap Text) -- The primitives found in '.' and 'primDir'
generateBindings primDir modName dflagsM = do
(bindings,clsOps,unlocatable,fiEnvs,(topEnt,topEntAnn),testInpM,expOutM) <- loadModules modName dflagsM
primMap <- generatePrimMap [primDir,"."]
generateBindings primDir hdl modName dflagsM = do
(bindings,clsOps,unlocatable,fiEnvs,(topEnt,topEntAnn),testInpM,expOutM,pFP) <- loadModules hdl modName dflagsM
primMap <- generatePrimMap (pFP ++ [primDir,"."])
let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState
(tcMap',tupTcCache) = mkTupTyCons tcMap
tcCache = makeAllTyCons tcMap' fiEnvs
@@ -17,9 +17,13 @@ where
-- External Modules
import Data.Either (partitionEithers)
import Data.List (elemIndex, partition)
import Data.Maybe (isJust, isNothing)
import Data.Maybe (isJust, isNothing, mapMaybe)
import Data.Word (Word8)
import CLaSH.Annotations.Primitive
-- GHC API
import qualified Annotations
import qualified BasicTypes
import qualified Class
import qualified CoreFVs
@@ -36,6 +40,7 @@ import qualified MkCore
import qualified MonadUtils
import qualified Name
import Outputable (showPpr, showSDoc, text)
import qualified Serialized
import qualified TcIface
import qualified TcRnMonad
import qualified TcRnTypes
@@ -44,7 +49,7 @@ import qualified Var
import qualified VarSet
-- Internal Modules
import CLaSH.Util (curLoc, traceIf)
import CLaSH.Util ((***), curLoc, traceIf)
runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a
runIfl modName action = do
@@ -77,14 +82,16 @@ loadIface foundMod = do
loadExternalExprs ::
GHC.GhcMonad m
=> [CoreSyn.CoreExpr]
=> HDL
-> [CoreSyn.CoreExpr]
-> [CoreSyn.CoreBndr]
-> m ( [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)] -- Binders
, [(CoreSyn.CoreBndr,Int)] -- Class Ops
, [CoreSyn.CoreBndr] -- Unlocatable
, [FilePath]
)
loadExternalExprs [] _ = return ([],[],[])
loadExternalExprs (expr:exprs) visited = do
loadExternalExprs _ [] _ = return ([],[],[],[])
loadExternalExprs hdl (expr:exprs) visited = do
let fvs = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars
(\v -> Var.isId v &&
isNothing (Id.isDataConId_maybe v) &&
@@ -93,17 +100,18 @@ loadExternalExprs (expr:exprs) visited = do
let (clsOps,fvs') = partition (isJust . Id.isClassOpId_maybe) fvs
(locatedExprs,unlocated) <- fmap partitionEithers
$ mapM loadExprFromIface fvs'
((locatedExprs,unlocated),pFP) <-
((partitionEithers *** concat) . unzip) <$> mapM (loadExprFromIface hdl) fvs'
let visited' = concat [ map fst locatedExprs
, unlocated
, clsOps
, visited
]
(locatedExprs', clsOps', unlocated') <-
(locatedExprs', clsOps', unlocated',pFP') <-
loadExternalExprs
hdl
(exprs ++ map snd locatedExprs)
visited'
@@ -118,32 +126,51 @@ loadExternalExprs (expr:exprs) visited = do
return ( locatedExprs ++ locatedExprs'
, clsOps'' ++ clsOps'
, unlocated ++ unlocated'
, pFP ++ pFP'
)
loadExprFromIface ::
GHC.GhcMonad m
=> CoreSyn.CoreBndr
=> HDL
-> CoreSyn.CoreBndr
-> m (Either
(CoreSyn.CoreBndr,CoreSyn.CoreExpr)
CoreSyn.CoreBndr
,[FilePath]
)
loadExprFromIface bndr = do
loadExprFromIface hdl bndr = do
let moduleM = Name.nameModule_maybe $ Var.varName bndr
case moduleM of
Just nameMod -> runIfl nameMod $ do
ifaceM <- loadIface nameMod
case ifaceM of
Nothing -> return (Right bndr)
Nothing -> return (Right bndr,[])
Just iface -> do
let decls = map snd (GHC.mi_decls iface)
let nameFun = GHC.getOccName $ Var.varName bndr
let declM = filter ((== nameFun) . IfaceSyn.ifName) decls
anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface)
let primFPs = loadPrimitiveAnnotations hdl anns
case declM of
[namedDecl] -> do
tyThing <- loadDecl namedDecl
return $ loadExprFromTyThing bndr tyThing
_ -> return (Right bndr)
Nothing -> return (Right bndr)
return (loadExprFromTyThing bndr tyThing,primFPs)
_ -> return (Right bndr,primFPs)
Nothing -> return (Right bndr,[])
loadPrimitiveAnnotations
:: HDL
-> [Annotations.Annotation]
-> [FilePath]
loadPrimitiveAnnotations hdl anns = mapMaybe toFP (concat prims)
where
annEnv = Annotations.mkAnnEnv anns
prims = UniqFM.eltsUFM (Annotations.deserializeAnns deserializer annEnv)
deserializer = Serialized.deserializeWithData :: ([Word8] -> Primitive)
toFP (Primitive hdl' fp)
| hdl == hdl'
= Just fp
toFP _ = Nothing
loadExprFromTyThing :: CoreSyn.CoreBndr
-> GHC.TyThing
@@ -25,6 +25,7 @@ where
import Data.Generics.Uniplate.DataOnly (transform)
import Data.List (foldl', nub)
import Data.Word (Word8)
import CLaSH.Annotations.Primitive (HDL)
import CLaSH.Annotations.TopEntity (TopEntity)
import System.Exit (ExitCode (..))
import System.IO (hGetLine)
@@ -87,8 +88,9 @@ getProcessOutput command =
-- return both the output and the exit code.
return (output, exitCode)
loadModules ::
String
loadModules
:: HDL
-> String
-> Maybe (DynFlags.DynFlags)
-> IO ( [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- Binders
, [(CoreSyn.CoreBndr,Int)] -- Class operations
@@ -97,8 +99,9 @@ loadModules ::
, (CoreSyn.CoreBndr, Maybe TopEntity) -- topEntity bndr + (maybe) TopEntity annotation
, Maybe CoreSyn.CoreBndr -- testInput bndr
, Maybe CoreSyn.CoreBndr -- expectedOutput bndr
, [FilePath]
)
loadModules modName dflagsM = do
loadModules hdl modName dflagsM = do
libDir <- MonadUtils.liftIO ghcLibDir
GHC.runGhc (Just libDir) $ do
@@ -194,9 +197,8 @@ loadModules modName dflagsM = do
let (binders,modFamInstEnvs) = first concat $ unzip tidiedMods
modFamInstEnvs' = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs
(externalBndrs,clsOps,unlocatable) <- loadExternalExprs
(map snd binders)
(map fst binders)
(externalBndrs,clsOps,unlocatable,pFP) <-
loadExternalExprs hdl (map snd binders) (map fst binders)
hscEnv <- GHC.getSession
famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs
@@ -234,7 +236,7 @@ loadModules modName dflagsM = do
[x] -> return (Just x)
_ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'testInput's found."
return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntity,testInput,expectedOutput)
return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntity,testInput,expectedOutput,nub pFP)
findCLaSHAnnotations :: GHC.GhcMonad m
=> [CoreSyn.CoreBndr]
@@ -16,12 +16,17 @@ import SrcLoc (SrcSpan)
import CLaSH.Netlist.Types
import CLaSH.Netlist.BlackBox.Types
import CLaSH.Annotations.Primitive (HDL)
type ModName = String
class Backend state where
-- | Initial state for state monad
initBackend :: Int -> HdlSyn -> state
-- | What HDL is the backend generating
hdlKind :: state -> HDL
-- | Location for the primitive definitions
primDir :: state -> IO FilePath
Submodule clash-prelude updated from 57ea12 to d6d829
@@ -34,6 +34,7 @@ import Prelude hiding ((<$>))
import Text.PrettyPrint.Leijen.Text.Monadic
import Text.Printf
import CLaSH.Annotations.Primitive (HDL (..))
import CLaSH.Backend
import CLaSH.Driver.Types (SrcSpan, noSrcSpan)
import CLaSH.Netlist.BlackBox.Types (HdlSyn (..))
@@ -69,6 +70,7 @@ makeLenses ''SystemVerilogState
instance Backend SystemVerilogState where
initBackend = SystemVerilogState HashSet.empty [] HashMap.empty 0 "" [] [] noSrcSpan []
hdlKind = const SystemVerilog
#ifdef CABAL
primDir = const (Paths_clash_systemverilog.getDataFileName "primitives")
#else
@@ -28,6 +28,7 @@ import Prelude hiding ((<$>))
import Text.Printf
import Text.PrettyPrint.Leijen.Text.Monadic
import CLaSH.Annotations.Primitive (HDL (..))
import CLaSH.Backend
import CLaSH.Driver.Types (SrcSpan, noSrcSpan)
import CLaSH.Netlist.BlackBox.Types (HdlSyn)
@@ -58,6 +59,7 @@ makeLenses ''VerilogState
instance Backend VerilogState where
initBackend = VerilogState 0 [] noSrcSpan []
hdlKind = const Verilog
#ifdef CABAL
primDir = const (Paths_clash_verilog.getDataFileName "primitives")
#else
@@ -33,6 +33,7 @@ import Prelude hiding ((<$>))
import Text.Printf
import Text.PrettyPrint.Leijen.Text.Monadic
import CLaSH.Annotations.Primitive (HDL (..))
import CLaSH.Backend
import CLaSH.Driver.Types (SrcSpan, noSrcSpan)
import CLaSH.Netlist.BlackBox.Types (HdlSyn (..))
@@ -67,6 +68,7 @@ makeLenses ''VHDLState
instance Backend VHDLState where
initBackend = VHDLState HashSet.empty [] HashMap.empty "" noSrcSpan [] [] []
hdlKind = const VHDL
#ifdef CABAL
primDir = const (Paths_clash_vhdl.getDataFileName "primitives")
#else

0 comments on commit 82cd318

Please sign in to comment.