Primitive.hs

{-|
Copyright  :  (C) 2017-2019, Myrtle Software, QBayLogic
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

Instruct the clash compiler to look for primitive HDL templates in the
indicated directory. For distribution of new packages with primitive HDL
templates.
-}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

{-# LANGUAGE Safe #-}

{-# OPTIONS_HADDOCK show-extensions #-}

module Clash.Annotations.Primitive
  ( dontTranslate
  , hasBlackBox
  , warnNonSynthesizable
  , warnAlways
  , Primitive(..)
  , PrimitiveGuard(..)
  , HDL(..)
  , extractPrim
  ) where

import           Control.DeepSeq                          (NFData)
import           Data.Binary                              (Binary)
import           Data.Data
import           Data.Hashable                            (Hashable)
import           GHC.Generics                             (Generic)


-- The commented code directly below this comment is affected by an old
-- GHC bug: https://ghc.haskell.org/trac/ghc/ticket/5463. In short, NOINLINE
-- pragmas generated by Template Haskell, get ignored. We'd still like a better
-- API than manually having to write all the guard/inline pragmas some day,
-- so I'm leaving the code in for now.

{-

guard :: TH.Exp -> TH.Name -> TH.Q [TH.Dec]
guard guardExpr fName =
  pure
    [ TH.PragmaD (TH.InlineP fName TH.NoInline TH.FunLike TH.AllPhases)
    , TH.PragmaD (TH.AnnP (TH.ValueAnnotation fName) (TH.SigE guardExpr typ))
    ]
  where
    typ = TH.AppT (TH.ConT ''PrimitiveGuard) (TH.TupleT 0)

applyUnit :: TH.Exp -> TH.Exp
applyUnit e = TH.AppE e (TH.TupE [])

-- | Mark a function as having a primitive. Clash will yield an error if it
-- needs to translate this function, but no blackbox was loaded. Usage:
--
-- @
-- $(hasBlackBox 'f)
-- @
--
-- If you don't want to use TemplateHaskell, add these annotations:
--
-- @
-- {-# NOINLINE f #-}
-- {-# ANN f (HasBlackBox ()) #-}
-- @
--
hasBlackBox :: TH.Name -> TH.Q [TH.Dec]
hasBlackBox = guard (applyUnit (TH.ConE 'HasBlackBox))

-- | Mark a function as non translatable. Clash will yield an error if
-- it needs to translate this function. Usage:
--
-- @
-- $(dontTranslate 'f)
-- @
--
-- If you don't want to use TemplateHaskell, add these annotations:
--
-- @
-- {-# NOINLINE f #-}
-- {-# ANN f DontTranslate #-}
-- @
--
dontTranslate :: TH.Name -> TH.Q [TH.Dec]
dontTranslate = guard (TH.ConE 'DontTranslate)

-- | Mark a function as non synthesizable. Clash will emit the given warning
-- if instantiated outside of a testbench context. Usage:
--
-- @
-- $(warnNonSynthesizable 'f "Tread carefully, user!")
-- @
--
-- If you don't want to use TemplateHaskell, add these annotations:
--
-- @
-- {-# NOINLINE f #-}
-- {-# ANN f (WarnNonSynthesizable "Tread carefully, user!" ()) #-}
-- @
--
warnNotSynthesizable :: TH.Name -> String -> TH.Q [TH.Dec]
warnNotSynthesizable nm warning =
  guard
    (applyUnit
      (TH.AppE
        (TH.ConE 'WarnNonSynthesizable)
        (TH.LitE (TH.StringL warning))))
    nm

-- | Emit warning when translating this value.
--
-- @
-- $(warnAlways 'f "Tread carefully, user!")
-- @
--
-- If you don't want to use TemplateHaskell, add these annotations:
--
-- @
-- {-# NOINLINE f #-}
-- {-# ANN f (WarnAlways "Tread carefully, user!" ()) #-}
-- @
--
warnAlways :: TH.Name -> String -> TH.Q [TH.Dec]
warnAlways nm warning =
  guard
    (applyUnit
      (TH.AppE
        (TH.ConE 'WarnAlways)
        (TH.LitE (TH.StringL warning))))
    nm
-}

dontTranslate :: PrimitiveGuard ()
dontTranslate = DontTranslate

hasBlackBox :: PrimitiveGuard ()
hasBlackBox = HasBlackBox ()

warnNonSynthesizable :: String -> PrimitiveGuard ()
warnNonSynthesizable s = WarnNonSynthesizable s ()

warnAlways :: String -> PrimitiveGuard ()
warnAlways s = WarnAlways s ()

data HDL
  = SystemVerilog
  | Verilog
  | VHDL
  deriving (Eq, Show, Read, Data, Generic, NFData, Hashable, Enum, Bounded)

-- | The 'Primitive' constructor instructs the clash compiler to look for primitive
-- HDL templates in the indicated directory. 'InlinePrimitive' is equivalent but
-- provides the HDL template inline. They are intended for the distribution of
-- new packages with primitive HDL templates.
--
-- === Example of 'Primitive'
--
-- You have some existing IP written in one of HDLs supported by Clash, and
-- you want to distribute some bindings so that the IP can be easily instantiated
-- from Clash.
--
-- You create a package which has a @myfancyip.cabal@ file with the following stanza:
--
-- @
-- data-files: path\/to\/MyFancyIP.json
-- cpp-options: -DCABAL
-- @
--
-- and a @MyFancyIP.hs@ module with the simulation definition and primitive.
--
-- @
-- module MyFancyIP where
--
-- import Clash.Prelude
--
-- myFancyIP :: ...
-- myFancyIP = ...
-- {\-\# NOINLINE myFancyIP \#-\}
-- @
--
-- The @NOINLINE@ pragma is needed so that GHC will never inline the definition.
--
-- Now you need to add the following imports and @ANN@ pragma:
--
-- @
-- \#ifdef CABAL
-- import           Clash.Annotations.Primitive
-- import           System.FilePath
-- import qualified Paths_myfancyip
-- import           System.IO.Unsafe
--
-- {\-\# ANN module (Primitive [VHDL] (unsafePerformIO Paths_myfancyip.getDataDir \<\/\> "path" \<\/\> "to")) \#-\}
-- \#endif
-- @
--
-- Add more files to the @data-files@ stanza in your @.cabal@ files and more
-- @ANN@ pragma's if you want to add more primitive templates for other HDLs
--
-- === Example of 'InlinePrimitive'
--
-- The following example shows off an inline HDL primitive template. It uses the
-- [interpolate](https://hackage.haskell.org/package/interpolate) package for
-- nicer multiline strings.
--
-- @
-- module InlinePrimitive where
--
-- import           Clash.Annotations.Primitive
-- import           Clash.Prelude
-- import           Data.String.Interpolate      (i)
-- import           Data.String.Interpolate.Util (unindent)
--
-- {\-\# ANN example (InlinePrimitive [VHDL] $ unindent [i|
--   [ { \"BlackBox\" :
--       { "name" : "InlinePrimitive.example"
--       , "kind": \"Declaration\"
--       , "template" :
--   "-- begin InlinePrimitive example:
--   ~GENSYM[example][0] : block
--   ~RESULT <= 1 + ~ARG[0];
--   end block;
--   -- end InlinePrimitive example"
--       }
--     }
--   ]
--   |]) \#-\}
-- {\-\# NOINLINE example \#-\}
-- example :: Signal System (BitVector 2) -> Signal System (BitVector 2)
-- example = fmap succ
-- @
data Primitive
  = Primitive [HDL] FilePath
  -- ^ Description of a primitive for a given 'HDL's in a file at 'FilePath'
  | InlinePrimitive [HDL] String
  -- ^ Description of a primitive for a given 'HDL's as an inline 'String'
  deriving (Show, Read, Data, Generic, NFData, Hashable)

-- | Guard primitive functions. This will help Clash generate better error
-- messages. You can annotate a function like:
--
-- @
-- {\-\# ANN f dontTranslate \#-\}
-- @
--
-- or
--
-- @
-- {\-\# ANN f hasBlackBox \#-\}
-- @
--
-- or
--
-- @
-- {\-\# ANN f (warnNonSynthesizable "Tread carefully, user!") \#-\}
-- @
--
-- or
--
-- @
-- {\-\# ANN f (warnAlways "Tread carefully, user!") \#-\}
-- @
data PrimitiveGuard a
  = DontTranslate
  -- ^ Marks value as not translatable. Clash will error if it finds a blackbox
  -- definition for it, or when it is forced to translate it.
  | HasBlackBox a
  -- ^ Marks a value as having a blackbox. Clash will err if it hasn't found
  -- a blackbox
  | WarnNonSynthesizable String a
  -- ^ Marks value as non-synthesizable. This will trigger a warning if
  -- instantiated in a non-testbench context. Implies @HasBlackBox@.
  | WarnAlways String a
  -- ^ Always emit warning upon instantiation. Implies @HasBlackBox@.
    deriving (Show, Read, Data, Generic, NFData, Hashable, Functor, Foldable, Traversable, Binary)

-- | Extract primitive definition from a PrimitiveGuard. Will yield Nothing
-- for guards of value 'DontTranslate'.
extractPrim
  :: PrimitiveGuard a
  -> Maybe a
extractPrim =
  \case
    HasBlackBox a            -> Just a
    WarnNonSynthesizable _ a -> Just a
    WarnAlways _ a           -> Just a
    DontTranslate            -> Nothing