--- /dev/null
+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, FlexibleContexts, TypeFamilies, TypeOperators #-}
+
+module CLasH.HardwareTypes
+ ( module Types
+ , module Data.Param.Vector
+ , module Data.Param.Index
+ , module Data.Param.Signed
+ , module Data.Param.Unsigned
+ , module Prelude
+ , Bit(..)
+ , State(..)
+ , resizeInt
+ , resizeWord
+ , hwand
+ , hwor
+ , hwxor
+ , hwnot
+ , RAM
+ , MemState
+ , blockRAM
+ ) where
+
+import qualified Prelude as P
+import Prelude hiding (
+ null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
+ zipWith, zip, unzip, concat, reverse, iterate )
+import Types
+import Data.Param.Vector
+import Data.Param.Index
+import qualified Data.Param.Signed as Signed
+import Data.Param.Signed hiding (resize)
+import qualified Data.Param.Unsigned as Unsigned
+import Data.Param.Unsigned hiding (resize)
+
+import Language.Haskell.TH.Lift
+import Data.Typeable
+
+newtype State s = State s deriving (P.Show)
+
+resizeInt :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'
+resizeInt = Signed.resize
+
+resizeWord :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'
+resizeWord = Unsigned.resize
+
+-- The plain Bit type
+data Bit = High | Low
+ deriving (P.Show, P.Eq, P.Read, Typeable)
+
+deriveLift ''Bit
+
+hwand :: Bit -> Bit -> Bit
+hwor :: Bit -> Bit -> Bit
+hwxor :: Bit -> Bit -> Bit
+hwnot :: Bit -> Bit
+
+High `hwand` High = High
+_ `hwand` _ = Low
+
+High `hwor` _ = High
+_ `hwor` High = High
+Low `hwor` Low = Low
+
+High `hwxor` Low = High
+Low `hwxor` High = High
+_ `hwxor` _ = Low
+
+hwnot High = Low
+hwnot Low = High
+
+type RAM s a = Vector (s :+: D1) a
+
+type MemState s a = State (RAM s a)
+
+blockRAM ::
+ (NaturalT s
+ ,PositiveT (s :+: D1)
+ ,((s :+: D1) :>: s) ~ True ) =>
+ (MemState s a) ->
+ a ->
+ Index s ->
+ Index s ->
+ Bool ->
+ ((MemState s a), a )
+blockRAM (State mem) data_in rdaddr wraddr wrenable =
+ ((State mem'), data_out)
+ where
+ data_out = mem!rdaddr
+ -- Only write data_in to memory if write is enabled
+ mem' = if wrenable then
+ replace mem wraddr data_in
+ else
+ mem
--- /dev/null
+--
+-- Functions to bring a Core expression in normal form. This module provides a
+-- top level function "normalize", and defines the actual transformation passes that
+-- are performed.
+--
+module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where
+
+-- Standard modules
+import Debug.Trace
+import qualified Maybe
+import qualified List
+import qualified Control.Monad.Trans.Class as Trans
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+import qualified Data.Monoid as Monoid
+import qualified Data.Map as Map
+
+-- GHC API
+import CoreSyn
+import qualified CoreUtils
+import qualified BasicTypes
+import qualified Type
+import qualified TysWiredIn
+import qualified Id
+import qualified Var
+import qualified Name
+import qualified DataCon
+import qualified VarSet
+import qualified CoreFVs
+import qualified Class
+import qualified MkCore
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import CLasH.Normalize.NormalizeTypes
+import CLasH.Translator.TranslatorTypes
+import CLasH.Normalize.NormalizeTools
+import CLasH.VHDL.Constants (builtinIds)
+import qualified CLasH.Utils as Utils
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.Core.BinderTools
+import CLasH.Utils.Pretty
+
+----------------------------------------------------------------
+-- Cleanup transformations
+----------------------------------------------------------------
+
+--------------------------------
+-- β-reduction
+--------------------------------
+beta :: Transform
+-- Substitute arg for x in expr. For value lambda's, also clone before
+-- substitution.
+beta c (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg c expr
+ | otherwise = setChanged >> substitute_clone x arg c expr
+-- Leave all other expressions unchanged
+beta c expr = return expr
+
+--------------------------------
+-- Unused let binding removal
+--------------------------------
+letremoveunused :: Transform
+letremoveunused c expr@(Let (NonRec b bound) res) = do
+ let used = expr_uses_binders [b] res
+ if used
+ then return expr
+ else change res
+letremoveunused c expr@(Let (Rec binds) res) = do
+ -- Filter out all unused binds.
+ let binds' = filter dobind binds
+ -- Only set the changed flag if binds got removed
+ changeif (length binds' /= length binds) (Let (Rec binds') res)
+ where
+ bound_exprs = map snd binds
+ -- For each bind check if the bind is used by res or any of the bound
+ -- expressions
+ dobind (bndr, _) = any (expr_uses_binders [bndr]) (res:bound_exprs)
+-- Leave all other expressions unchanged
+letremoveunused c expr = return expr
+
+--------------------------------
+-- empty let removal
+--------------------------------
+-- Remove empty (recursive) lets
+letremove :: Transform
+letremove c (Let (Rec []) res) = change res
+-- Leave all other expressions unchanged
+letremove c expr = return expr
+
+--------------------------------
+-- Simple let binding removal
+--------------------------------
+-- Remove a = b bindings from let expressions everywhere
+letremovesimple :: Transform
+letremovesimple = inlinebind (\(b, e) -> Trans.lift $ is_local_var e)
+
+--------------------------------
+-- Cast propagation
+--------------------------------
+-- Try to move casts as much downward as possible.
+castprop :: Transform
+castprop c (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
+castprop c expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
+ where
+ alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
+-- Leave all other expressions unchanged
+castprop c expr = return expr
+
+--------------------------------
+-- Cast simplification. Mostly useful for state packing and unpacking, but
+-- perhaps for others as well.
+--------------------------------
+castsimpl :: Transform
+castsimpl c expr@(Cast val ty) = do
+ -- Don't extract values that are already simpl
+ local_var <- Trans.lift $ is_local_var val
+ -- Don't extract values that are not representable, to prevent loops with
+ -- inlinenonrep
+ repr <- isRepr val
+ if (not local_var) && repr
+ then do
+ -- Generate a binder for the expression
+ id <- Trans.lift $ mkBinderFor val "castval"
+ -- Extract the expression
+ change $ Let (NonRec id val) (Cast (Var id) ty)
+ else
+ return expr
+-- Leave all other expressions unchanged
+castsimpl c expr = return expr
+
+--------------------------------
+-- Top level function inlining
+--------------------------------
+-- This transformation inlines simple top level bindings. Simple
+-- currently means that the body is only a single application (though
+-- the complexity of the arguments is not currently checked) or that the
+-- normalized form only contains a single binding. This should catch most of the
+-- cases where a top level function is created that simply calls a type class
+-- method with a type and dictionary argument, e.g.
+-- fromInteger = GHC.Num.fromInteger (SizedWord D8) $dNum
+-- which is later called using simply
+-- fromInteger (smallInteger 10)
+--
+-- These useless wrappers are created by GHC automatically. If we don't
+-- inline them, we get loads of useless components cluttering the
+-- generated VHDL.
+--
+-- Note that the inlining could also inline simple functions defined by
+-- the user, not just GHC generated functions. It turns out to be near
+-- impossible to reliably determine what functions are generated and
+-- what functions are user-defined. Instead of guessing (which will
+-- inline less than we want) we will just inline all simple functions.
+--
+-- Only functions that are actually completely applied and bound by a
+-- variable in a let expression are inlined. These are the expressions
+-- that will eventually generate instantiations of trivial components.
+-- By not inlining any other reference, we also prevent looping problems
+-- with funextract and inlinedict.
+inlinetoplevel :: Transform
+inlinetoplevel (LetBinding:_) expr | not (is_fun expr) =
+ case collectArgs expr of
+ (Var f, args) -> do
+ body_maybe <- needsInline f
+ case body_maybe of
+ Just body -> do
+ -- Regenerate all uniques in the to-be-inlined expression
+ body_uniqued <- Trans.lift $ genUniques body
+ -- And replace the variable reference with the unique'd body.
+ change (mkApps body_uniqued args)
+ -- No need to inline
+ Nothing -> return expr
+ -- This is not an application of a binder, leave it unchanged.
+ _ -> return expr
+
+-- Leave all other expressions unchanged
+inlinetoplevel c expr = return expr
+
+-- | Does the given binder need to be inlined? If so, return the body to
+-- be used for inlining.
+needsInline :: CoreBndr -> TransformMonad (Maybe CoreExpr)
+needsInline f = do
+ body_maybe <- Trans.lift $ getGlobalBind f
+ case body_maybe of
+ -- No body available?
+ Nothing -> return Nothing
+ Just body -> case CoreSyn.collectArgs body of
+ -- The body is some (top level) binder applied to 0 or more
+ -- arguments. That should be simple enough to inline.
+ (Var f, args) -> return $ Just body
+ -- Body is more complicated, try normalizing it
+ _ -> do
+ norm_maybe <- Trans.lift $ getNormalized_maybe False f
+ case norm_maybe of
+ -- Noth normalizeable
+ Nothing -> return Nothing
+ Just norm -> case splitNormalizedNonRep norm of
+ -- The function has just a single binding, so that's simple
+ -- enough to inline.
+ (args, [bind], Var res) -> return $ Just norm
+ -- More complicated function, don't inline
+ _ -> return Nothing
+
+
+----------------------------------------------------------------
+-- Program structure transformations
+----------------------------------------------------------------
+
+--------------------------------
+-- η expansion
+--------------------------------
+-- Make sure all parameters to the normalized functions are named by top
+-- level lambda expressions. For this we apply η expansion to the
+-- function body (possibly enclosed in some lambda abstractions) while
+-- it has a function type. Eventually this will result in a function
+-- body consisting of a bunch of nested lambdas containing a
+-- non-function value (e.g., a complete application).
+eta :: Transform
+eta c expr | is_fun expr && not (is_lam expr) && all (== LambdaBody) c = do
+ let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
+ id <- Trans.lift $ mkInternalVar "param" arg_ty
+ change (Lam id (App expr (Var id)))
+-- Leave all other expressions unchanged
+eta c e = return e
+
+--------------------------------
+-- Application propagation
+--------------------------------
+-- Move applications into let and case expressions.
+appprop :: Transform
+-- Propagate the application into the let
+appprop c (App (Let binds expr) arg) = change $ Let binds (App expr arg)
+-- Propagate the application into each of the alternatives
+appprop c (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
+ where
+ alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
+ ty' = CoreUtils.applyTypeToArg ty arg
+-- Leave all other expressions unchanged
+appprop c expr = return expr
+
+--------------------------------
+-- Let recursification
+--------------------------------
+-- Make all lets recursive, so other transformations don't need to
+-- handle non-recursive lets
+letrec :: Transform
+letrec c expr@(Let (NonRec bndr val) res) =
+ change $ Let (Rec [(bndr, val)]) res
+
+-- Leave all other expressions unchanged
+letrec c expr = return expr
+
+--------------------------------
+-- let flattening
+--------------------------------
+-- Takes a let that binds another let, and turns that into two nested lets.
+-- e.g., from:
+-- let b = (let b' = expr' in res') in res
+-- to:
+-- let b' = expr' in (let b = res' in res)
+letflat :: Transform
+-- Turn a nonrec let that binds a let into two nested lets.
+letflat c (Let (NonRec b (Let binds res')) res) =
+ change $ Let binds (Let (NonRec b res') res)
+letflat c (Let (Rec binds) expr) = do
+ -- Flatten each binding.
+ binds' <- Utils.concatM $ Monad.mapM flatbind binds
+ -- Return the new let. We don't use change here, since possibly nothing has
+ -- changed. If anything has changed, flatbind has already flagged that
+ -- change.
+ return $ Let (Rec binds') expr
+ where
+ -- Turns a binding of a let into a multiple bindings, or any other binding
+ -- into a list with just that binding
+ flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
+ flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
+ flatbind (b, Let (NonRec b' expr') expr) = change [(b, expr), (b', expr')]
+ flatbind (b, expr) = return [(b, expr)]
+-- Leave all other expressions unchanged
+letflat c expr = return expr
+
+--------------------------------
+-- Return value simplification
+--------------------------------
+-- Ensure the return value of a function follows proper normal form. eta
+-- expansion ensures the body starts with lambda abstractions, this
+-- transformation ensures that the lambda abstractions always contain a
+-- recursive let and that, when the return value is representable, the
+-- let contains a local variable reference in its body.
+
+-- Extract the return value from the body of the top level lambdas (of
+-- which ther could be zero), unless it is a let expression (in which
+-- case the next clause applies).
+retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
+ local_var <- Trans.lift $ is_local_var expr
+ repr <- isRepr expr
+ if not local_var && repr
+ then do
+ id <- Trans.lift $ mkBinderFor expr "res"
+ change $ Let (Rec [(id, expr)]) (Var id)
+ else
+ return expr
+-- Extract the return value from the body of a let expression, which is
+-- itself the body of the top level lambdas (of which there could be
+-- zero).
+retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do
+ -- Don't extract values that are already a local variable, to prevent
+ -- loops with ourselves.
+ local_var <- Trans.lift $ is_local_var body
+ -- Don't extract values that are not representable, to prevent loops with
+ -- inlinenonrep
+ repr <- isRepr body
+ if not local_var && repr
+ then do
+ id <- Trans.lift $ mkBinderFor body "res"
+ change $ Let (Rec ((id, body):binds)) (Var id)
+ else
+ return expr
+-- Leave all other expressions unchanged
+retvalsimpl c expr = return expr
+
+--------------------------------
+-- Representable arguments simplification
+--------------------------------
+-- Make sure that all arguments of a representable type are simple variables.
+appsimpl :: Transform
+-- Simplify all representable arguments. Do this by introducing a new Let
+-- that binds the argument and passing the new binder in the application.
+appsimpl c expr@(App f arg) = do
+ -- Check runtime representability
+ repr <- isRepr arg
+ local_var <- Trans.lift $ is_local_var arg
+ if repr && not local_var
+ then do -- Extract representable arguments
+ id <- Trans.lift $ mkBinderFor arg "arg"
+ change $ Let (NonRec id arg) (App f (Var id))
+ else -- Leave non-representable arguments unchanged
+ return expr
+-- Leave all other expressions unchanged
+appsimpl c expr = return expr
+
+----------------------------------------------------------------
+-- Built-in function transformations
+----------------------------------------------------------------
+
+--------------------------------
+-- Function-typed argument extraction
+--------------------------------
+-- This transform takes any function-typed argument that cannot be propagated
+-- (because the function that is applied to it is a builtin function), and
+-- puts it in a brand new top level binder. This allows us to for example
+-- apply map to a lambda expression This will not conflict with inlinenonrep,
+-- since that only inlines local let bindings, not top level bindings.
+funextract :: Transform
+funextract c expr@(App _ _) | is_var fexpr = do
+ body_maybe <- Trans.lift $ getGlobalBind f
+ case body_maybe of
+ -- We don't have a function body for f, so we can perform this transform.
+ Nothing -> do
+ -- Find the new arguments
+ args' <- mapM doarg args
+ -- And update the arguments. We use return instead of changed, so the
+ -- changed flag doesn't get set if none of the args got changed.
+ return $ MkCore.mkCoreApps fexpr args'
+ -- We have a function body for f, leave this application to funprop
+ Just _ -> return expr
+ where
+ -- Find the function called and the arguments
+ (fexpr, args) = collectArgs expr
+ Var f = fexpr
+ -- Change any arguments that have a function type, but are not simple yet
+ -- (ie, a variable or application). This means to create a new function
+ -- for map (\f -> ...) b, but not for map (foo a) b.
+ --
+ -- We could use is_applicable here instead of is_fun, but I think
+ -- arguments to functions could only have forall typing when existential
+ -- typing is enabled. Not sure, though.
+ doarg arg | not (is_simple arg) && is_fun arg = do
+ -- Create a new top level binding that binds the argument. Its body will
+ -- be extended with lambda expressions, to take any free variables used
+ -- by the argument expression.
+ let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
+ let body = MkCore.mkCoreLams free_vars arg
+ id <- Trans.lift $ mkBinderFor body "fun"
+ Trans.lift $ addGlobalBind id body
+ -- Replace the argument with a reference to the new function, applied to
+ -- all vars it uses.
+ change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
+ -- Leave all other arguments untouched
+ doarg arg = return arg
+
+-- Leave all other expressions unchanged
+funextract c expr = return expr
+
+
+
+
+----------------------------------------------------------------
+-- Case normalization transformations
+----------------------------------------------------------------
+
+--------------------------------
+-- Scrutinee simplification
+--------------------------------
+-- Make sure the scrutinee of a case expression is a local variable
+-- reference.
+scrutsimpl :: Transform
+-- Don't touch scrutinees that are already simple
+scrutsimpl c expr@(Case (Var _) _ _ _) = return expr
+-- Replace all other cases with a let that binds the scrutinee and a new
+-- simple scrutinee, but only when the scrutinee is representable (to prevent
+-- loops with inlinenonrep, though I don't think a non-representable scrutinee
+-- will be supported anyway...)
+scrutsimpl c expr@(Case scrut b ty alts) = do
+ repr <- isRepr scrut
+ if repr
+ then do
+ id <- Trans.lift $ mkBinderFor scrut "scrut"
+ change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
+ else
+ return expr
+-- Leave all other expressions unchanged
+scrutsimpl c expr = return expr
+
+--------------------------------
+-- Scrutinee binder removal
+--------------------------------
+-- A case expression can have an extra binder, to which the scrutinee is bound
+-- after bringing it to WHNF. This is used for forcing evaluation of strict
+-- arguments. Since strictness does not matter for us (rather, everything is
+-- sort of strict), this binder is ignored when generating VHDL, and must thus
+-- be wild in the normal form.
+scrutbndrremove :: Transform
+-- If the scrutinee is already simple, and the bndr is not wild yet, replace
+-- all occurences of the binder with the scrutinee variable.
+scrutbndrremove c (Case (Var scrut) bndr ty alts) | bndr_used = do
+ alts' <- mapM subs_bndr alts
+ change $ Case (Var scrut) wild ty alts'
+ where
+ is_used (_, _, expr) = expr_uses_binders [bndr] expr
+ bndr_used = or $ map is_used alts
+ subs_bndr (con, bndrs, expr) = do
+ expr' <- substitute bndr (Var scrut) c expr
+ return (con, bndrs, expr')
+ wild = MkCore.mkWildBinder (Id.idType bndr)
+-- Leave all other expressions unchanged
+scrutbndrremove c expr = return expr
+
+--------------------------------
+-- Case normalization
+--------------------------------
+-- Turn a case expression with any number of alternatives with any
+-- number of non-wild binders into as set of case and let expressions,
+-- all of which are in normal form (e.g., a bunch of extractor case
+-- expressions to extract all fields from the scrutinee, a number of let
+-- bindings to bind each alternative and a single selector case to
+-- select the right value.
+casesimpl :: Transform
+-- This is already a selector case (or, if x does not appear in bndrs, a very
+-- simple case statement that will be removed by caseremove below). Just leave
+-- it be.
+casesimpl c expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
+-- Make sure that all case alternatives have only wild binders and simple
+-- expressions.
+-- This is done by creating a new let binding for each non-wild binder, which
+-- is bound to a new simple selector case statement and for each complex
+-- expression. We do this only for representable types, to prevent loops with
+-- inlinenonrep.
+casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
+ (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
+ let bindings = concat bindingss
+ -- Replace the case with a let with bindings and a case
+ let newlet = mkNonRecLets bindings (Case scrut bndr ty alts')
+ -- If there are no non-wild binders, or this case is already a simple
+ -- selector (i.e., a single alt with exactly one binding), already a simple
+ -- selector altan no bindings (i.e., no wild binders in the original case),
+ -- don't change anything, otherwise, replace the case.
+ if null bindings then return expr else change newlet
+ where
+ -- Check if the scrutinee binder is used
+ is_used (_, _, expr) = expr_uses_binders [bndr] expr
+ bndr_used = or $ map is_used alts
+ -- Generate a single wild binder, since they are all the same
+ wild = MkCore.mkWildBinder
+ -- Wilden the binders of one alt, producing a list of bindings as a
+ -- sideeffect.
+ doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
+ doalt (con, bndrs, expr) = do
+ -- Make each binder wild, if possible
+ bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
+ let (newbndrs, bindings_maybe) = unzip bndrs_res
+ -- Extract a complex expression, if possible. For this we check if any of
+ -- the new list of bndrs are used by expr. We can't use free_vars here,
+ -- since that looks at the old bndrs.
+ let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
+ (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
+ -- Create a new alternative
+ let newalt = (con, newbndrs, expr')
+ let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
+ return (bindings, newalt)
+ where
+ -- Make wild alternatives for each binder
+ wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
+ -- A set of all the binders that are used by the expression
+ free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
+ -- Look at the ith binder in the case alternative. Return a new binder
+ -- for it (either the same one, or a wild one) and optionally a let
+ -- binding containing a case expression.
+ dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
+ dobndr b i = do
+ repr <- isRepr b
+ -- Is b wild (e.g., not a free var of expr. Since b is only in scope
+ -- in expr, this means that b is unused if expr does not use it.)
+ let wild = not (VarSet.elemVarSet b free_vars)
+ -- Create a new binding for any representable binder that is not
+ -- already wild and is representable (to prevent loops with
+ -- inlinenonrep).
+ if (not wild) && repr
+ then do
+ caseexpr <- Trans.lift $ mkSelCase scrut i
+ -- Create a new binder that will actually capture a value in this
+ -- case statement, and return it.
+ return (wildbndrs!!i, Just (b, caseexpr))
+ else
+ -- Just leave the original binder in place, and don't generate an
+ -- extra selector case.
+ return (b, Nothing)
+ -- Process the expression of a case alternative. Accepts an expression
+ -- and whether this expression uses any of the binders in the
+ -- alternative. Returns an optional new binding and a new expression.
+ doexpr :: CoreExpr -> Bool -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreExpr)
+ doexpr expr uses_bndrs = do
+ local_var <- Trans.lift $ is_local_var expr
+ repr <- isRepr expr
+ -- Extract any expressions that do not use any binders from this
+ -- alternative, is not a local var already and is representable (to
+ -- prevent loops with inlinenonrep).
+ if (not uses_bndrs) && (not local_var) && repr
+ then do
+ id <- Trans.lift $ mkBinderFor expr "caseval"
+ -- We don't flag a change here, since casevalsimpl will do that above
+ -- based on Just we return here.
+ return (Just (id, expr), Var id)
+ else
+ -- Don't simplify anything else
+ return (Nothing, expr)
+-- Leave all other expressions unchanged
+casesimpl c expr = return expr
+
+--------------------------------
+-- Case removal
+--------------------------------
+-- Remove case statements that have only a single alternative and only wild
+-- binders.
+caseremove :: Transform
+-- Replace a useless case by the value of its single alternative
+caseremove c (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
+ -- Find if any of the binders are used by expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` b:bndrs))) expr
+-- Leave all other expressions unchanged
+caseremove c expr = return expr
+
+--------------------------------
+-- Case of known constructor simplification
+--------------------------------
+-- If a case expressions scrutinizes a datacon application, we can
+-- determine which alternative to use and remove the case alltogether.
+-- We replace it with a let expression the binds every binder in the
+-- alternative bound to the corresponding argument of the datacon. We do
+-- this instead of substituting the binders, to prevent duplication of
+-- work and preserve sharing wherever appropriate.
+knowncase :: Transform
+knowncase context expr@(Case scrut@(App _ _) bndr ty alts) | not bndr_used = do
+ case collectArgs scrut of
+ (Var f, args) -> case Id.isDataConId_maybe f of
+ -- Not a dataconstructor? Don't change anything (probably a
+ -- function, then)
+ Nothing -> return expr
+ Just dc -> do
+ let (altcon, bndrs, res) = case List.find (\(altcon, bndrs, res) -> altcon == (DataAlt dc)) alts of
+ Just alt -> alt -- Return the alternative found
+ Nothing -> head alts -- If the datacon is not present, the first must be the default alternative
+ -- Double check if we have either the correct alternative, or
+ -- the default.
+ if altcon /= (DataAlt dc) && altcon /= DEFAULT then error ("Normalize.knowncase: Invalid core, datacon not found in alternatives and DEFAULT alternative is not first? " ++ pprString expr) else return ()
+ -- Find out how many arguments to drop (type variables and
+ -- predicates like dictionaries).
+ let (tvs, preds, _, _) = DataCon.dataConSig dc
+ let count = length tvs + length preds
+ -- Create a let expression that binds each of the binders in
+ -- this alternative to the corresponding argument of the data
+ -- constructor.
+ let binds = zip bndrs (drop count args)
+ change $ Let (Rec binds) res
+ _ -> return expr -- Scrutinee is not an application of a var
+ where
+ is_used (_, _, expr) = expr_uses_binders [bndr] expr
+ bndr_used = or $ map is_used alts
+
+-- Leave all other expressions unchanged
+knowncase c expr = return expr
+
+
+
+
+----------------------------------------------------------------
+-- Unrepresentable value removal transformations
+----------------------------------------------------------------
+
+--------------------------------
+-- Non-representable binding inlining
+--------------------------------
+-- Remove a = B bindings, with B of a non-representable type, from let
+-- expressions everywhere. This means that any value that we can't generate a
+-- signal for, will be inlined and hopefully turned into something we can
+-- represent.
+--
+-- This is a tricky function, which is prone to create loops in the
+-- transformations. To fix this, we make sure that no transformation will
+-- create a new let binding with a non-representable type. These other
+-- transformations will just not work on those function-typed values at first,
+-- but the other transformations (in particular β-reduction) should make sure
+-- that the type of those values eventually becomes representable.
+inlinenonrep :: Transform
+inlinenonrep = inlinebind ((Monad.liftM not) . isRepr . snd)
+
+--------------------------------
+-- Function specialization
+--------------------------------
+-- Remove all applications to non-representable arguments, by duplicating the
+-- function called with the non-representable parameter replaced by the free
+-- variables of the argument passed in.
+argprop :: Transform
+-- Transform any application of a named function (i.e., skip applications of
+-- lambda's). Also skip applications that have arguments with free type
+-- variables, since we can't inline those.
+argprop c expr@(App _ _) | is_var fexpr = do
+ -- Find the body of the function called
+ body_maybe <- Trans.lift $ getGlobalBind f
+ case body_maybe of
+ Just body -> do
+ -- Process each of the arguments in turn
+ (args', changed) <- Writer.listen $ mapM doarg args
+ -- See if any of the arguments changed
+ case Monoid.getAny changed of
+ True -> do
+ let (newargs', newparams', oldargs) = unzip3 args'
+ let newargs = concat newargs'
+ let newparams = concat newparams'
+ -- Create a new body that consists of a lambda for all new arguments and
+ -- the old body applied to some arguments.
+ let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
+ -- Create a new function with the same name but a new body
+ newf <- Trans.lift $ mkFunction f newbody
+
+ Trans.lift $ MonadState.modify tsInitStates (\ismap ->
+ let init_state_maybe = Map.lookup f ismap in
+ case init_state_maybe of
+ Nothing -> ismap
+ Just init_state -> Map.insert newf init_state ismap)
+ -- Replace the original application with one of the new function to the
+ -- new arguments.
+ change $ MkCore.mkCoreApps (Var newf) newargs
+ False ->
+ -- Don't change the expression if none of the arguments changed
+ return expr
+
+ -- If we don't have a body for the function called, leave it unchanged (it
+ -- should be a primitive function then).
+ Nothing -> return expr
+ where
+ -- Find the function called and the arguments
+ (fexpr, args) = collectArgs expr
+ Var f = fexpr
+
+ -- Process a single argument and return (args, bndrs, arg), where args are
+ -- the arguments to replace the given argument in the original
+ -- application, bndrs are the binders to include in the top-level lambda
+ -- in the new function body, and arg is the argument to apply to the old
+ -- function body.
+ doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
+ doarg arg = do
+ repr <- isRepr arg
+ bndrs <- Trans.lift getGlobalBinders
+ let interesting var = Var.isLocalVar var && (var `notElem` bndrs)
+ if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
+ then do
+ -- Propagate all complex arguments that are not representable, but not
+ -- arguments with free type variables (since those would require types
+ -- not known yet, which will always be known eventually).
+ -- Find interesting free variables, each of which should be passed to
+ -- the new function instead of the original function argument.
+ --
+ -- Interesting vars are those that are local, but not available from the
+ -- top level scope (functions from this module are defined as local, but
+ -- they're not local to this function, so we can freely move references
+ -- to them into another function).
+ let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
+ -- Mark the current expression as changed
+ setChanged
+ -- TODO: Clone the free_vars (and update references in arg), since
+ -- this might cause conflicts if two arguments that are propagated
+ -- share a free variable. Also, we are now introducing new variables
+ -- into a function that are not fresh, which violates the binder
+ -- uniqueness invariant.
+ return (map Var free_vars, free_vars, arg)
+ else do
+ -- Representable types will not be propagated, and arguments with free
+ -- type variables will be propagated later.
+ -- Note that we implicitly remove any type variables in the type of
+ -- the original argument by using the type of the actual argument
+ -- for the new formal parameter.
+ -- TODO: preserve original naming?
+ id <- Trans.lift $ mkBinderFor arg "param"
+ -- Just pass the original argument to the new function, which binds it
+ -- to a new id and just pass that new id to the old function body.
+ return ([arg], [id], mkReferenceTo id)
+-- Leave all other expressions unchanged
+argprop c expr = return expr
+
+--------------------------------
+-- Non-representable result inlining
+--------------------------------
+-- This transformation takes a function (top level binding) that has a
+-- non-representable result (e.g., a tuple containing a function, or an
+-- Integer. The latter can occur in some cases as the result of the
+-- fromIntegerT function) and inlines enough of the function to make the
+-- result representable again.
+--
+-- This is done by first normalizing the function and then "inlining"
+-- the result. Since no unrepresentable let bindings are allowed in
+-- normal form, we can be sure that all free variables of the result
+-- expression will be representable (Note that we probably can't
+-- guarantee that all representable parts of the expression will be free
+-- variables, so we might inline more than strictly needed).
+--
+-- The new function result will be a tuple containing all free variables
+-- of the old result, so the old result can be rebuild at the caller.
+--
+-- We take care not to inline dictionary id's, which are top level
+-- bindings with a non-representable result type as well, since those
+-- will never become VHDL signals directly. There is a separate
+-- transformation (inlinedict) that specifically inlines dictionaries
+-- only when it is useful.
+inlinenonrepresult :: Transform
+
+-- Apply to any (application of) a reference to a top level function
+-- that is fully applied (i.e., dos not have a function type) but is not
+-- representable. We apply in any context, since non-representable
+-- expressions are generally left alone and can occur anywhere.
+inlinenonrepresult context expr | not (is_fun expr) =
+ case collectArgs expr of
+ (Var f, args) | not (Id.isDictId f) -> do
+ repr <- isRepr expr
+ if not repr
+ then do
+ body_maybe <- Trans.lift $ getNormalized_maybe True f
+ case body_maybe of
+ Just body -> do
+ let (bndrs, binds, res) = splitNormalizedNonRep body
+ if has_free_tyvars res
+ then
+ -- Don't touch anything with free type variables, since
+ -- we can't return those. We'll wait until argprop
+ -- removed those variables.
+ return expr
+ else do
+ -- Get the free local variables of res
+ global_bndrs <- Trans.lift getGlobalBinders
+ let interesting var = Var.isLocalVar var && (var `notElem` global_bndrs)
+ let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting res
+ let free_var_types = map Id.idType free_vars
+ let n_free_vars = length free_vars
+ -- Get a tuple datacon to wrap around the free variables
+ let fvs_datacon = TysWiredIn.tupleCon BasicTypes.Boxed n_free_vars
+ let fvs_datacon_id = DataCon.dataConWorkId fvs_datacon
+ -- Let the function now return a tuple with references to
+ -- all free variables of the old return value. First pass
+ -- all the types of the variables, since tuple
+ -- constructors are polymorphic.
+ let newres = mkApps (Var fvs_datacon_id) (map Type free_var_types ++ map Var free_vars)
+ -- Recreate the function body with the changed return value
+ let newbody = mkLams bndrs (Let (Rec binds) newres)
+ -- Create the new function
+ f' <- Trans.lift $ mkFunction f newbody
+
+ -- Call the new function
+ let newapp = mkApps (Var f') args
+ res_bndr <- Trans.lift $ mkBinderFor newapp "res"
+ -- Create extractor case expressions to extract each of the
+ -- free variables from the tuple.
+ sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1]
+
+ -- Bind the res_bndr to the result of the new application
+ -- and each of the free variables to the corresponding
+ -- selector case. Replace the let body with the original
+ -- body of the called function (which can still access all
+ -- of its free variables, from the let).
+ let binds = (res_bndr, newapp):(zip free_vars sel_cases)
+ let letexpr = Let (Rec binds) res
+
+ -- Finally, regenarate all uniques in the new expression,
+ -- since the free variables could otherwise become
+ -- duplicated. It is not strictly necessary to regenerate
+ -- res, since we're moving that expression, but it won't
+ -- hurt.
+ letexpr_uniqued <- Trans.lift $ genUniques letexpr
+ change letexpr_uniqued
+ Nothing -> return expr
+ else
+ -- Don't touch representable expressions or (applications of)
+ -- dictionary ids.
+ return expr
+ -- Not a reference to or application of a top level function
+ _ -> return expr
+-- Leave all other expressions unchanged
+inlinenonrepresult c expr = return expr
+
+--------------------------------
+-- ClassOp resolution
+--------------------------------
+-- Resolves any class operation to the actual operation whenever
+-- possible. Class methods (as well as parent dictionary selectors) are
+-- special "functions" that take a type and a dictionary and evaluate to
+-- the corresponding method. A dictionary is nothing more than a
+-- special dataconstructor applied to the type the dictionary is for,
+-- each of the superclasses and all of the class method definitions for
+-- that particular type. Since dictionaries all always inlined (top
+-- levels dictionaries are inlined by inlinedict, local dictionaries are
+-- inlined by inlinenonrep), we will eventually have something like:
+--
+-- baz
+-- @ CLasH.HardwareTypes.Bit
+-- (D:Baz @ CLasH.HardwareTypes.Bit bitbaz)
+--
+-- Here, baz is the method selector for the baz method, while
+-- D:Baz is the dictionary constructor for the Baz and bitbaz is the baz
+-- method defined in the Baz Bit instance declaration.
+--
+-- To resolve this, we can look at the ClassOp IdInfo from the baz Id,
+-- which contains the Class it is defined for. From the Class, we can
+-- get a list of all selectors (both parent class selectors as well as
+-- method selectors). Since the arguments to D:Baz (after the type
+-- argument) correspond exactly to this list, we then look up baz in
+-- that list and replace the entire expression by the corresponding
+-- argument to D:Baz.
+--
+-- We don't resolve methods that have a builtin translation (such as
+-- ==), since the actual implementation is not always (easily)
+-- translateable. For example, when deriving ==, GHC generates code
+-- using $con2tag functions to translate a datacon to an int and compare
+-- that with GHC.Prim.==# . Better to avoid that for now.
+classopresolution :: Transform
+classopresolution c expr@(App (App (Var sel) ty) dict) | not is_builtin =
+ case Id.isClassOpId_maybe sel of
+ -- Not a class op selector
+ Nothing -> return expr
+ Just cls -> case collectArgs dict of
+ (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet)
+ (Var dictdc, (ty':selectors)) | not (Maybe.isJust (Id.isDataConId_maybe dictdc)) -> return expr -- Dictionary is not a datacon yet (but e.g., a top level binder)
+ | tyargs_neq ty ty' -> error $ "Normalize.classopresolution: Applying class selector to dictionary without matching type?\n" ++ pprString expr
+ | otherwise ->
+ let selector_ids = Class.classSelIds cls in
+ -- Find the selector used in the class' list of selectors
+ case List.elemIndex sel selector_ids of
+ Nothing -> error $ "Normalize.classopresolution: Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids
+ -- Get the corresponding argument from the dictionary
+ Just n -> change (selectors!!n)
+ (_, _) -> return expr -- Not applying a variable? Don't touch
+ where
+ -- Compare two type arguments, returning True if they are _not_
+ -- equal
+ tyargs_neq (Type ty1) (Type ty2) = not $ Type.coreEqType ty1 ty2
+ tyargs_neq _ _ = True
+ -- Is this a builtin function / method?
+ is_builtin = elem (Name.getOccString sel) builtinIds
+
+-- Leave all other expressions unchanged
+classopresolution c expr = return expr
+
+--------------------------------
+-- Dictionary inlining
+--------------------------------
+-- Inline all top level dictionaries, that are in a position where
+-- classopresolution can actually resolve them. This makes this
+-- transformation look similar to classoperesolution below, but we'll
+-- keep them separated for clarity. By not inlining other dictionaries,
+-- we prevent expression sizes exploding when huge type level integer
+-- dictionaries are inlined which can never be expanded (in casts, for
+-- example).
+inlinedict c expr@(App (App (Var sel) ty) (Var dict)) | not is_builtin && is_classop = do
+ body_maybe <- Trans.lift $ getGlobalBind dict
+ case body_maybe of
+ -- No body available (no source available, or a local variable /
+ -- argument)
+ Nothing -> return expr
+ Just body -> change (App (App (Var sel) ty) body)
+ where
+ -- Is this a builtin function / method?
+ is_builtin = elem (Name.getOccString sel) builtinIds
+ -- Are we dealing with a class operation selector?
+ is_classop = Maybe.isJust (Id.isClassOpId_maybe sel)
+
+-- Leave all other expressions unchanged
+inlinedict c expr = return expr
+
+
+{-
+--------------------------------
+-- Identical let binding merging
+--------------------------------
+-- Merge two bindings in a let if they are identical
+-- TODO: We would very much like to use GHC's CSE module for this, but that
+-- doesn't track if something changed or not, so we can't use it properly.
+letmerge :: Transform
+letmerge c expr@(Let _ _) = do
+ let (binds, res) = flattenLets expr
+ binds' <- domerge binds
+ return $ mkNonRecLets binds' res
+ where
+ domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)]
+ domerge [] = return []
+ domerge (e:es) = do
+ es' <- mapM (mergebinds e) es
+ es'' <- domerge es'
+ return (e:es'')
+
+ -- Uses the second bind to simplify the second bind, if applicable.
+ mergebinds :: (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ mergebinds (b1, e1) (b2, e2)
+ -- Identical expressions? Replace the second binding with a reference to
+ -- the first binder.
+ | CoreUtils.cheapEqExpr e1 e2 = change $ (b2, Var b1)
+ -- Different expressions? Don't change
+ | otherwise = return (b2, e2)
+-- Leave all other expressions unchanged
+letmerge c expr = return expr
+-}
+
+--------------------------------
+-- End of transformations
+--------------------------------
+
+
+
+
+-- What transforms to run?
+transforms = [ ("inlinedict", inlinedict)
+ , ("inlinetoplevel", inlinetoplevel)
+ , ("inlinenonrepresult", inlinenonrepresult)
+ , ("knowncase", knowncase)
+ , ("classopresolution", classopresolution)
+ , ("argprop", argprop)
+ , ("funextract", funextract)
+ , ("eta", eta)
+ , ("beta", beta)
+ , ("appprop", appprop)
+ , ("castprop", castprop)
+ , ("letremovesimple", letremovesimple)
+ , ("letrec", letrec)
+ , ("letremove", letremove)
+ , ("retvalsimpl", retvalsimpl)
+ , ("letflat", letflat)
+ , ("scrutsimpl", scrutsimpl)
+ , ("scrutbndrremove", scrutbndrremove)
+ , ("casesimpl", casesimpl)
+ , ("caseremove", caseremove)
+ , ("inlinenonrep", inlinenonrep)
+ , ("appsimpl", appsimpl)
+ , ("letremoveunused", letremoveunused)
+ , ("castsimpl", castsimpl)
+ ]
+
+-- | Returns the normalized version of the given function, or an error
+-- if it is not a known global binder.
+getNormalized ::
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The function to get
+ -> TranslatorSession CoreExpr -- The normalized function body
+getNormalized result_nonrep bndr = do
+ norm <- getNormalized_maybe result_nonrep bndr
+ return $ Maybe.fromMaybe
+ (error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr)
+ norm
+
+-- | Returns the normalized version of the given function, or Nothing
+-- when the binder is not a known global binder or is not normalizeable.
+getNormalized_maybe ::
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The function to get
+ -> TranslatorSession (Maybe CoreExpr) -- The normalized function body
+
+getNormalized_maybe result_nonrep bndr = do
+ expr_maybe <- getGlobalBind bndr
+ normalizeable <- isNormalizeable result_nonrep bndr
+ if not normalizeable || Maybe.isNothing expr_maybe
+ then
+ -- Binder not normalizeable or not found
+ return Nothing
+ else do
+ -- Binder found and is monomorphic. Normalize the expression
+ -- and cache the result.
+ normalized <- Utils.makeCached bndr tsNormalized $
+ normalizeExpr (show bndr) (Maybe.fromJust expr_maybe)
+ return (Just normalized)
+
+-- | Normalize an expression
+normalizeExpr ::
+ String -- ^ What are we normalizing? For debug output only.
+ -> CoreSyn.CoreExpr -- ^ The expression to normalize
+ -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
+
+normalizeExpr what expr = do
+ startcount <- MonadState.get tsTransformCounter
+ expr_uniqued <- genUniques expr
+ -- Do a debug print, if requested
+ let expr_uniqued' = Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") expr_uniqued
+ -- Normalize this expression
+ expr' <- dotransforms transforms expr_uniqued'
+ endcount <- MonadState.get tsTransformCounter
+ -- Do a debug print, if requested
+ Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr') ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
+ return expr'
+
+-- | Split a normalized expression into the argument binders, top level
+-- bindings and the result binder. This function returns an error if
+-- the type of the expression is not representable.
+splitNormalized ::
+ CoreExpr -- ^ The normalized expression
+ -> ([CoreBndr], [Binding], CoreBndr)
+splitNormalized expr =
+ case splitNormalizedNonRep expr of
+ (args, binds, Var res) -> (args, binds, res)
+ _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
+
+-- Split a normalized expression, whose type can be unrepresentable.
+splitNormalizedNonRep::
+ CoreExpr -- ^ The normalized expression
+ -> ([CoreBndr], [Binding], CoreExpr)
+splitNormalizedNonRep expr = (args, binds, resexpr)
+ where
+ (args, letexpr) = CoreSyn.collectBinders expr
+ (binds, resexpr) = flattenLets letexpr
--- /dev/null
+--
+-- This module provides functions for program transformations.
+--
+module CLasH.Normalize.NormalizeTools where
+
+-- Standard modules
+import qualified Data.Monoid as Monoid
+import qualified Data.Either as Either
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Control.Monad.Trans.Class as Trans
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- GHC API
+import CoreSyn
+import qualified Name
+import qualified Id
+import qualified CoreSubst
+import qualified Type
+import qualified CoreUtils
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import CLasH.Normalize.NormalizeTypes
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.Constants (builtinIds)
+import CLasH.Utils
+import qualified CLasH.Utils.Core.CoreTools as CoreTools
+import qualified CLasH.VHDL.VHDLTools as VHDLTools
+
+-- Apply the given transformation to all expressions in the given expression,
+-- including the expression itself.
+everywhere :: Transform -> Transform
+everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
+
+data NormDbgLevel =
+ NormDbgNone -- ^ No debugging
+ | NormDbgFinal -- ^ Print functions before / after normalization
+ | NormDbgApplied -- ^ Print expressions before / after applying transformations
+ | NormDbgAll -- ^ Print expressions when a transformation does not apply
+ deriving (Eq, Ord)
+normalize_debug = NormDbgFinal
+
+-- Applies a transform, optionally showing some debug output.
+apply :: (String, Transform) -> Transform
+apply (name, trans) ctx expr = do
+ -- Apply the transformation and find out if it changed anything
+ (expr', any_changed) <- Writer.listen $ trans ctx expr
+ let changed = Monoid.getAny any_changed
+ -- If it changed, increase the transformation counter
+ Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1))
+ -- Prepare some debug strings
+ let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n"
+ let context = "Context: " ++ show ctx ++ "\n"
+ let after = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
+ traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $
+ traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before ++ context) $
+ return expr'
+
+-- Apply the first transformation, followed by the second transformation, and
+-- keep applying both for as long as expression still changes.
+applyboth :: Transform -> Transform -> Transform
+applyboth first second context expr = do
+ -- Apply the first
+ expr' <- first context expr
+ -- Apply the second
+ (expr'', changed) <- Writer.listen $ second context expr'
+ if Monoid.getAny $ changed
+ then
+ applyboth first second context expr''
+ else
+ return expr''
+
+-- Apply the given transformation to all direct subexpressions (only), not the
+-- expression itself.
+subeverywhere :: Transform -> Transform
+subeverywhere trans c (App a b) = do
+ a' <- trans (AppFirst:c) a
+ b' <- trans (AppSecond:c) b
+ return $ App a' b'
+
+subeverywhere trans c (Let (NonRec b bexpr) expr) = do
+ bexpr' <- trans (LetBinding:c) bexpr
+ expr' <- trans (LetBody:c) expr
+ return $ Let (NonRec b bexpr') expr'
+
+subeverywhere trans c (Let (Rec binds) expr) = do
+ expr' <- trans (LetBody:c) expr
+ binds' <- mapM transbind binds
+ return $ Let (Rec binds') expr'
+ where
+ transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ transbind (b, e) = do
+ e' <- trans (LetBinding:c) e
+ return (b, e')
+
+subeverywhere trans c (Lam x expr) = do
+ expr' <- trans (LambdaBody:c) expr
+ return $ Lam x expr'
+
+subeverywhere trans c (Case scrut b t alts) = do
+ scrut' <- trans (Other:c) scrut
+ alts' <- mapM transalt alts
+ return $ Case scrut' b t alts'
+ where
+ transalt :: CoreAlt -> TransformMonad CoreAlt
+ transalt (con, binders, expr) = do
+ expr' <- trans (Other:c) expr
+ return (con, binders, expr')
+
+subeverywhere trans c (Var x) = return $ Var x
+subeverywhere trans c (Lit x) = return $ Lit x
+subeverywhere trans c (Type x) = return $ Type x
+
+subeverywhere trans c (Cast expr ty) = do
+ expr' <- trans (Other:c) expr
+ return $ Cast expr' ty
+
+subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
+
+-- Runs each of the transforms repeatedly inside the State monad.
+dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
+dotransforms transs expr = do
+ (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply trans) [] e) expr transs
+ if Monoid.getAny changed then dotransforms transs expr' else return expr'
+
+-- Inline all let bindings that satisfy the given condition
+inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
+inlinebind condition context expr@(Let (Rec binds) res) = do
+ -- Find all bindings that adhere to the condition
+ res_eithers <- mapM docond binds
+ case Either.partitionEithers res_eithers of
+ -- No replaces? No change
+ ([], _) -> return expr
+ (replace, others) -> do
+ -- Substitute the to be replaced binders with their expression
+ newexpr <- do_substitute replace (Let (Rec others) res)
+ change newexpr
+ where
+ -- Apply the condition to a let binding and return an Either
+ -- depending on whether it needs to be inlined or not.
+ docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
+ docond b = do
+ res <- condition b
+ return $ case res of True -> Left b; False -> Right b
+
+ -- Apply the given list of substitutions to the the given expression
+ do_substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> TransformMonad CoreExpr
+ do_substitute [] expr = return expr
+ do_substitute ((bndr, val):reps) expr = do
+ -- Perform this substitution in the expression
+ expr' <- substitute_clone bndr val context expr
+ -- And in the substitution values we will be using next
+ reps' <- mapM (subs_bind bndr val) reps
+ -- And then perform the remaining substitutions
+ do_substitute reps' expr'
+
+ -- Replace the given binder with the given expression in the
+ -- expression oft the given let binding
+ subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ subs_bind bndr expr (b, v) = do
+ v' <- substitute_clone bndr expr (LetBinding:context) v
+ return (b, v')
+
+
+-- Leave all other expressions unchanged
+inlinebind _ context expr = return expr
+
+-- Sets the changed flag in the TransformMonad, to signify that some
+-- transform has changed the result
+setChanged :: TransformMonad ()
+setChanged = Writer.tell (Monoid.Any True)
+
+-- Sets the changed flag and returns the given value.
+change :: a -> TransformMonad a
+change val = do
+ setChanged
+ return val
+
+-- Returns the given value and sets the changed flag if the bool given is
+-- True. Note that this will not unset the changed flag if the bool is False.
+changeif :: Bool -> a -> TransformMonad a
+changeif True val = change val
+changeif False val = return val
+
+-- | Creates a transformation that substitutes the given binder with the given
+-- expression (This can be a type variable, replace by a Type expression).
+-- Does not set the changed flag.
+substitute :: CoreBndr -> CoreExpr -> Transform
+-- Use CoreSubst to subst a type var in an expression
+substitute find repl context expr = do
+ let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
+ return $ CoreSubst.substExpr subst expr
+
+-- | Creates a transformation that substitutes the given binder with the given
+-- expression. This does only work for value expressions! All binders in the
+-- expression are cloned before the replacement, to guarantee uniqueness.
+substitute_clone :: CoreBndr -> CoreExpr -> Transform
+-- If we see the var to find, replace it by a uniqued version of repl
+substitute_clone find repl context (Var var) | find == var = do
+ repl' <- Trans.lift $ CoreTools.genUniques repl
+ change repl'
+
+-- For all other expressions, just look in subexpressions
+substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr
+
+-- Is the given expression representable at runtime, based on the type?
+isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
+isRepr tything = Trans.lift (isRepr' tything)
+
+isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
+isRepr' tything = case CoreTools.getType tything of
+ Nothing -> return False
+ Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
+
+is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
+is_local_var (CoreSyn.Var v) = do
+ bndrs <- getGlobalBinders
+ return $ v `notElem` bndrs
+is_local_var _ = return False
+
+-- Is the given binder defined by the user?
+isUserDefined :: CoreSyn.CoreBndr -> Bool
+-- System names are certain to not be user defined
+isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
+-- Builtin functions are usually not user-defined either (and would
+-- break currently if they are...)
+isUserDefined bndr = str `notElem` builtinIds
+ where
+ str = Name.getOccString bndr
+
+-- | Is the given binder normalizable? This means that its type signature can be
+-- represented in hardware, which should (?) guarantee that it can be made
+-- into hardware. This checks whether all the arguments and (optionally)
+-- the return value are
+-- representable.
+isNormalizeable ::
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The binder to check
+ -> TranslatorSession Bool -- ^ Is it normalizeable?
+isNormalizeable result_nonrep bndr = do
+ let ty = Id.idType bndr
+ let (arg_tys, res_ty) = Type.splitFunTys ty
+ let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys)
+ andM $ mapM isRepr' check_tys
--- /dev/null
+module CLasH.Normalize.NormalizeTypes where
+
+-- Standard modules
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Data.Monoid as Monoid
+
+-- GHC API
+import qualified CoreSyn
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+
+-- Wrap a writer around a TranslatorSession, to run a single transformation
+-- over a single expression and track if the expression was changed.
+type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession
+
+-- | In what context does a core expression occur?
+data CoreContext = AppFirst -- ^ The expression is the first
+ -- argument of an application (i.e.,
+ -- it is applied)
+ | AppSecond -- ^ The expression is the second
+ -- argument of an application
+ -- (i.e., something is applied to it)
+ | LetBinding -- ^ The expression is bound in a
+ -- (recursive or non-recursive) let
+ -- expression.
+ | LetBody -- ^ The expression is the body of a
+ -- let expression
+ | LambdaBody -- ^ The expression is the body of a
+ -- lambda abstraction
+ | Other -- ^ Another context
+ deriving (Eq, Show)
+-- | Transforms a CoreExpr and keeps track if it has changed.
+type Transform = [CoreContext] -> CoreSyn.CoreExpr -> TransformMonad CoreSyn.CoreExpr
--- /dev/null
+module CLasH.Translator
+ (
+ makeVHDLAnnotations
+ ) where
+
+-- Standard Modules
+import qualified System.Directory as Directory
+import qualified Maybe
+import qualified Monad
+import qualified System.FilePath as FilePath
+import qualified Control.Monad.Trans.State as State
+import Text.PrettyPrint.HughesPJ (render)
+import Data.Accessor.Monad.Trans.State
+import qualified Data.Map as Map
+import qualified Data.Time.Clock as Clock
+import Debug.Trace
+
+-- GHC API
+import qualified CoreSyn
+import qualified HscTypes
+import qualified UniqSupply
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+import qualified Language.VHDL.FileIO as FileIO
+import qualified Language.VHDL.Ppr as Ppr
+
+-- Local Imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.Translator.Annotations
+import CLasH.Utils
+import CLasH.Utils.GhcTools
+import CLasH.VHDL
+import CLasH.VHDL.VHDLTools
+import CLasH.VHDL.Testbench
+
+-- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
+-- and Test Inputs found in the Files.
+makeVHDLAnnotations ::
+ FilePath -- ^ The GHC Library Dir
+ -> [FilePath] -- ^ The FileNames
+ -> IO ()
+makeVHDLAnnotations libdir filenames =
+ makeVHDL libdir filenames finder
+ where
+ finder = findSpec (hasCLasHAnnotation isTopEntity)
+ (hasCLasHAnnotation isInitState)
+ (isCLasHAnnotation isInitState)
+ (hasCLasHAnnotation isTestInput)
+
+-- | Turn Haskell to VHDL, using the given finder functions to find the Top
+-- Entity, Initial State and Test Inputs in the Haskell Files.
+makeVHDL ::
+ FilePath -- ^ The GHC Library Dir
+ -> [FilePath] -- ^ The Filenames
+ -> Finder
+ -> IO ()
+makeVHDL libdir filenames finder = do
+ start <- Clock.getCurrentTime
+ -- Load the modules
+ (cores, env, specs) <- loadModules libdir filenames (Just finder)
+ -- Translate to VHDL
+ vhdl <- moduleToVHDL env cores specs
+ -- Write VHDL to file. Just use the first entity for the name
+ let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
+ let dir = "./vhdl/" ++ (show top_entity) ++ "/"
+ prepareDir dir
+ mapM_ (writeVHDL dir) vhdl
+ end <- Clock.getCurrentTime
+ trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $
+ return ()
+
+-- | Translate the specified entities in the given modules to VHDL.
+moduleToVHDL ::
+ HscTypes.HscEnv -- ^ The GHC Environment
+ -> [HscTypes.CoreModule] -- ^ The Core Modules
+ -> [EntitySpec] -- ^ The entities to generate
+ -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env cores specs = do
+ (vhdl, count) <- runTranslatorSession env $ do
+ let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
+ -- Store the bindings we loaded
+ tsBindings %= Map.fromList all_bindings
+ let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs
+ tsInitStates %= Map.fromList all_initstates
+ test_binds <- catMaybesM $ Monad.mapM mkTest specs
+ let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
+ vhdl <- case topbinds of
+ [] -> error "Could not find top entity requested"
+ tops -> createDesignFiles (tops ++ test_binds)
+ count <- get tsTransformCounter
+ return (vhdl, count)
+ mapM_ (putStr . render . Ppr.ppr . snd) vhdl
+ putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
+ return vhdl
+ where
+ mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
+ -- Create a testbench for any entry that has test input
+ mkTest (_, _, Nothing) = return Nothing
+ mkTest (Nothing, _, _) = return Nothing
+ mkTest (Just top, _, Just input) = do
+ bndr <- createTestbench Nothing cores input top
+ return $ Just bndr
+
+-- Run the given translator session. Generates a new UniqSupply for that
+-- session.
+runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
+runTranslatorSession env session = do
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate
+ -- a unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
+ let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
+ return $ State.evalState session init_state
+
+-- | Prepares the directory for writing VHDL files. This means creating the
+-- dir if it does not exist and removing all existing .vhdl files from it.
+prepareDir :: String -> IO()
+prepareDir dir = do
+ -- Create the dir if needed
+ Directory.createDirectoryIfMissing True dir
+ -- Find all .vhdl files in the directory
+ files <- Directory.getDirectoryContents dir
+ let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
+ -- Prepend the dirname to the filenames
+ let abs_to_remove = map (FilePath.combine dir) to_remove
+ -- Remove the files
+ mapM_ Directory.removeFile abs_to_remove
+
+-- | Write the given design file to a file with the given name inside the
+-- given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, vhdl) = do
+ -- Find the filename
+ let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
+ -- Write the file
+ FileIO.writeDesignFile vhdl fname
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+module CLasH.Translator.Annotations where
+
+import qualified Language.Haskell.TH as TH
+import Data.Data
+
+data CLasHAnn = TopEntity | InitState TH.Name | TestInput | TestCycles
+ deriving (Show, Data, Typeable)
+
+isTopEntity :: CLasHAnn -> Bool
+isTopEntity TopEntity = True
+isTopEntity _ = False
+
+isInitState :: CLasHAnn -> Bool
+isInitState (InitState _) = True
+isInitState _ = False
+
+isTestInput :: CLasHAnn -> Bool
+isTestInput TestInput = True
+isTestInput _ = False
+
+isTestCycles :: CLasHAnn -> Bool
+isTestCycles TestCycles = True
+isTestCycles _ = False
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE TemplateHaskell #-}
+--
+-- Simple module providing some types used by Translator. These are in a
+-- separate module to prevent circular dependencies in Pretty for example.
+--
+module CLasH.Translator.TranslatorTypes where
+
+-- Standard modules
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Map as Map
+import qualified Data.Accessor.Template
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- GHC API
+import qualified GHC
+import qualified CoreSyn
+import qualified Type
+import qualified HscTypes
+import qualified UniqSupply
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- Local imports
+import CLasH.VHDL.VHDLTypes
+
+-- | A specification of an entity we can generate VHDL for. Consists of the
+-- binder of the top level entity, an optional initial state and an optional
+-- test input.
+type EntitySpec = (Maybe CoreSyn.CoreBndr, Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)], Maybe CoreSyn.CoreExpr)
+
+-- | A function that knows which parts of a module to compile
+type Finder =
+ HscTypes.CoreModule -- ^ The module to look at
+ -> GHC.Ghc [EntitySpec]
+
+-----------------------------------------------------------------------------
+-- The TranslatorSession
+-----------------------------------------------------------------------------
+
+-- A orderable equivalent of CoreSyn's Type for use as a map key
+newtype OrdType = OrdType Type.Type
+instance Eq OrdType where
+ (OrdType a) == (OrdType b) = Type.tcEqType a b
+instance Ord OrdType where
+ compare (OrdType a) (OrdType b) = Type.tcCmpType a b
+
+data HType = AggrType String [HType] |
+ EnumType String [String] |
+ VecType Int HType |
+ UVecType HType |
+ SizedWType Int |
+ RangedWType Int |
+ SizedIType Int |
+ BuiltinType String |
+ StateType
+ deriving (Eq, Ord, Show)
+
+-- A map of a Core type to the corresponding type name, or Nothing when the
+-- type would be empty.
+type TypeMapRec = Maybe (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn))
+type TypeMap = Map.Map HType TypeMapRec
+
+-- A map of a vector Core element type and function name to the coressponding
+-- VHDLId of the function and the function body.
+type TypeFunMap = Map.Map (HType, String) (AST.VHDLId, AST.SubProgBody)
+
+type TfpIntMap = Map.Map OrdType Int
+-- A substate that deals with type generation
+data TypeState = TypeState {
+ -- | A map of Core type -> VHDL Type
+ tsTypes_ :: TypeMap,
+ -- | A list of type declarations
+ tsTypeDecls_ :: [Maybe AST.PackageDecItem],
+ -- | A map of vector Core type -> VHDL type function
+ tsTypeFuns_ :: TypeFunMap,
+ tsTfpInts_ :: TfpIntMap,
+ tsHscEnv_ :: HscTypes.HscEnv
+}
+
+-- Derive accessors
+Data.Accessor.Template.deriveAccessors ''TypeState
+
+-- Define a session
+type TypeSession = State.State TypeState
+-- A global state for the translator
+data TranslatorState = TranslatorState {
+ tsUniqSupply_ :: UniqSupply.UniqSupply
+ , tsType_ :: TypeState
+ , tsBindings_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr
+ , tsNormalized_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr
+ , tsEntityCounter_ :: Integer
+ , tsEntities_ :: Map.Map CoreSyn.CoreBndr Entity
+ , tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr])
+ , tsInitStates_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr
+ , tsTransformCounter_ :: Int -- ^ How many transformations were applied?
+}
+
+-- Derive accessors
+Data.Accessor.Template.deriveAccessors ''TranslatorState
+
+type TranslatorSession = State.State TranslatorState
+
+-----------------------------------------------------------------------------
+-- Some accessors
+-----------------------------------------------------------------------------
+
+-- Does the given binder reference a top level binder in the current
+-- module(s)?
+isTopLevelBinder :: CoreSyn.CoreBndr -> TranslatorSession Bool
+isTopLevelBinder bndr = do
+ bindings <- MonadState.get tsBindings
+ return $ Map.member bndr bindings
+
+-- Finds the value of a global binding, if available
+getGlobalBind :: CoreSyn.CoreBndr -> TranslatorSession (Maybe CoreSyn.CoreExpr)
+getGlobalBind bndr = do
+ bindings <- MonadState.get tsBindings
+ return $ Map.lookup bndr bindings
+
+-- Adds a new global binding with the given value
+addGlobalBind :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession ()
+addGlobalBind bndr expr = MonadState.modify tsBindings (Map.insert bndr expr)
+
+-- Returns a list of all global binders
+getGlobalBinders :: TranslatorSession [CoreSyn.CoreBndr]
+getGlobalBinders = do
+ bindings <- MonadState.get tsBindings
+ return $ Map.keys bindings
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+module CLasH.Utils where
+
+-- Standard Imports
+import qualified Maybe
+import Data.Accessor
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+import qualified Data.Map as Map
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.State as State
+import qualified Debug.Trace as Trace
+
+-- Make a caching version of a stateful computatation.
+makeCached :: (Monad m, Ord k) =>
+ k -- ^ The key to use for the cache
+ -> Accessor s (Map.Map k v) -- ^ The accessor to get at the cache
+ -> State.StateT s m v -- ^ How to compute the value to cache?
+ -> State.StateT s m v -- ^ The resulting value, from the cache or freshly
+ -- computed.
+makeCached key accessor create = do
+ cache <- MonadState.get accessor
+ case Map.lookup key cache of
+ -- Found in cache, just return
+ Just value -> return value
+ -- Not found, compute it and put it in the cache
+ Nothing -> do
+ value <- create
+ MonadState.modify accessor (Map.insert key value)
+ return value
+
+unzipM :: (Monad m) =>
+ m [(a, b)]
+ -> m ([a], [b])
+unzipM = Monad.liftM unzip
+
+catMaybesM :: (Monad m) =>
+ m [Maybe a]
+ -> m [a]
+catMaybesM = Monad.liftM Maybe.catMaybes
+
+concatM :: (Monad m) =>
+ m [[a]]
+ -> m [a]
+concatM = Monad.liftM concat
+
+isJustM :: (Monad m) => m (Maybe a) -> m Bool
+isJustM = Monad.liftM Maybe.isJust
+
+andM, orM :: (Monad m) => m [Bool] -> m Bool
+andM = Monad.liftM and
+orM = Monad.liftM or
+
+-- | Monadic versions of any and all. We reimplement them, since there
+-- is no ready-made lifting function for them.
+allM, anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM f = andM . (mapM f)
+anyM f = orM . (mapM f)
+
+mapAccumLM :: (Monad m) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
+mapAccumLM _ s [] = return (s, [])
+mapAccumLM f s (x:xs) = do
+ (s', y ) <- f s x
+ (s'', ys) <- mapAccumLM f s' xs
+ return (s'', y:ys)
+
+-- Trace the given string if the given bool is True, do nothing
+-- otherwise.
+traceIf :: Bool -> String -> a -> a
+traceIf True = Trace.trace
+traceIf False = flip const
--- /dev/null
+--
+-- This module contains functions that manipulate binders in various ways.
+--
+module CLasH.Utils.Core.BinderTools where
+
+-- Standard modules
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- GHC API
+import qualified CoreSyn
+import qualified Type
+import qualified UniqSupply
+import qualified Unique
+import qualified OccName
+import qualified Name
+import qualified Module
+import qualified Var
+import qualified SrcLoc
+import qualified IdInfo
+import qualified CoreUtils
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+
+-- Create a new Unique
+mkUnique :: TranslatorSession Unique.Unique
+mkUnique = do
+ us <- MonadState.get tsUniqSupply
+ let (us', us'') = UniqSupply.splitUniqSupply us
+ MonadState.set tsUniqSupply us'
+ return $ UniqSupply.uniqFromSupply us''
+
+-- Create a new internal var with the given name and type. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var
+mkInternalVar str ty = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
+
+-- Create a new type variable with the given name and kind. A Unique is
+-- appended to the given name, to ensure uniqueness (not strictly neccesary,
+-- since the Unique is also stored in the name, but this ensures variable
+-- names are unique in the output).
+mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var
+mkTypeVar str kind = do
+ uniq <- mkUnique
+ let occname = OccName.mkVarOcc (str ++ show uniq)
+ let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
+ return $ Var.mkTyVar name kind
+
+-- Creates a binder for the given expression with the given name. This
+-- works for both value and type level expressions, so it can return a Var or
+-- TyVar (which is just an alias for Var).
+mkBinderFor :: CoreSyn.CoreExpr -> String -> TranslatorSession Var.Var
+mkBinderFor (CoreSyn.Type ty) string = mkTypeVar string (Type.typeKind ty)
+mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
+
+-- Creates a reference to the given variable. This works for both a normal
+-- variable as well as a type variable
+mkReferenceTo :: Var.Var -> CoreSyn.CoreExpr
+mkReferenceTo var | Var.isTyVar var = (CoreSyn.Type $ Type.mkTyVarTy var)
+ | otherwise = (CoreSyn.Var var)
+
+cloneVar :: Var.Var -> TranslatorSession Var.Var
+cloneVar v = do
+ uniq <- mkUnique
+ -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
+ -- contains, but vannillaIdInfo is always correct, since it means "no info").
+ return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
+
+-- Creates a new function with the same name as the given binder (but with a
+-- new unique) and with the given function body. Returns the new binder for
+-- this function.
+mkFunction :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreBndr
+mkFunction bndr body = do
+ let ty = CoreUtils.exprType body
+ id <- cloneVar bndr
+ let newid = Var.setVarType id ty
+ addGlobalBind newid body
+ return newid
+
+-- Returns the full name of a NamedThing, in the forum
+-- modulename.occname
+getFullString :: Name.NamedThing a => a -> String
+getFullString thing = modstr ++ occstr
+ where
+ name = Name.getName thing
+ modstr = case Name.nameModule_maybe name of
+ Nothing -> ""
+ Just mod -> Module.moduleNameString (Module.moduleName mod) ++ "."
+ occstr = Name.getOccString name
--- /dev/null
+{-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
+--
+-- This module derives Show instances for CoreSyn types.
+--
+module CLasH.Utils.Core.CoreShow where
+
+-- GHC API
+import qualified BasicTypes
+import qualified CoreSyn
+import qualified TypeRep
+import qualified TyCon
+import qualified HsTypes
+import qualified HsExpr
+import qualified HsBinds
+import qualified SrcLoc
+import qualified RdrName
+import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)
+
+-- Derive Show for core expressions and binders, so we can see the actual
+-- structure.
+deriving instance (Show b) => Show (CoreSyn.Expr b)
+deriving instance (Show b) => Show (CoreSyn.Bind b)
+deriving instance Show TypeRep.Type
+deriving instance (Show n, OutputableBndr n) => Show (HsTypes.HsType n)
+deriving instance (Show n, OutputableBndr n) => Show (HsTypes.ConDeclField n)
+deriving instance (Show x) => Show (SrcLoc.Located x)
+deriving instance (Show x, OutputableBndr x) => Show (HsExpr.StmtLR x x)
+deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsTupArg x)
+deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsExpr x)
+deriving instance Show (RdrName.RdrName)
+deriving instance (Show idL, Show idR, OutputableBndr idL, OutputableBndr idR) => Show (HsBinds.HsBindLR idL idR)
+deriving instance Show CoreSyn.Note
+deriving instance Show TyCon.SynTyConRhs
+
+
+-- Implement dummy shows, since deriving them will need loads of other shows
+-- as well.
+instance Show TypeRep.PredType where
+ show t = "_PredType:(" ++ showSDoc (ppr t) ++ ")"
+instance Show TyCon.TyCon where
+ show t | TyCon.isAlgTyCon t && not (TyCon.isTupleTyCon t) =
+ showtc "AlgTyCon" ""
+ | TyCon.isCoercionTyCon t =
+ showtc "CoercionTyCon" ""
+ | TyCon.isSynTyCon t =
+ showtc "SynTyCon" (", synTcRhs = " ++ synrhs)
+ | TyCon.isTupleTyCon t =
+ showtc "TupleTyCon" ""
+ | TyCon.isFunTyCon t =
+ showtc "FunTyCon" ""
+ | TyCon.isPrimTyCon t =
+ showtc "PrimTyCon" ""
+ | TyCon.isSuperKindTyCon t =
+ showtc "SuperKindTyCon" ""
+ | otherwise =
+ "_Nonexistant tycon?:(" ++ showSDoc (ppr t) ++ ")_"
+ where
+ showtc con extra = "(" ++ con ++ " {tyConName = " ++ name ++ extra ++ ", ...})"
+ name = show (TyCon.tyConName t)
+ synrhs = show (TyCon.synTyConRhs t)
+instance Show BasicTypes.Boxity where
+ show b = "_Boxity"
+instance Show HsTypes.HsExplicitForAll where
+ show b = "_HsExplicitForAll"
+instance Show HsExpr.HsArrAppType where
+ show b = "_HsArrAppType"
+instance Show (HsExpr.MatchGroup x) where
+ show b = "_HsMatchGroup"
+instance Show (HsExpr.GroupByClause x) where
+ show b = "_GroupByClause"
+instance Show (HsExpr.HsStmtContext x) where
+ show b = "_HsStmtContext"
+instance Show (HsBinds.Prag) where
+ show b = "_Prag"
+instance Show (HsExpr.GRHSs id) where
+ show b = "_GRHSs"
+
+
+instance (Outputable x) => Show x where
+ show x = "__" ++ showSDoc (ppr x) ++ "__"
--- /dev/null
+{-# LANGUAGE PatternGuards, TypeSynonymInstances #-}
+-- | This module provides a number of functions to find out things about Core
+-- programs. This module does not provide the actual plumbing to work with
+-- Core and Haskell (it uses HsTools for this), but only the functions that
+-- know about various libraries and know which functions to call.
+module CLasH.Utils.Core.CoreTools where
+
+--Standard modules
+import qualified Maybe
+import qualified System.IO.Unsafe
+import qualified Data.Map as Map
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- GHC API
+import qualified GHC
+import qualified Type
+import qualified TcType
+import qualified HsExpr
+import qualified HsTypes
+import qualified HscTypes
+import qualified Name
+import qualified Id
+import qualified TyCon
+import qualified DataCon
+import qualified TysWiredIn
+import qualified DynFlags
+import qualified SrcLoc
+import qualified CoreSyn
+import qualified Var
+import qualified IdInfo
+import qualified VarSet
+import qualified CoreUtils
+import qualified CoreFVs
+import qualified Literal
+import qualified MkCore
+import qualified VarEnv
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.Utils.GhcTools
+import CLasH.Utils.Core.BinderTools
+import CLasH.Utils.HsTools
+import CLasH.Utils.Pretty
+import CLasH.Utils
+import qualified CLasH.Utils.Core.BinderTools as BinderTools
+
+-- | A single binding, used as a shortcut to simplify type signatures.
+type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr)
+
+-- | Evaluate a core Type representing type level int from the tfp
+-- library to a real int. Checks if the type really is a Dec type and
+-- caches the results.
+tfp_to_int :: Type.Type -> TypeSession Int
+tfp_to_int ty = do
+ hscenv <- MonadState.get tsHscEnv
+ let norm_ty = normalize_tfp_int hscenv ty
+ case Type.splitTyConApp_maybe norm_ty of
+ Just (tycon, args) -> do
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "Dec" ->
+ tfp_to_int' ty
+ otherwise -> do
+ return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
+ Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
+
+-- | Evaluate a core Type representing type level int from the tfp
+-- library to a real int. Caches the results. Do not use directly, use
+-- tfp_to_int instead.
+tfp_to_int' :: Type.Type -> TypeSession Int
+tfp_to_int' ty = do
+ lens <- MonadState.get tsTfpInts
+ hscenv <- MonadState.get tsHscEnv
+ let norm_ty = normalize_tfp_int hscenv ty
+ let existing_len = Map.lookup (OrdType norm_ty) lens
+ case existing_len of
+ Just len -> return len
+ Nothing -> do
+ let new_len = eval_tfp_int hscenv ty
+ MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+ return new_len
+
+-- | Evaluate a core Type representing type level int from the tfp
+-- library to a real int. Do not use directly, use tfp_to_int instead.
+eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
+eval_tfp_int env ty =
+ unsafeRunGhc libdir $ do
+ GHC.setSession env
+ -- Automatically import modules for any fully qualified identifiers
+ setDynFlag DynFlags.Opt_ImplicitImportQualified
+
+ let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT"
+ let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
+ let undef = hsTypedUndef $ coreToHsType ty
+ let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
+ let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
+ let expr = HsExpr.ExprWithTySig app int_ty
+ core <- toCore expr
+ execCore core
+ where
+ libdir = DynFlags.topDir dynflags
+ dynflags = HscTypes.hsc_dflags env
+
+normalize_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
+normalize_tfp_int env ty =
+ System.IO.Unsafe.unsafePerformIO $
+ normalizeType env ty
+
+sized_word_len_ty :: Type.Type -> Type.Type
+sized_word_len_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
+ [len] = args
+
+sized_int_len_ty :: Type.Type -> Type.Type
+sized_int_len_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
+ [len] = args
+
+ranged_word_bound_ty :: Type.Type -> Type.Type
+ranged_word_bound_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
+ [len] = args
+
+tfvec_len_ty :: Type.Type -> Type.Type
+tfvec_len_ty ty = len
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
+ [len, el_ty] = args
+
+-- | Get the element type of a TFVec type
+tfvec_elem :: Type.Type -> Type.Type
+tfvec_elem ty = el_ty
+ where
+ args = case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> args
+ Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
+ [len, el_ty] = args
+
+-- Is the given core expression a lambda abstraction?
+is_lam :: CoreSyn.CoreExpr -> Bool
+is_lam (CoreSyn.Lam _ _) = True
+is_lam _ = False
+
+-- Is the given core expression a let expression?
+is_let :: CoreSyn.CoreExpr -> Bool
+is_let (CoreSyn.Let _ _) = True
+is_let _ = False
+
+-- Is the given core expression of a function type?
+is_fun :: CoreSyn.CoreExpr -> Bool
+-- Treat Type arguments differently, because exprType is not defined for them.
+is_fun (CoreSyn.Type _) = False
+is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
+
+-- Is the given core expression polymorphic (i.e., does it accept type
+-- arguments?).
+is_poly :: CoreSyn.CoreExpr -> Bool
+-- Treat Type arguments differently, because exprType is not defined for them.
+is_poly (CoreSyn.Type _) = False
+is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
+
+-- Is the given core expression a variable reference?
+is_var :: CoreSyn.CoreExpr -> Bool
+is_var (CoreSyn.Var _) = True
+is_var _ = False
+
+is_lit :: CoreSyn.CoreExpr -> Bool
+is_lit (CoreSyn.Lit _) = True
+is_lit _ = False
+
+-- Can the given core expression be applied to something? This is true for
+-- applying to a value as well as a type.
+is_applicable :: CoreSyn.CoreExpr -> Bool
+is_applicable expr = is_fun expr || is_poly expr
+
+-- Is the given core expression a variable or an application?
+is_simple :: CoreSyn.CoreExpr -> Bool
+is_simple (CoreSyn.App _ _) = True
+is_simple (CoreSyn.Var _) = True
+is_simple (CoreSyn.Cast expr _) = is_simple expr
+is_simple _ = False
+
+-- Does the given CoreExpr have any free type vars?
+has_free_tyvars :: CoreSyn.CoreExpr -> Bool
+has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
+
+-- Does the given type have any free type vars?
+ty_has_free_tyvars :: Type.Type -> Bool
+ty_has_free_tyvars = not . VarSet.isEmptyVarSet . Type.tyVarsOfType
+
+-- Does the given CoreExpr have any free local vars?
+has_free_vars :: CoreSyn.CoreExpr -> Bool
+has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
+
+-- Does the given expression use any of the given binders?
+expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool
+expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))
+
+-- Turns a Var CoreExpr into the Id inside it. Will of course only work for
+-- simple Var CoreExprs, not complexer ones.
+exprToVar :: CoreSyn.CoreExpr -> Var.Id
+exprToVar (CoreSyn.Var id) = id
+exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
+
+-- Turns a Lit CoreExpr into the Literal inside it.
+exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
+exprToLit (CoreSyn.Lit lit) = lit
+exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
+
+-- Removes all the type and dictionary arguments from the given argument list,
+-- leaving only the normal value arguments. The type given is the type of the
+-- expression applied to this argument list.
+get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
+get_val_args ty args = drop n args
+ where
+ (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
+ -- The first (length tyvars) arguments should be types, the next
+ -- (length predtypes) arguments should be dictionaries. We drop this many
+ -- arguments, to get at the value arguments.
+ n = length tyvars + length predtypes
+
+-- Finds out what literal Integer this expression represents.
+getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer
+getIntegerLiteral expr =
+ case CoreSyn.collectArgs expr of
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)])
+ | getFullString f == "GHC.Integer.smallInteger" -> return integer
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)])
+ | getFullString f == "GHC.Integer.int64ToInteger" -> return integer
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)])
+ | getFullString f == "GHC.Integer.wordToInteger" -> return integer
+ (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)])
+ | getFullString f == "GHC.Integer.word64ToInteger" -> return integer
+ -- fromIntegerT returns the integer corresponding to the type of its
+ -- (third) argument. Since it is polymorphic, the type of that
+ -- argument is passed as the first argument, so we can just use that
+ -- one.
+ (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg])
+ | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do
+ int <- MonadState.lift tsType $ tfp_to_int dec_ty
+ return $ toInteger int
+ _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr
+
+reduceCoreListToHsList ::
+ [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
+ -> CoreSyn.CoreExpr -- ^ The refence to atleast one of the nodes
+ -> TranslatorSession [CoreSyn.CoreExpr]
+reduceCoreListToHsList cores app@(CoreSyn.App _ _) = do {
+ ; let { (fun, args) = CoreSyn.collectArgs app
+ ; len = length args
+ } ;
+ ; case len of
+ 3 -> do {
+ ; let topelem = args!!1
+ ; case (args!!2) of
+ (varz@(CoreSyn.Var id)) -> do {
+ ; binds <- mapM (findExpr (isVarName id)) cores
+ ; otherelems <- reduceCoreListToHsList cores (head (Maybe.catMaybes binds))
+ ; return (topelem:otherelems)
+ }
+ (appz@(CoreSyn.App _ _)) -> do {
+ ; otherelems <- reduceCoreListToHsList cores appz
+ ; return (topelem:otherelems)
+ }
+ otherwise -> return [topelem]
+ }
+ otherwise -> return []
+ }
+ where
+ isVarName :: Monad m => Var.Var -> Var.Var -> m Bool
+ isVarName lookfor bind = return $ (Var.varName lookfor) == (Var.varName bind)
+
+reduceCoreListToHsList _ _ = return []
+
+-- Is the given var the State data constructor?
+isStateCon :: Var.Var -> Bool
+isStateCon var =
+ -- See if it is a DataConWrapId (not DataConWorkId, since State is a
+ -- newtype).
+ case Id.idDetails var of
+ IdInfo.DataConWrapId dc ->
+ -- See if the datacon is the State datacon from the State type.
+ let tycon = DataCon.dataConTyCon dc
+ tyname = Name.getOccString tycon
+ dcname = Name.getOccString dc
+ in case (tyname, dcname) of
+ ("State", "State") -> True
+ _ -> False
+ _ -> False
+
+-- | Is the given type a State type?
+isStateType :: Type.Type -> Bool
+-- Resolve any type synonyms remaining
+isStateType ty | Just ty' <- Type.tcView ty = isStateType ty'
+isStateType ty = Maybe.isJust $ do
+ -- Split the type. Don't use normal splitAppTy, since that looks through
+ -- newtypes, and we want to see the State newtype.
+ (typef, _) <- Type.repSplitAppTy_maybe ty
+ -- See if the applied type is a type constructor
+ (tycon, _) <- Type.splitTyConApp_maybe typef
+ if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State"
+ then
+ Just ()
+ else
+ Nothing
+
+-- | Does the given TypedThing have a State type?
+hasStateType :: (TypedThing t) => t -> Bool
+hasStateType expr = case getType expr of
+ Nothing -> False
+ Just ty -> isStateType ty
+
+
+-- | Flattens nested lets into a single list of bindings. The expression
+-- passed does not have to be a let expression, if it isn't an empty list of
+-- bindings is returned.
+flattenLets ::
+ CoreSyn.CoreExpr -- ^ The expression to flatten.
+ -> ([Binding], CoreSyn.CoreExpr) -- ^ The bindings and resulting expression.
+flattenLets (CoreSyn.Let binds expr) =
+ (bindings ++ bindings', expr')
+ where
+ -- Recursively flatten the contained expression
+ (bindings', expr') =flattenLets expr
+ -- Flatten our own bindings to remove the Rec / NonRec constructors
+ bindings = CoreSyn.flattenBinds [binds]
+flattenLets expr = ([], expr)
+
+-- | Create bunch of nested non-recursive let expressions from the given
+-- bindings. The first binding is bound at the highest level (and thus
+-- available in all other bindings).
+mkNonRecLets :: [Binding] -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr
+mkNonRecLets bindings expr = MkCore.mkCoreLets binds expr
+ where
+ binds = map (uncurry CoreSyn.NonRec) bindings
+
+-- | A class of things that (optionally) have a core Type. The type is
+-- optional, since Type expressions don't have a type themselves.
+class TypedThing t where
+ getType :: t -> Maybe Type.Type
+
+instance TypedThing CoreSyn.CoreExpr where
+ getType (CoreSyn.Type _) = Nothing
+ getType expr = Just $ CoreUtils.exprType expr
+
+instance TypedThing CoreSyn.CoreBndr where
+ getType = return . Id.idType
+
+instance TypedThing Type.Type where
+ getType = return . id
+
+-- | Generate new uniques for all binders in the given expression.
+-- Does not support making type variables unique, though this could be
+-- supported if required (by passing a CoreSubst.Subst instead of VarEnv to
+-- genUniques' below).
+genUniques :: CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr
+genUniques = genUniques' VarEnv.emptyVarEnv
+
+-- | A helper function to generate uniques, that takes a VarEnv containing the
+-- substitutions already performed.
+genUniques' :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr
+genUniques' subst (CoreSyn.Var f) = do
+ -- Replace the binder with its new value, if applicable.
+ let f' = VarEnv.lookupWithDefaultVarEnv subst f f
+ return (CoreSyn.Var f')
+-- Leave literals untouched
+genUniques' subst (CoreSyn.Lit l) = return $ CoreSyn.Lit l
+genUniques' subst (CoreSyn.App f arg) = do
+ -- Only work on subexpressions
+ f' <- genUniques' subst f
+ arg' <- genUniques' subst arg
+ return (CoreSyn.App f' arg')
+-- Don't change type abstractions
+genUniques' subst expr@(CoreSyn.Lam bndr res) | CoreSyn.isTyVar bndr = return expr
+genUniques' subst (CoreSyn.Lam bndr res) = do
+ -- Generate a new unique for the bound variable
+ (subst', bndr') <- genUnique subst bndr
+ res' <- genUniques' subst' res
+ return (CoreSyn.Lam bndr' res')
+genUniques' subst (CoreSyn.Let (CoreSyn.NonRec bndr bound) res) = do
+ -- Make the binders unique
+ (subst', bndr') <- genUnique subst bndr
+ bound' <- genUniques' subst' bound
+ res' <- genUniques' subst' res
+ return $ CoreSyn.Let (CoreSyn.NonRec bndr' bound') res'
+genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
+ -- Make each of the binders unique
+ (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)
+ bounds' <- mapM (genUniques' subst' . snd) binds
+ res' <- genUniques' subst' res
+ let binds' = zip bndrs' bounds'
+ return $ CoreSyn.Let (CoreSyn.Rec binds') res'
+genUniques' subst (CoreSyn.Case scrut bndr ty alts) = do
+ -- Process the scrutinee with the original substitution, since non of the
+ -- binders bound in the Case statement is in scope in the scrutinee.
+ scrut' <- genUniques' subst scrut
+ -- Generate a new binder for the scrutinee
+ (subst', bndr') <- genUnique subst bndr
+ -- Process each of the alts
+ alts' <- mapM (doalt subst') alts
+ return $ CoreSyn.Case scrut' bndr' ty alts'
+ where
+ doalt subst (con, bndrs, expr) = do
+ (subst', bndrs') <- mapAccumLM genUnique subst bndrs
+ expr' <- genUniques' subst' expr
+ -- Note that we don't return subst', since bndrs are only in scope in
+ -- expr.
+ return (con, bndrs', expr')
+genUniques' subst (CoreSyn.Cast expr coercion) = do
+ expr' <- genUniques' subst expr
+ -- Just process the casted expression
+ return $ CoreSyn.Cast expr' coercion
+genUniques' subst (CoreSyn.Note note expr) = do
+ expr' <- genUniques' subst expr
+ -- Just process the annotated expression
+ return $ CoreSyn.Note note expr'
+-- Leave types untouched
+genUniques' subst expr@(CoreSyn.Type _) = return expr
+
+-- Generate a new unique for the given binder, and extend the given
+-- substitution to reflect this.
+genUnique :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> TranslatorSession (VarEnv.VarEnv CoreSyn.CoreBndr, CoreSyn.CoreBndr)
+genUnique subst bndr = do
+ bndr' <- BinderTools.cloneVar bndr
+ -- Replace all occurences of the old binder with a reference to the new
+ -- binder.
+ let subst' = VarEnv.extendVarEnv subst bndr bndr'
+ return (subst', bndr')
+
+-- Create a "selector" case that selects the ith field from a datacon
+mkSelCase :: CoreSyn.CoreExpr -> Int -> TranslatorSession CoreSyn.CoreExpr
+mkSelCase scrut i = do
+ let scrut_ty = CoreUtils.exprType scrut
+ case Type.splitTyConApp_maybe scrut_ty of
+ -- The scrutinee should have a type constructor. We keep the type
+ -- arguments around so we can instantiate the field types below
+ Just (tycon, tyargs) -> case TyCon.tyConDataCons tycon of
+ -- The scrutinee type should have a single dataconstructor,
+ -- otherwise we can't construct a valid selector case.
+ [datacon] -> do
+ let field_tys = DataCon.dataConInstOrigArgTys datacon tyargs
+ -- Create a list of wild binders for the fields we don't want
+ let wildbndrs = map MkCore.mkWildBinder field_tys
+ -- Create a single binder for the field we want
+ sel_bndr <- mkInternalVar "sel" (field_tys!!i)
+ -- Create a wild binder for the scrutinee
+ let scrut_bndr = MkCore.mkWildBinder scrut_ty
+ -- Create the case expression
+ let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs
+ return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]
+ dcs -> error $ "CoreTools.mkSelCase: Scrutinee type must have exactly one datacon. Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "' Datacons: " ++ (show dcs) ++ " Type: " ++ (pprString scrut_ty)
+ Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)
--- /dev/null
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CLasH.Utils.GhcTools where
+
+-- Standard modules
+import qualified Monad
+import qualified System.IO.Unsafe
+import qualified Language.Haskell.TH as TH
+import qualified Maybe
+
+-- GHC API
+import qualified Annotations
+import qualified CoreSyn
+import qualified CoreUtils
+import qualified DynFlags
+import qualified HscTypes
+import qualified GHC
+import qualified Name
+import qualified Serialized
+import qualified Var
+import qualified Outputable
+import qualified Class
+
+-- Local Imports
+import CLasH.Utils.Pretty
+import CLasH.Translator.TranslatorTypes
+import CLasH.Translator.Annotations
+import CLasH.Utils
+
+listBindings :: FilePath -> [FilePath] -> IO ()
+listBindings libdir filenames = do
+ (cores,_,_) <- loadModules libdir filenames Nothing
+ let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+ mapM listBinding binds
+ putStr "\n=========================\n"
+ let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
+ mapM listClass classes
+ return ()
+
+listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
+listBinding (b, e) = do
+ putStr "\nBinder: "
+ putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]"
+ putStr "\nType of Binder: \n"
+ putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
+ putStr "\n\nExpression: \n"
+ putStr $ prettyShow e
+ putStr "\n\n"
+ putStr $ Outputable.showSDoc $ Outputable.ppr e
+ putStr "\n\nType of Expression: \n"
+ putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
+ putStr "\n\n"
+
+listClass :: Class.Class -> IO ()
+listClass c = do
+ putStr "\nClass: "
+ putStr $ show (Class.className c)
+ putStr "\nSelectors: "
+ putStr $ show (Class.classSelIds c)
+ putStr "\n"
+
+-- | Show the core structure of the given binds in the given file.
+listBind :: FilePath -> [FilePath] -> String -> IO ()
+listBind libdir filenames name = do
+ (cores,_,_) <- loadModules libdir filenames Nothing
+ bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
+ mapM_ listBinding bindings
+ return ()
+
+-- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
+-- be no standard function to do exactly this.
+setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
+setDynFlag dflag = do
+ dflags <- GHC.getSessionDynFlags
+ let dflags' = DynFlags.dopt_set dflags dflag
+ GHC.setSessionDynFlags dflags'
+ return ()
+
+-- We don't want the IO monad sprinkled around everywhere, so we hide it.
+-- This should be safe as long as we only do simple things in the GhcMonad
+-- such as interface lookups and evaluating simple expressions that
+-- don't have side effects themselves (Or rather, that don't use
+-- unsafePerformIO themselves, since normal side effectful function would
+-- just return an IO monad when they are evaluated).
+unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
+unsafeRunGhc libDir m =
+ System.IO.Unsafe.unsafePerformIO $
+ GHC.runGhc (Just libDir) $ do
+ dflags <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags dflags
+ m
+
+-- | Loads the given files and turns it into a core module
+loadModules ::
+ FilePath -- ^ The GHC Library directory
+ -> [String] -- ^ The files that need to be loaded
+ -> Maybe Finder -- ^ What entities to build?
+ -> IO ( [HscTypes.CoreModule]
+ , HscTypes.HscEnv
+ , [EntitySpec]
+ ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
+loadModules libdir filenames finder =
+ GHC.defaultErrorHandler DynFlags.defaultDynFlags $
+ GHC.runGhc (Just libdir) $ do
+ dflags <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags dflags
+ cores <- mapM GHC.compileToCoreModule filenames
+ env <- GHC.getSession
+ specs <- case finder of
+ Nothing -> return []
+ Just f -> concatM $ mapM f cores
+ return (cores, env, specs)
+
+findBinds ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe [CoreSyn.CoreBndr])
+findBinds criteria core = do
+ binders <- findBinder criteria core
+ case binders of
+ [] -> return Nothing
+ bndrs -> return $ Just $ map fst bndrs
+
+findBind ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe CoreSyn.CoreBndr)
+findBind criteria core = do
+ binders <- findBinds criteria core
+ case binders of
+ Nothing -> return Nothing
+ (Just bndrs) -> return $ Just $ head bndrs
+
+findExprs ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe [CoreSyn.CoreExpr])
+findExprs criteria core = do
+ binders <- findBinder criteria core
+ case binders of
+ [] -> return Nothing
+ bndrs -> return $ Just (map snd bndrs)
+
+findExpr ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe CoreSyn.CoreExpr)
+findExpr criteria core = do
+ exprs <- findExprs criteria core
+ case exprs of
+ Nothing -> return Nothing
+ (Just exprs) -> return $ Just $ head exprs
+
+findAnns ::
+ Monad m =>
+ (Var.Var -> m [CLasHAnn])
+ -> HscTypes.CoreModule
+ -> m [CLasHAnn]
+findAnns criteria core = do
+ let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
+ anns <- Monad.mapM (criteria . fst) binds
+ case anns of
+ [] -> return []
+ xs -> return $ concat xs
+
+-- | Find a binder in module according to a certain criteria
+findBinder ::
+ Monad m =>
+ (Var.Var -> m Bool) -- ^ The criteria to filter the binders on
+ -> HscTypes.CoreModule -- ^ The module to be inspected
+ -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
+findBinder criteria core = do
+ let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
+ Monad.filterM (criteria . fst) binds
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+isCLasHAnnotation ::
+ GHC.GhcMonad m =>
+ (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
+ -> Var.Var -- ^ The Binder
+ -> m [CLasHAnn] -- ^ Indicates if binder has the Annotation
+isCLasHAnnotation clashAnn var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let annEnts = filter clashAnn anns
+ return annEnts
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+hasCLasHAnnotation ::
+ GHC.GhcMonad m =>
+ (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
+ -> Var.Var -- ^ The Binder
+ -> m Bool -- ^ Indicates if binder has the Annotation
+hasCLasHAnnotation clashAnn var = do
+ anns <- isCLasHAnnotation clashAnn var
+ case anns of
+ [] -> return False
+ xs -> return True
+
+-- | Determine if a binder has a certain name
+hasVarName ::
+ Monad m =>
+ String -- ^ The name the binder has to have
+ -> Var.Var -- ^ The Binder
+ -> m Bool -- ^ Indicate if the binder has the name
+hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
+
+
+findInitStates ::
+ (Var.Var -> GHC.Ghc Bool) ->
+ (Var.Var -> GHC.Ghc [CLasHAnn]) ->
+ HscTypes.CoreModule ->
+ GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
+findInitStates statec annsc mod = do
+ states <- findBinds statec mod
+ anns <- findAnns annsc mod
+ let funs = Maybe.catMaybes (map extractInits anns)
+ exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
+ let exprs = Maybe.catMaybes exprs'
+ let inits = zipMWith (\a b -> (a,b)) states exprs
+ return inits
+ where
+ extractInits :: CLasHAnn -> Maybe TH.Name
+ extractInits (InitState x) = Just x
+ extractInits _ = Nothing
+ zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
+ zipMWith _ Nothing _ = Nothing
+ zipMWith f (Just as) bs = Just $ zipWith f as bs
+
+-- | Make a complete spec out of a three conditions
+findSpec ::
+ (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
+ -> Finder
+
+findSpec topc statec annsc testc mod = do
+ top <- findBind topc mod
+ state <- findExprs statec mod
+ anns <- findAnns annsc mod
+ test <- findExpr testc mod
+ inits <- findInitStates statec annsc mod
+ return [(top, inits, test)]
+ -- case top of
+ -- Just t -> return [(t, state, test)]
+ -- Nothing -> return error $ "Could not find top entity requested"
--- /dev/null
+module CLasH.Utils.HsTools where
+
+-- Standard modules
+import qualified Unsafe.Coerce
+import qualified Maybe
+
+-- GHC API
+import qualified GHC
+import qualified HscMain
+import qualified HscTypes
+import qualified DynFlags
+import qualified FastString
+import qualified StringBuffer
+import qualified MonadUtils
+import Outputable ( showSDoc, ppr )
+import qualified Outputable
+-- Lexer & Parser, i.e. up to HsExpr
+import qualified Lexer
+import qualified Parser
+-- HsExpr representation, renaming, typechecking and desugaring
+-- (i.e., everything up to Core).
+import qualified HsSyn
+import qualified HsExpr
+import qualified HsTypes
+import qualified HsBinds
+import qualified TcRnMonad
+import qualified TcRnTypes
+import qualified RnExpr
+import qualified RnEnv
+import qualified TcExpr
+import qualified TcEnv
+import qualified TcSimplify
+import qualified TcTyFuns
+import qualified Desugar
+import qualified PrelNames
+import qualified Module
+import qualified OccName
+import qualified RdrName
+import qualified Name
+import qualified SrcLoc
+import qualified LoadIface
+import qualified BasicTypes
+-- Core representation and handling
+import qualified CoreSyn
+import qualified Id
+import qualified Type
+import qualified TyCon
+
+-- | Translate a HsExpr to a Core expression. This does renaming, type
+-- checking, simplification of class instances and desugaring. The result is
+-- a let expression that holds the given expression and a number of binds that
+-- are needed for any type classes used to work. For example, the HsExpr:
+-- \x = x == (1 :: Int)
+-- will result in the CoreExpr
+-- let
+-- $dInt = ...
+-- (==) = Prelude.(==) Int $dInt
+-- in
+-- \x = (==) x 1
+toCore ::
+ HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
+ -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
+toCore expr = do
+ env <- GHC.getSession
+ let icontext = HscTypes.hsc_IC env
+
+ (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
+ -- Translage the TcRn (typecheck-rename) monad into an IO monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+ (tc_expr, insts) <- TcRnMonad.getLIE $ do
+ -- Rename the expression, resulting in a HsExpr Name
+ (rn_expr, freevars) <- RnExpr.rnExpr expr
+ -- Typecheck the expression, resulting in a HsExpr Id and a list of
+ -- Insts
+ (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
+ return res
+ -- Translate the instances into bindings
+ --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
+ binds <- TcSimplify.tcSimplifyTop insts
+ return (binds, tc_expr)
+
+ -- Create a let expression with the extra binds (for polymorphism etc.) and
+ -- the resulting expression.
+ let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
+ (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
+ tc_expr
+ -- Desugar the expression, resulting in core.
+ let rdr_env = HscTypes.ic_rn_gbl_env icontext
+ HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
+
+
+-- | Create an Id from a RdrName. Might not work for DataCons...
+mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
+mkId rdr_name = do
+ env <- GHC.getSession
+ HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
+ -- Translage the TcRn (typecheck-rename) monad in an IO monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
+ -- Automatically import all available modules, so fully qualified names
+ -- always work
+ TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
+ -- Lookup a Name for the RdrName. This finds the package (version) in
+ -- which the name resides.
+ name <- RnEnv.lookupGlobalOccRn rdr_name
+ -- Lookup an Id for the Name. This finds out the the type of the thing
+ -- we're looking for.
+ --
+ -- Note that tcLookupId doesn't seem to work for DataCons. See source for
+ -- tcLookupId to find out.
+ TcEnv.tcLookupId name
+
+normalizeType ::
+ HscTypes.HscEnv
+ -> Type.Type
+ -> IO Type.Type
+normalizeType env ty = do
+ (err, nty) <- MonadUtils.liftIO $
+ -- Initialize the typechecker monad
+ TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+ -- Normalize the type
+ (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
+ return nty
+ let normalized_ty = Maybe.fromJust nty
+ return normalized_ty
+
+-- | Translate a core Type to an HsType. Far from complete so far.
+coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
+-- Translate TyConApps
+coreToHsType ty = case Type.splitTyConApp_maybe ty of
+ Just (tycon, tys) ->
+ foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
+ where
+ tycon_name = TyCon.tyConName tycon
+ mod_name = Module.moduleName $ Name.nameModule tycon_name
+ occ_name = Name.nameOccName tycon_name
+ tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
+ tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
+ Nothing -> error "HsTools.coreToHsType Cannot translate non-tycon type"
+
+-- | Evaluate a CoreExpr and return its value. For this to work, the caller
+-- should already know the result type for sure, since the result value is
+-- unsafely coerced into this type.
+execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
+execCore expr = do
+ -- Setup session flags (yeah, this seems like a noop, but
+ -- setSessionDynFlags really does some extra work...)
+ dflags <- GHC.getSessionDynFlags
+ GHC.setSessionDynFlags dflags
+ -- Compile the expressions. This runs in the IO monad, but really wants
+ -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
+ -- understand what it means, but it works.
+ env <- GHC.getSession
+ let srcspan = SrcLoc.noSrcSpan
+ hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
+ let res = Unsafe.Coerce.unsafeCoerce hval :: Int
+ return $ Unsafe.Coerce.unsafeCoerce hval
+
+-- These functions build (parts of) a LHSExpr RdrName.
+
+-- | A reference to the Prelude.undefined function.
+hsUndef :: HsExpr.LHsExpr RdrName.RdrName
+hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
+
+-- | A typed reference to the Prelude.undefined function.
+hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
+hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
+
+-- | Create a qualified RdrName from a module name and a variable name
+mkRdrName :: String -> String -> RdrName.RdrName
+mkRdrName mod var =
+ RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
+
+-- These three functions are simplified copies of those in HscMain, because
+-- those functions are not exported. These versions have all error handling
+-- removed.
+hscParseType = hscParseThing Parser.parseType
+hscParseStmt = hscParseThing Parser.parseStmt
+
+hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
+hscParseThing parser dflags str = do
+ buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
+ let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
+ let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
+ return thing
+
+-- | This function imports the module with the given name, for the renamer /
+-- typechecker to use. It also imports any "orphans" and "family instances"
+-- from modules included by this module, but not the actual modules
+-- themselves. I'm not 100% sure how this works, but it seems that any
+-- functions defined in included modules are available just by loading the
+-- original module, and by doing this orphan stuff, any (type family or class)
+-- instances are available as well.
+--
+-- Most of the code is based on tcRnImports and rnImportDecl, but those
+-- functions do a lot more (which I hope we won't need...).
+importModule :: Module.ModuleName -> TcRnTypes.RnM ()
+importModule mod = do
+ let reason = Outputable.text "Hardcoded import" -- Used for trace output
+ let pkg = Nothing
+ -- Load the interface.
+ iface <- LoadIface.loadSrcInterface reason mod False pkg
+ -- Load orphan an familiy instance dependencies as well. I think these
+ -- dependencies are needed for the type checker to know all instances. Any
+ -- other instances (on other packages) are only useful to the
+ -- linker, so we can probably safely ignore them here. Dependencies within
+ -- the same package are also listed in deps, but I'm not so sure what to do
+ -- with them.
+ let deps = HscTypes.mi_deps iface
+ let orphs = HscTypes.dep_orphs deps
+ let finsts = HscTypes.dep_finsts deps
+ LoadIface.loadOrphanModules orphs False
+ LoadIface.loadOrphanModules finsts True
--- /dev/null
+module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where
+
+-- Standard imports
+import qualified Data.Map as Map
+import Text.PrettyPrint.HughesPJClass
+
+-- GHC API
+import qualified CoreSyn
+import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
+
+-- VHDL Imports
+import qualified Language.VHDL.Ppr as Ppr
+import qualified Language.VHDL.AST as AST
+import qualified Language.VHDL.AST.Ppr
+
+-- Local imports
+import CLasH.VHDL.VHDLTypes
+import CLasH.Utils.Core.CoreShow
+
+-- | A version of the default pPrintList method, which uses a custom function
+-- f instead of pPrint to print elements.
+printList :: (a -> Doc) -> [a] -> Doc
+printList f = brackets . fsep . punctuate comma . map f
+
+{-
+instance Pretty FuncData where
+ pPrint (FuncData flatfunc entity arch) =
+ text "Flattened: " $$ nest 15 (ppffunc flatfunc)
+ $+$ text "Entity" $$ nest 15 (ppent entity)
+ $+$ pparch arch
+ where
+ ppffunc (Just f) = pPrint f
+ ppffunc Nothing = text "Nothing"
+ ppent (Just e) = pPrint e
+ ppent Nothing = text "Nothing"
+ pparch Nothing = text "VHDL architecture not present"
+ pparch (Just _) = text "VHDL architecture present"
+-}
+
+instance Pretty Entity where
+ pPrint (Entity id args res decl) =
+ text "Entity: " $$ nest 10 (pPrint id)
+ $+$ text "Args: " $$ nest 10 (pPrint args)
+ $+$ text "Result: " $$ nest 10 (pPrint res)
+ $+$ text "Declaration not shown"
+
+instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
+ pPrint (CoreSyn.NonRec b expr) =
+ text "NonRec: " $$ nest 10 (prettyBind (b, expr))
+ pPrint (CoreSyn.Rec binds) =
+ text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
+
+instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
+ pPrint = text . show
+
+instance Pretty AST.VHDLId where
+ pPrint id = Ppr.ppr id
+
+instance Pretty AST.VHDLName where
+ pPrint name = Ppr.ppr name
+
+prettyBind :: (Show b, Show e) => (b, e) -> Doc
+prettyBind (b, expr) =
+ text b' <> text " = " <> text expr'
+ where
+ b' = show b
+ expr' = show expr
+
+instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
+ pPrint =
+ vcat . map ppentry . Map.toList
+ where
+ ppentry (k, v) =
+ pPrint k <> text " : " $$ nest 15 (pPrint v)
+
+-- Convenience method for turning an Outputable into a string
+pprString :: (Outputable x) => x -> String
+pprString = showSDoc . ppr
+
+pprStringDebug :: (Outputable x) => x -> String
+pprStringDebug = showSDocDebug . ppr
--- /dev/null
+--
+-- Functions to generate VHDL from FlatFunctions
+--
+module CLasH.VHDL where
+
+-- Standard modules
+import qualified Data.Map as Map
+import qualified Maybe
+import qualified Control.Arrow as Arrow
+import Data.Accessor
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import qualified CoreSyn
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.VHDLTypes
+import CLasH.VHDL.VHDLTools
+import CLasH.VHDL.Constants
+import CLasH.VHDL.Generate
+
+createDesignFiles ::
+ [CoreSyn.CoreBndr] -- ^ Top binders
+ -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
+
+createDesignFiles topbndrs = do
+ bndrss <- mapM recurseArchitectures topbndrs
+ let bndrs = concat bndrss
+ lunits <- mapM createLibraryUnit bndrs
+ typepackage <- createTypesPackage
+ let files = map (Arrow.second $ AST.DesignFile full_context) lunits
+ return $ typepackage : files
+ where
+ full_context =
+ mkUseAll ["work", "types"]
+ : (mkUseAll ["work"]
+ : ieee_context)
+
+ieee_context = [
+ AST.Library $ mkVHDLBasicId "IEEE",
+ mkUseAll ["IEEE", "std_logic_1164"],
+ mkUseAll ["IEEE", "numeric_std"],
+ mkUseAll ["std", "textio"]
+ ]
+
+-- | Find out which entities are needed for the given top level binders.
+recurseArchitectures ::
+ CoreSyn.CoreBndr -- ^ The top level binder
+ -> TranslatorSession [CoreSyn.CoreBndr]
+ -- ^ The binders of all needed functions.
+recurseArchitectures bndr = do
+ -- See what this binder directly uses
+ (_, used) <- getArchitecture bndr
+ -- Recursively check what each of the used functions uses
+ useds <- mapM recurseArchitectures used
+ -- And return all of them
+ return $ bndr : (concat useds)
+
+-- | Creates the types package, based on the current type state.
+createTypesPackage ::
+ TranslatorSession (AST.VHDLId, AST.DesignFile)
+ -- ^ The id and content of the types package
+
+createTypesPackage = do
+ tyfuns <- MonadState.get (tsType .> tsTypeFuns)
+ let tyfun_decls = mkBuiltInShow ++ map snd (Map.elems tyfuns)
+ ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
+ let ty_decls = Maybe.catMaybes ty_decls_maybes
+ let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
+ let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
+ let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+ return (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
+ where
+ tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
+ tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple highId) Nothing)
+ tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
+
+-- Create a use foo.bar.all statement. Takes a list of components in the used
+-- name. Must contain at least two components
+mkUseAll :: [String] -> AST.ContextItem
+mkUseAll ss =
+ AST.Use $ from AST.:.: AST.All
+ where
+ base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
+ from = foldl select base_prefix (tail ss)
+ select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
+
+createLibraryUnit ::
+ CoreSyn.CoreBndr
+ -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
+
+createLibraryUnit bndr = do
+ entity <- getEntity bndr
+ (arch, _) <- getArchitecture bndr
+ return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])
--- /dev/null
+module CLasH.VHDL.Constants where
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- | A list of all builtin functions. Partly duplicates the name table
+-- in VHDL.Generate, but we can't use that map everywhere due to
+-- circular dependencie.
+builtinIds = [ exId, replaceId, headId, lastId, tailId, initId, takeId, dropId
+ , selId, plusgtId, ltplusId, plusplusId, mapId, zipWithId, foldlId
+ , foldrId, zipId, unzipId, shiftlId, shiftrId, rotlId, rotrId
+ , concatId, reverseId, iteratenId, iterateId, generatenId, generateId
+ , emptyId, singletonId, copynId, copyId, lengthTId, nullId
+ , hwxorId, hwandId, hworId, hwnotId, equalityId, inEqualityId, ltId
+ , lteqId, gtId, gteqId, boolOrId, boolAndId, plusId, timesId
+ , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId
+ , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId
+ , splitId, minimumId, fromRangedWordId
+ ]
+--------------
+-- Identifiers
+--------------
+
+-- | reset and clock signal identifiers in String form
+resetStr, clockStr :: String
+resetStr = "resetn"
+clockStr = "clock"
+
+-- | reset and clock signal identifiers in basic AST.VHDLId form
+resetId, clockId :: AST.VHDLId
+resetId = AST.unsafeVHDLBasicId resetStr
+clockId = AST.unsafeVHDLBasicId clockStr
+
+integerId :: AST.VHDLId
+integerId = AST.unsafeVHDLBasicId "integer"
+
+-- | \"types\" identifier
+typesId :: AST.VHDLId
+typesId = AST.unsafeVHDLBasicId "types"
+
+-- | work identifier
+workId :: AST.VHDLId
+workId = AST.unsafeVHDLBasicId "work"
+
+-- | std identifier
+stdId :: AST.VHDLId
+stdId = AST.unsafeVHDLBasicId "std"
+
+
+-- | textio identifier
+textioId :: AST.VHDLId
+textioId = AST.unsafeVHDLBasicId "textio"
+
+-- | range attribute identifier
+rangeId :: AST.VHDLId
+rangeId = AST.unsafeVHDLBasicId "range"
+
+
+-- | high attribute identifier
+highId :: AST.VHDLId
+highId = AST.unsafeVHDLBasicId "high"
+
+-- | range attribute identifier
+imageId :: AST.VHDLId
+imageId = AST.unsafeVHDLBasicId "image"
+
+-- | event attribute identifie
+eventId :: AST.VHDLId
+eventId = AST.unsafeVHDLBasicId "event"
+
+
+-- | default function identifier
+defaultId :: AST.VHDLId
+defaultId = AST.unsafeVHDLBasicId "default"
+
+-- FSVec function identifiers
+
+-- | ex (operator ! in original Haskell source) function identifier
+exId :: String
+exId = "!"
+
+-- | sel (function select in original Haskell source) function identifier
+selId :: String
+selId = "select"
+
+
+-- | ltplus (function (<+) in original Haskell source) function identifier
+ltplusId :: String
+ltplusId = "<+"
+
+
+-- | plusplus (function (++) in original Haskell source) function identifier
+plusplusId :: String
+plusplusId = "++"
+
+
+-- | empty function identifier
+emptyId :: String
+emptyId = "empty"
+
+-- | plusgt (function (+>) in original Haskell source) function identifier
+plusgtId :: String
+plusgtId = "+>"
+
+-- | singleton function identifier
+singletonId :: String
+singletonId = "singleton"
+
+-- | length function identifier
+lengthId :: String
+lengthId = "length"
+
+
+-- | isnull (function null in original Haskell source) function identifier
+nullId :: String
+nullId = "null"
+
+
+-- | replace function identifier
+replaceId :: String
+replaceId = "replace"
+
+
+-- | head function identifier
+headId :: String
+headId = "head"
+
+
+-- | last function identifier
+lastId :: String
+lastId = "last"
+
+
+-- | init function identifier
+initId :: String
+initId = "init"
+
+
+-- | tail function identifier
+tailId :: String
+tailId = "tail"
+
+-- | minimum ftp function identifier
+minimumId :: String
+minimumId = "minimum"
+
+-- | take function identifier
+takeId :: String
+takeId = "take"
+
+
+-- | drop function identifier
+dropId :: String
+dropId = "drop"
+
+-- | shiftl function identifier
+shiftlId :: String
+shiftlId = "shiftl"
+
+-- | shiftr function identifier
+shiftrId :: String
+shiftrId = "shiftr"
+
+-- | rotl function identifier
+rotlId :: String
+rotlId = "rotl"
+
+-- | reverse function identifier
+rotrId :: String
+rotrId = "rotr"
+
+-- | concatenate the vectors in a vector
+concatId :: String
+concatId = "concat"
+
+-- | reverse function identifier
+reverseId :: String
+reverseId = "reverse"
+
+-- | iterate function identifier
+iterateId :: String
+iterateId = "iterate"
+
+-- | iteraten function identifier
+iteratenId :: String
+iteratenId = "iteraten"
+
+-- | iterate function identifier
+generateId :: String
+generateId = "generate"
+
+-- | iteraten function identifier
+generatenId :: String
+generatenId = "generaten"
+
+-- | copy function identifier
+copyId :: String
+copyId = "copy"
+
+-- | copyn function identifier
+copynId :: String
+copynId = "copyn"
+
+-- | map function identifier
+mapId :: String
+mapId = "map"
+
+-- | zipwith function identifier
+zipWithId :: String
+zipWithId = "zipWith"
+
+-- | foldl function identifier
+foldlId :: String
+foldlId = "foldl"
+
+-- | foldr function identifier
+foldrId :: String
+foldrId = "foldr"
+
+-- | zip function identifier
+zipId :: String
+zipId = "zip"
+
+-- | unzip function identifier
+unzipId :: String
+unzipId = "unzip"
+
+-- | hwxor function identifier
+hwxorId :: String
+hwxorId = "hwxor"
+
+-- | hwor function identifier
+hworId :: String
+hworId = "hwor"
+
+-- | hwnot function identifier
+hwnotId :: String
+hwnotId = "hwnot"
+
+-- | hwand function identifier
+hwandId :: String
+hwandId = "hwand"
+
+lengthTId :: String
+lengthTId = "lengthT"
+
+fstId :: String
+fstId = "fst"
+
+sndId :: String
+sndId = "snd"
+
+splitId :: String
+splitId = "split"
+
+-- Equality Operations
+equalityId :: String
+equalityId = "=="
+
+inEqualityId :: String
+inEqualityId = "/="
+
+gtId :: String
+gtId = ">"
+
+ltId :: String
+ltId = "<"
+
+gteqId :: String
+gteqId = ">="
+
+lteqId :: String
+lteqId = "<="
+
+boolOrId :: String
+boolOrId = "||"
+
+boolAndId :: String
+boolAndId = "&&"
+
+boolNot :: String
+boolNot = "not"
+
+-- Numeric Operations
+
+-- | plus operation identifier
+plusId :: String
+plusId = "+"
+
+-- | times operation identifier
+timesId :: String
+timesId = "*"
+
+-- | negate operation identifier
+negateId :: String
+negateId = "negate"
+
+-- | minus operation identifier
+minusId :: String
+minusId = "-"
+
+-- | convert sizedword to ranged
+fromSizedWordId :: String
+fromSizedWordId = "fromUnsigned"
+
+fromRangedWordId :: String
+fromRangedWordId = "fromIndex"
+
+toIntegerId :: String
+toIntegerId = "to_integer"
+
+fromIntegerId :: String
+fromIntegerId = "fromInteger"
+
+toSignedId :: String
+toSignedId = "to_signed"
+
+toUnsignedId :: String
+toUnsignedId = "to_unsigned"
+
+resizeId :: String
+resizeId = "resize"
+
+resizeWordId :: String
+resizeWordId = "resizeWord"
+
+resizeIntId :: String
+resizeIntId = "resizeInt"
+
+smallIntegerId :: String
+smallIntegerId = "smallInteger"
+
+sizedIntId :: String
+sizedIntId = "Signed"
+
+tfvecId :: String
+tfvecId = "Vector"
+
+blockRAMId :: String
+blockRAMId = "blockRAM"
+
+-- | output file identifier (from std.textio)
+showIdString :: String
+showIdString = "show"
+
+showId :: AST.VHDLId
+showId = AST.unsafeVHDLExtId showIdString
+
+-- | write function identifier (from std.textio)
+writeId :: AST.VHDLId
+writeId = AST.unsafeVHDLBasicId "write"
+
+-- | output file identifier (from std.textio)
+outputId :: AST.VHDLId
+outputId = AST.unsafeVHDLBasicId "output"
+
+------------------
+-- VHDL type marks
+------------------
+
+-- | The Bit type mark
+bitTM :: AST.TypeMark
+bitTM = AST.unsafeVHDLBasicId "Bit"
+
+-- | Stardard logic type mark
+std_logicTM :: AST.TypeMark
+std_logicTM = AST.unsafeVHDLBasicId "std_logic"
+
+-- | boolean type mark
+booleanTM :: AST.TypeMark
+booleanTM = AST.unsafeVHDLBasicId "boolean"
+
+-- | fsvec_index AST. TypeMark
+tfvec_indexTM :: AST.TypeMark
+tfvec_indexTM = AST.unsafeVHDLBasicId "tfvec_index"
+
+-- | natural AST. TypeMark
+naturalTM :: AST.TypeMark
+naturalTM = AST.unsafeVHDLBasicId "natural"
+
+-- | integer TypeMark
+integerTM :: AST.TypeMark
+integerTM = AST.unsafeVHDLBasicId "integer"
+
+-- | signed TypeMark
+signedTM :: AST.TypeMark
+signedTM = AST.unsafeVHDLBasicId "signed"
+
+-- | unsigned TypeMark
+unsignedTM :: AST.TypeMark
+unsignedTM = AST.unsafeVHDLBasicId "unsigned"
+
+-- | string TypeMark
+stringTM :: AST.TypeMark
+stringTM = AST.unsafeVHDLBasicId "string"
+
+-- | tup VHDLName suffix
+tupVHDLSuffix :: AST.VHDLId -> AST.Suffix
+tupVHDLSuffix id = AST.SSimple id
--- /dev/null
+module CLasH.VHDL.Generate where
+
+-- Standard modules
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Control.Monad as Monad
+import qualified Maybe
+import qualified Data.Either as Either
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import qualified CoreSyn
+import qualified Type
+import qualified Var
+import qualified Id
+import qualified IdInfo
+import qualified Literal
+import qualified Name
+import qualified TyCon
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.Constants
+import CLasH.VHDL.VHDLTypes
+import CLasH.VHDL.VHDLTools
+import CLasH.Utils
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.Pretty
+import qualified CLasH.Normalize as Normalize
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL for user-defined functions.
+-----------------------------------------------------------------------------
+
+-- | Create an entity for a given function
+getEntity ::
+ CoreSyn.CoreBndr
+ -> TranslatorSession Entity -- ^ The resulting entity
+
+getEntity fname = makeCached fname tsEntities $ do
+ expr <- Normalize.getNormalized False fname
+ -- Split the normalized expression
+ let (args, binds, res) = Normalize.splitNormalized expr
+ -- Generate ports for all non-empty types
+ args' <- catMaybesM $ mapM mkMap args
+ -- TODO: Handle Nothing
+ res' <- mkMap res
+ count <- MonadState.get tsEntityCounter
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
+ MonadState.set tsEntityCounter (count + 1)
+ let ent_decl = createEntityAST vhdl_id args' res'
+ let signature = Entity vhdl_id args' res' ent_decl
+ return signature
+ where
+ mkMap ::
+ --[(SignalId, SignalInfo)]
+ CoreSyn.CoreBndr
+ -> TranslatorSession (Maybe Port)
+ mkMap = (\bndr ->
+ let
+ --info = Maybe.fromMaybe
+ -- (error $ "Signal not found in the name map? This should not happen!")
+ -- (lookup id sigmap)
+ -- Assume the bndr has a valid VHDL id already
+ id = varToVHDLId bndr
+ ty = Var.varType bndr
+ error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
+ in do
+ type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
+ case type_mark_maybe of
+ Just type_mark -> return $ Just (id, type_mark)
+ Nothing -> return Nothing
+ )
+
+-- | Create the VHDL AST for an entity
+createEntityAST ::
+ AST.VHDLId -- ^ The name of the function
+ -> [Port] -- ^ The entity's arguments
+ -> Maybe Port -- ^ The entity's result
+ -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
+
+createEntityAST vhdl_id args res =
+ AST.EntityDec vhdl_id ports
+ where
+ -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
+ ports = map (mkIfaceSigDec AST.In) args
+ ++ (Maybe.maybeToList res_port)
+ ++ [clk_port,resetn_port]
+ -- Add a clk port if we have state
+ clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
+ resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
+ res_port = fmap (mkIfaceSigDec AST.Out) res
+
+-- | Create a port declaration
+mkIfaceSigDec ::
+ AST.Mode -- ^ The mode for the port (In / Out)
+ -> Port -- ^ The id and type for the port
+ -> AST.IfaceSigDec -- ^ The resulting port declaration
+
+mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
+
+-- | Create an architecture for a given function
+getArchitecture ::
+ CoreSyn.CoreBndr -- ^ The function to get an architecture for
+ -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
+ -- ^ The architecture for this function
+
+getArchitecture fname = makeCached fname tsArchitectures $ do
+ expr <- Normalize.getNormalized False fname
+ -- Split the normalized expression
+ let (args, binds, res) = Normalize.splitNormalized expr
+
+ -- Get the entity for this function
+ signature <- getEntity fname
+ let entity_id = ent_id signature
+
+ -- Create signal declarations for all binders in the let expression, except
+ -- for the output port (that will already have an output port declared in
+ -- the entity).
+ sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
+ let sig_decs = Maybe.catMaybes sig_dec_maybes
+ -- Process each bind, resulting in info about state variables and concurrent
+ -- statements.
+ (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
+ let (in_state_maybes, out_state_maybes) = unzip state_vars
+ let (statementss, used_entitiess) = unzip sms
+ -- Get initial state, if it's there
+ initSmap <- MonadState.get tsInitStates
+ let init_state = Map.lookup fname initSmap
+ -- Create a state proc, if needed
+ (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
+ ([in_state], [out_state], Nothing) -> do
+ nonEmpty <- hasNonEmptyType in_state
+ if nonEmpty
+ then error ("No initial state defined for: " ++ show fname)
+ else return ([],[])
+ ([in_state], [out_state], Just resetval) -> do
+ nonEmpty <- hasNonEmptyType in_state
+ if nonEmpty
+ then mkStateProcSm (in_state, out_state, resetval)
+ else error ("Initial state defined for function with only substate: " ++ show fname)
+ ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
+ ([], [], Nothing) -> return ([],[])
+ (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
+ -- Join the create statements and the (optional) state_proc
+ let statements = concat statementss ++ state_proc
+ -- Create the architecture
+ let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
+ let used_entities = (concat used_entitiess) ++ resbndr
+ return (arch, used_entities)
+ where
+ dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
+ -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
+ -- ^ ((Input state variable, output state variable), (statements, used entities))
+ -- newtype unpacking is just a cast
+ dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
+ | hasStateType packed && not (hasStateType unpacked)
+ = return ((Just bndr, Nothing), ([], []))
+ -- With simplCore, newtype packing is just a cast
+ dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
+ | hasStateType packed && not (hasStateType unpacked)
+ = return ((Nothing, Just state), ([], []))
+ -- Without simplCore, newtype packing uses a data constructor
+ dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
+ | isStateCon con
+ = return ((Nothing, Just state), ([], []))
+ -- Anything else is handled by mkConcSm
+ dobind bind = do
+ sms <- mkConcSm bind
+ return ((Nothing, Nothing), sms)
+
+mkStateProcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
+mkStateProcSm (old, new, res) = do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
+ type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
+ let type_mark_old = Maybe.fromMaybe
+ (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
+ type_mark_old_maybe
+ type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
+ let type_mark_res' = Maybe.fromMaybe
+ (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
+ type_mark_res_maybe
+ let type_mark_res = if type_mark_old == type_mark_res' then
+ type_mark_res'
+ else
+ error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
+ let resvalid = mkVHDLExtId $ varToString res ++ "val"
+ let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
+ let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
+ let res_assign = AST.SigAssign (varToVHDLName old) reswform
+ let blocklabel = mkVHDLBasicId "state"
+ let statelabel = mkVHDLBasicId "stateupdate"
+ let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+ let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
+ let clk_assign = AST.SigAssign (varToVHDLName old) wform
+ let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
+ let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
+ signature <- getEntity res
+ let entity_id = ent_id signature
+ let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
+ let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
+ let reset_statement = mkComponentInst reslabel entity_id portmaps
+ let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
+ let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
+ let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
+ let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
+ return ([block],[res])
+
+-- | Transforms a core binding into a VHDL concurrent statement
+mkConcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+ -- ^ The corresponding VHDL concurrent statements and entities
+ -- instantiated.
+
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out. Throw away state repacking
+mkConcSm (bndr, to@(CoreSyn.Cast from ty))
+ | hasStateType to && hasStateType from
+ = return ([],[])
+mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
+
+-- Simple a = b assignments are just like applications, but without arguments.
+-- We can't just generate an unconditional assignment here, since b might be a
+-- top level binding (e.g., a function with no arguments).
+mkConcSm (bndr, CoreSyn.Var v) =
+ genApplication (Left bndr) v []
+
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ genApplication (Left bndr) f (map Left valargs)
+
+-- A single alt case must be a selector. This means the scrutinee is a simple
+-- variable, the alternative is a dataalt with a single non-wild binder that
+-- is also returned.
+mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
+ -- Don't generate VHDL for substate extraction
+ | hasStateType bndr = return ([], [])
+ | otherwise =
+ case alt of
+ (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
+ nonemptysel <- hasNonEmptyType sel_bndr
+ if nonemptysel
+ then do
+ bndrs' <- Monad.filterM hasNonEmptyType bndrs
+ case List.elemIndex sel_bndr bndrs' of
+ Just i -> do
+ htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
+ htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+ case htypeScrt == htypeBndr of
+ True -> do
+ let sel_name = varToVHDLName scrut
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
+ otherwise ->
+ case htypeScrt of
+ Right (AggrType _ _) -> do
+ labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
+ let label = labels!!i
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
+ _ -> do -- error $ "DIE!"
+ let sel_name = varToVHDLName scrut
+ let sel_expr = AST.PrimName sel_name
+ return ([mkUncondAssign (Left bndr) sel_expr], [])
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
+ else
+ -- A selector case that selects a state value, ignore it.
+ return ([], [])
+
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+-- Multiple case alt become conditional assignments and have only wild
+-- binders in the alts and only variables in the case values and a variable
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- first is the default case, if there is any.
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do
+ scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
+ -- Omit first condition, which is the default
+ altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
+ let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
+ -- Rotate expressions to the left, so that the expression related to the default case is the last
+ exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
+ return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
+
+mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL for builtin functions
+-----------------------------------------------------------------------------
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be expressions.
+genExprArgs wrap dst func args = do
+ args' <- argsToVHDLExprs args
+ wrap dst func args'
+
+-- | Turn the all lefts into VHDL Expressions.
+argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
+argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
+
+argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
+argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
+ let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
+ ty_maybe <- vhdlTy errmsg expr
+ case ty_maybe of
+ Just _ -> do
+ vhdl_expr <- varToVHDLExpr $ exprToVar expr
+ return $ Just vhdl_expr
+ Nothing -> return Nothing
+
+argToVHDLExpr (Right expr) = return $ Just expr
+
+-- A function to wrap a builder-like function that generates no component
+-- instantiations
+genNoInsts ::
+ (dst -> func -> args -> TranslatorSession [AST.ConcSm])
+ -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
+genNoInsts wrap dst func args = do
+ concsms <- wrap dst func args
+ return (concsms, [])
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be variables.
+genVarArgs ::
+ (dst -> func -> [Var.Var] -> res)
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genVarArgs wrap = genCoreArgs $ \dst func args -> let
+ args' = map exprToVar args
+ in
+ wrap dst func args'
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be core expressions.
+genCoreArgs ::
+ (dst -> func -> [CoreSyn.CoreExpr] -> res)
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genCoreArgs wrap dst func args = wrap dst func args'
+ where
+ -- Check (rather crudely) that all arguments are CoreExprs
+ args' = case Either.partitionEithers args of
+ (exprargs, []) -> exprargs
+ (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
+
+-- | A function to wrap a builder-like function that produces an expression
+-- and expects it to be assigned to the destination.
+genExprRes ::
+ ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
+ -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
+genExprRes wrap dst func args = do
+ expr <- wrap dst func args
+ return [mkUncondAssign dst expr]
+
+-- | Generate a binary operator application. The first argument should be a
+-- constructor from the AST.Expr type, e.g. AST.And.
+genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
+genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
+genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
+
+-- | Generate a unary operator application
+genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
+genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
+genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genOperator1' op _ f [arg] = return $ op arg
+
+-- | Generate a unary operator application
+genNegation :: BuiltinBuilder
+genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
+genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
+genNegation' _ f [arg] = do
+ arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
+ let ty = Var.varType arg
+ let (tycon, args) = Type.splitTyConApp ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "Signed" -> return $ AST.Neg arg1
+ otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
+
+-- | Generate a function call from the destination binder, function name and a
+-- list of expressions (its arguments)
+genFCall :: Bool -> BuiltinBuilder
+genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
+genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genFCall' switch (Left res) f args = do
+ let fname = varToString f
+ let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
+ id <- MonadState.lift tsType $ vectorFunId el_ty fname
+ return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genFromSizedWord :: BuiltinBuilder
+genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
+genFromSizedWord' (Left res) f args@[arg] =
+ return [mkUncondAssign (Left res) arg]
+ -- let fname = varToString f
+ -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
+ -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genFromRangedWord :: BuiltinBuilder
+genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
+genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genFromRangedWord' (Left res) f [arg] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genResize :: BuiltinBuilder
+genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genResize' (Left res) f [arg] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genTimes :: BuiltinBuilder
+genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
+genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genTimes' (Left res) f [arg1,arg2] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
+ ; return bitsize
+ }
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+-- fromInteger turns an Integer into a Num instance. Since Integer is
+-- not representable and is only allowed for literals, the actual
+-- Integer should be inlined entirely into the fromInteger argument.
+genFromInteger :: BuiltinBuilder
+genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
+genFromInteger' (Left res) f args = do
+ let ty = Var.varType res
+ let (tycon, tyargs) = Type.splitTyConApp ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ len <- case name of
+ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "Index" -> do
+ bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
+ let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
+ case args of
+ [integer] -> do -- The type and dictionary arguments are removed by genApplication
+ literal <- getIntegerLiteral integer
+ return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
+
+genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genSizedInt :: BuiltinBuilder
+genSizedInt = genFromInteger
+
+{-
+-- This function is useful for use with vectorTH, since that generates
+-- explicit references to the TFVec constructor (which is normally
+-- hidden). Below implementation is probably not current anymore, but
+-- kept here in case we start using vectorTH again.
+-- | Generate a Builder for the builtin datacon TFVec
+genTFVec :: BuiltinBuilder
+genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
+ -- Generate Assignments for all the binders
+ ; letAssigns <- mapM genBinderAssign letBinders
+ -- Generate assignments for the result (which might be another let binding)
+ ; (resBinders,resAssignments) <- genResAssign letRes
+ -- Get all the Assigned binders
+ ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
+ -- Make signal names for all the assigned binders
+ ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
+ -- Assign all the signals to the resulting vector
+ ; let { vecsigns = mkAggregateSignal sigs
+ ; vecassign = mkUncondAssign (Left res) vecsigns
+ } ;
+ -- Generate all the signal declaration for the assigned binders
+ ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
+ ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
+ -- Setup the VHDL Block
+ ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
+ ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
+ } ;
+ -- Return the block statement coressponding to the TFVec literal
+ ; return $ [AST.CSBSm block]
+ }
+ where
+ genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
+ -- For now we only translate applications
+ genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
+ let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+ let valargs = get_val_args (Var.varType f) args
+ apps <- genApplication (Left bndr) f (map Left valargs)
+ return (Just bndr, apps)
+ genBinderAssign _ = return (Nothing,[])
+ genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
+ genResAssign app@(CoreSyn.App _ letexpr) = do
+ case letexpr of
+ (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
+ letapps <- mapM genBinderAssign letbndrs
+ let bndrs = Maybe.catMaybes (map fst letapps)
+ let app = (map snd letapps)
+ (vars, apps) <- genResAssign letres
+ return ((bndrs ++ vars),((concat app) ++ apps))
+ otherwise -> return ([],[])
+ genResAssign _ = return ([],[])
+
+genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
+ ; let { elems = reduceCoreListToHsList app
+ -- Make signal names for all the binders
+ ; binders = map (\expr -> case expr of
+ (CoreSyn.Var b) -> b
+ otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
+ ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
+ } ;
+ ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
+ -- Assign all the signals to the resulting vector
+ ; let { vecsigns = mkAggregateSignal sigs
+ ; vecassign = mkUncondAssign (Left res) vecsigns
+ -- Setup the VHDL Block
+ ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
+ ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
+ } ;
+ -- Return the block statement coressponding to the TFVec literal
+ ; return $ [AST.CSBSm block]
+ }
+
+genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
+
+genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
+-}
+-- | Generate a generate statement for the builtin function "map"
+genMap :: BuiltinBuilder
+genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
+ -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
+ -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
+ -- we must index it (which we couldn't if it was a VHDL Expr, since only
+ -- VHDLNames can be indexed).
+ -- Setup the generate scheme
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ ; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
+ ; valargs = get_val_args (Var.varType real_f) already_mapped_args
+ } ;
+ ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
+ -- Return the generate statement
+ ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
+ }
+
+genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
+
+genZipWith :: BuiltinBuilder
+genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the zipped_f to
+ -- each of the elements in arg1 and arg2, storing to each element in res
+ ; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
+ ; valargs = get_val_args (Var.varType real_f) already_mapped_args
+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ } ;
+ ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2])
+ -- Return the generate functions
+ ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
+ }
+
+genFoldl :: BuiltinBuilder
+genFoldl = genFold True
+
+genFoldr :: BuiltinBuilder
+genFoldr = genFold False
+
+genFold :: Bool -> BuiltinBuilder
+genFold left = genVarArgs (genFold' left)
+
+genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+genFold' left res f args@[folded_f , start ,vec]= do
+ len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
+ genFold'' len left res f args
+
+genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+-- Special case for an empty input vector, just assign start to res
+genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
+ arg <- MonadState.lift tsType $ varToVHDLExpr start
+ return ([mkUncondAssign (Left res) arg], [])
+
+genFold'' len left (Left res) f [folded_f, start, vec] = do
+ -- The vector length
+ --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ -- An expression for len-1
+ let len_min_expr = (AST.PrimLit $ show (len-1))
+ -- evec is (TFVec n), so it still needs an element type
+ let (nvec, _) = Type.splitAppTy (Var.varType vec)
+ -- Put the type of the start value in nvec, this will be the type of our
+ -- temporary vector
+ let tmp_ty = Type.mkAppTy nvec (Var.varType start)
+ let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
+ -- TODO: Handle Nothing
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
+ -- Setup the generate scheme
+ let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
+ let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
+ else AST.DownRange len_min_expr (AST.PrimLit "0")
+ let gen_scheme = AST.ForGn n_id gen_range
+ -- Make the intermediate vector
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells' <- sequence [genFirstCell, genOtherCell]
+ let (cells, useds) = unzip cells'
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] or tmp[0] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
+ (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
+ (mkIndexedName tmp_name (AST.PrimLit "0")))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return ([AST.CSBSm block], concat useds)
+ where
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_cur = idToVHDLExpr n_id
+ -- An expression for previous n
+ n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
+ else (n_cur AST.:+: (AST.PrimLit "1"))
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
+ genFirstCell = do
+ len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0 or n == len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
+ else (AST.PrimLit $ show (len-1)))
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from start
+ argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
+ -- Input from vec[current n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+ (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
+ [Right argexpr1, Right argexpr2]
+ else
+ [Right argexpr2, Right argexpr1]
+ )
+ -- Return the conditional generate part
+ return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+
+ genOtherCell = do
+ len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0 or n < len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
+ else (AST.PrimLit $ show (len-1)))
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from tmp[previous n]
+ let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+ -- Input from vec[current n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+ (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
+ [Right argexpr1, Right argexpr2]
+ else
+ [Right argexpr2, Right argexpr1]
+ )
+ -- Return the conditional generate part
+ return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+
+-- | Generate a generate statement for the builtin function "zip"
+genZip :: BuiltinBuilder
+genZip = genNoInsts $ genVarArgs genZip'
+genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genZip' (Left res) f args@[arg1, arg2] = do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ } ;
+ ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
+ ; let { resnameA = mkSelectedName resname' (labels!!0)
+ ; resnameB = mkSelectedName resname' (labels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
+ ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
+ } ;
+ -- Return the generate functions
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
+
+-- | Generate a generate statement for the builtin function "fst"
+genFst :: BuiltinBuilder
+genFst = genNoInsts $ genVarArgs genFst'
+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genFst' (Left res) f args@[arg] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
+ ; let { argexpr' = varToVHDLName arg
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
+ ; assign = mkUncondAssign (Left res) argexprA
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
+
+-- | Generate a generate statement for the builtin function "snd"
+genSnd :: BuiltinBuilder
+genSnd = genNoInsts $ genVarArgs genSnd'
+genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSnd' (Left res) f args@[arg] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
+ ; let { argexpr' = varToVHDLName arg
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
+ ; assign = mkUncondAssign (Left res) argexprB
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
+
+-- | Generate a generate statement for the builtin function "unzip"
+genUnzip :: BuiltinBuilder
+genUnzip = genNoInsts $ genVarArgs genUnzip'
+genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genUnzip' (Left res) f args@[arg] = do
+ let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
+ htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
+ -- Prepare a unconditional assignment, for the case when either part
+ -- of the unzip is a state variable, which will disappear in the
+ -- resulting VHDL, making the the unzip no longer required.
+ case htype of
+ -- A normal vector containing two-tuples
+ VecType _ (AggrType _ [_, _]) -> do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = varToVHDLName res
+ ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
+ } ;
+ ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
+ ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
+ ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexprA
+ ; resB_assign = mkUncondAssign (Right resnameB) argexprB
+ } ;
+ -- Return the generate functions
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
+ -- Both elements of the tuple were state, so they've disappeared. No
+ -- need to do anything
+ VecType _ (AggrType _ []) -> return []
+ -- A vector containing aggregates with more than two elements?
+ VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
+ -- One of the elements of the tuple was state, so there won't be a
+ -- tuple (record) in the VHDL output. We can just do a plain
+ -- assignment, then.
+ VecType _ _ -> do
+ argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
+ return [mkUncondAssign (Left res) argexpr]
+ _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
+
+genCopy :: BuiltinBuilder
+genCopy = genNoInsts genCopy'
+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]
+genCopy' (Left res) f [arg] = do {
+ ; [arg'] <- argsToVHDLExprs [arg]
+ ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
+ ; out_assign = mkUncondAssign (Left res) resExpr
+ }
+ ; return [out_assign]
+ }
+
+genConcat :: BuiltinBuilder
+genConcat = genNoInsts $ genVarArgs genConcat'
+genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genConcat' (Left res) f args@[arg] = do {
+ -- Setup the generate scheme
+ ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
+ ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
+ ; resname = vecSlice fromRange toRange
+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ ; out_assign = mkUncondAssign (Right resname) argexpr
+ } ;
+ -- Return the generate statement
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+ }
+ where
+ vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
+ (AST.ToRange init last))
+
+genIteraten :: BuiltinBuilder
+genIteraten dst f args = genIterate dst f (tail args)
+
+genIterate :: BuiltinBuilder
+genIterate = genIterateOrGenerate True
+
+genGeneraten :: BuiltinBuilder
+genGeneraten dst f args = genGenerate dst f (tail args)
+
+genGenerate :: BuiltinBuilder
+genGenerate = genIterateOrGenerate False
+
+genIterateOrGenerate :: Bool -> BuiltinBuilder
+genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
+
+genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+genIterateOrGenerate' iter (Left res) f args = do
+ len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ genIterateOrGenerate'' len iter (Left res) f args
+
+genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+-- Special case for an empty input vector, just assign start to res
+genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
+
+genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
+ -- The vector length
+ -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ -- An expression for len-1
+ let len_min_expr = (AST.PrimLit $ show (len-1))
+ -- -- evec is (TFVec n), so it still needs an element type
+ -- let (nvec, _) = splitAppTy (Var.varType vec)
+ -- -- Put the type of the start value in nvec, this will be the type of our
+ -- -- temporary vector
+ let tmp_ty = Var.varType res
+ let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
+ -- TODO: Handle Nothing
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
+ -- Setup the generate scheme
+ let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
+ let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
+ let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
+ let gen_scheme = AST.ForGn n_id gen_range
+ -- Make the intermediate vector
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells' <- sequence [genFirstCell, genOtherCell]
+ let (cells, useds) = unzip cells'
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] or tmp[0] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return ([AST.CSBSm block], concat useds)
+ where
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_cur = idToVHDLExpr n_id
+ -- An expression for previous n
+ n_prev = n_cur AST.:-: (AST.PrimLit "1")
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
+ genFirstCell = do
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0 or n == len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from start
+ argexpr <- MonadState.lift tsType $ varToVHDLExpr start
+ let startassign = mkUncondAssign (Right resname) argexpr
+ (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
+ -- Return the conditional generate part
+ let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
+ [startassign]
+ else
+ app_concsms
+ )
+ return (gensm, used)
+
+ genOtherCell = do
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0 or n < len-1
+ let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
+ -- Output to tmp[current n]
+ let resname = mkIndexedName tmp_name n_cur
+ -- Input from tmp[previous n]
+ let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+ (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
+ -- Return the conditional generate part
+ return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+
+genBlockRAM :: BuiltinBuilder
+genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
+
+genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
+genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
+ -- Get the ram type
+ let (tup,data_out) = Type.splitAppTy (Var.varType res)
+ let (tup',ramvec) = Type.splitAppTy tup
+ let Just realram = Type.coreView ramvec
+ let Just (tycon, types) = Type.splitTyConApp_maybe realram
+ Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
+ -- Make the intermediate vector
+ let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
+ -- Get the data_out name
+ -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ let resname = varToVHDLName res
+ -- let resname = mkSelectedName resname' (reslabels!!0)
+ let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
+ let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
+ let assign = mkUncondAssign (Right resname) argexpr
+ let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
+ return [AST.CSBSm block]
+ where
+ ram_id = mkVHDLBasicId "ram"
+ mkUpdateProcSm :: AST.ConcSm
+ mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
+ where
+ proclabel = mkVHDLBasicId "updateRAM"
+ rising_edge = mkVHDLBasicId "rising_edge"
+ wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
+ ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
+ wform = AST.Wform [AST.WformElem data_in Nothing]
+ ramassign = AST.SigAssign ramloc wform
+ rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
+ statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
+
+genSplit :: BuiltinBuilder
+genSplit = genNoInsts $ genVarArgs genSplit'
+
+genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSplit' (Left res) f args@[vecIn] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
+ ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
+ ; halflen = round ((fromIntegral len) / 2)
+ ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
+ ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
+ ; resname = varToVHDLName res
+ ; resnameL = mkSelectedName resname (labels!!0)
+ ; resnameR = mkSelectedName resname (labels!!1)
+ ; argexprL = vhdlNameToVHDLExpr rangeL
+ ; argexprR = vhdlNameToVHDLExpr rangeR
+ ; out_assignL = mkUncondAssign (Right resnameL) argexprL
+ ; out_assignR = mkUncondAssign (Right resnameR) argexprR
+ ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
+ }
+ ; return [AST.CSBSm block]
+ }
+ where
+ vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
+ (AST.ToRange init last))
+-----------------------------------------------------------------------------
+-- Function to generate VHDL for applications
+-----------------------------------------------------------------------------
+genApplication ::
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
+ -> CoreSyn.CoreBndr -- ^ The function to apply
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+ -- ^ The corresponding VHDL concurrent statements and entities
+ -- instantiated.
+genApplication dst f args = do
+ nonemptydst <- case dst of
+ Left bndr -> hasNonEmptyType bndr
+ Right _ -> return True
+ if nonemptydst
+ then
+ if Var.isGlobalId f then
+ case Var.idDetails f of
+ IdInfo.DataConWorkId dc -> case dst of
+ -- It's a datacon. Create a record from its arguments.
+ Left bndr -> do
+ -- We have the bndr, so we can get at the type
+ htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+ let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
+ case argsNostate of
+ [arg] -> do
+ [arg'] <- argsToVHDLExprs [arg]
+ return ([mkUncondAssign dst arg'], [])
+ otherwise ->
+ case htype of
+ Right (AggrType _ _) -> do
+ labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
+ args' <- argsToVHDLExprs argsNostate
+ return (zipWith mkassign labels args', [])
+ where
+ mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+ mkassign label arg =
+ let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+ mkUncondAssign (Right sel_name) arg
+ _ -> do -- error $ "DIE!"
+ args' <- argsToVHDLExprs argsNostate
+ return ([mkUncondAssign dst (head args')], [])
+ Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
+ IdInfo.DataConWrapId dc -> case dst of
+ -- It's a datacon. Create a record from its arguments.
+ Left bndr ->
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
+ Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
+ IdInfo.VanillaId ->
+ -- It's a global value imported from elsewhere. These can be builtin
+ -- functions. Look up the function name in the name table and execute
+ -- the associated builder if there is any and the argument count matches
+ -- (this should always be the case if it typechecks, but just to be
+ -- sure...).
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> do
+ top <- isTopLevelBinder f
+ if top then
+ do
+ -- Local binder that references a top level binding. Generate a
+ -- component instantiation.
+ signature <- getEntity f
+ args' <- argsToVHDLExprs args
+ let entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ let label = "comp_ins_" ++ (either show prettyShow) dst
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+ return ([mkComponentInst label entity_id portmaps], [f])
+ else
+ -- Not a top level binder, so this must be a local variable reference.
+ -- It should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an unconditional
+ -- assignment here.
+ -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
+ -- f' <- MonadState.lift tsType $ varToVHDLExpr f
+ -- return $ ([mkUncondAssign dst f'], [])
+ do errtype <- case dst of
+ Left bndr -> do
+ htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+ return (show htype)
+ Right vhd -> return $ show vhd
+ error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
+ IdInfo.ClassOpId cls ->
+ -- FIXME: Not looking for what instance this class op is called for
+ -- Is quite stupid of course.
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
+ details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+ else do
+ top <- isTopLevelBinder f
+ if top then
+ do
+ -- Local binder that references a top level binding. Generate a
+ -- component instantiation.
+ signature <- getEntity f
+ args' <- argsToVHDLExprs args
+ let entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+ return ([mkComponentInst label entity_id portmaps], [f])
+ else
+ -- Not a top level binder, so this must be a local variable reference.
+ -- It should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an unconditional
+ -- assignment here.
+ do f' <- MonadState.lift tsType $ varToVHDLExpr f
+ return ([mkUncondAssign dst f'], [])
+ else -- Destination has empty type, don't generate anything
+ return ([], [])
+-----------------------------------------------------------------------------
+-- Functions to generate functions dealing with vectors.
+-----------------------------------------------------------------------------
+
+-- Returns the VHDLId of the vector function with the given name for the given
+-- element type. Generates -- this function if needed.
+vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
+vectorFunId el_ty fname = do
+ let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
+ -- TODO: Handle the Nothing case?
+ elemTM_maybe <- vhdlTy error_msg el_ty
+ let elemTM = Maybe.fromMaybe
+ (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
+ elemTM_maybe
+ -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
+ -- the VHDLState or something.
+ let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
+ typefuns <- MonadState.get tsTypeFuns
+ el_htype <- mkHType error_msg el_ty
+ case Map.lookup (UVecType el_htype, fname) typefuns of
+ -- Function already generated, just return it
+ Just (id, _) -> return id
+ -- Function not generated yet, generate it
+ Nothing -> do
+ let functions = genUnconsVectorFuns elemTM vectorTM
+ case lookup fname functions of
+ Just body -> do
+ MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
+ mapM_ (vectorFunId el_ty) (snd body)
+ return function_id
+ Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
+ where
+ function_id = mkVHDLExtId fname
+
+genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
+ -> AST.TypeMark -- ^ type of the vector
+ -> [(String, (AST.SubProgBody, [String]))]
+genUnconsVectorFuns elemTM vectorTM =
+ [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
+ , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
+ , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
+ , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
+ , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
+ , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
+ , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
+ , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
+ , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
+ , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
+ , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
+ , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
+ , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
+ , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
+ , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
+ , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
+ , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
+ , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
+ , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
+ , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
+ , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
+ ]
+ where
+ ixPar = AST.unsafeVHDLBasicId "ix"
+ vecPar = AST.unsafeVHDLBasicId "vec"
+ vec1Par = AST.unsafeVHDLBasicId "vec1"
+ vec2Par = AST.unsafeVHDLBasicId "vec2"
+ nPar = AST.unsafeVHDLBasicId "n"
+ leftPar = AST.unsafeVHDLBasicId "nLeft"
+ rightPar = AST.unsafeVHDLBasicId "nRight"
+ iId = AST.unsafeVHDLBasicId "i"
+ iPar = iId
+ aPar = AST.unsafeVHDLBasicId "a"
+ fPar = AST.unsafeVHDLBasicId "f"
+ sPar = AST.unsafeVHDLBasicId "s"
+ resId = AST.unsafeVHDLBasicId "res"
+ exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec ixPar unsignedTM] elemTM
+ exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
+ (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
+ replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
+ , AST.IfaceVarDec iPar unsignedTM
+ , AST.IfaceVarDec aPar elemTM
+ ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ replaceVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
+ replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
+ replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
+ replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ vecSlice init last = AST.PrimName (AST.NSlice
+ (AST.SliceName
+ (AST.NSimple vecPar)
+ (AST.ToRange init last)))
+ lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(vec'length-1);
+ lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar)
+ [AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"])))
+ initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ initVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- resAST.:= vec(0 to vec'length-2)
+ initExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "2"))
+ initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
+ AST.IfaceVarDec rightPar naturalTM ] naturalTM
+ minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
+ [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
+ []
+ (Just $ AST.Else [minimumExprRet])
+ where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
+ takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
+ minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
+ ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
+ takeVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (minLength AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(0 to n-1)
+ takeExpr = AST.NSimple resId AST.:=
+ (vecSlice (AST.PrimLit "0")
+ (minLength AST.:-: AST.PrimLit "1"))
+ takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-n-1);
+ dropVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
+ Nothing
+ -- res AST.:= vec(n to vec'length-1)
+ dropExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimName $ AST.NSimple nPar)
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"))
+ dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
+ AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length);
+ plusgtVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
+ Nothing
+ plusgtExpr = AST.NSimple resId AST.:=
+ ((AST.PrimName $ AST.NSimple aPar) AST.:&:
+ (AST.PrimName $ AST.NSimple vecPar))
+ plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
+ emptyVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
+ Nothing
+ emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+ singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
+ vectorTM
+ -- variable res : fsvec_x (0 to 0) := (others => a);
+ singletonVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
+ (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
+ (AST.PrimName $ AST.NSimple aPar)])
+ singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to n-1) := (others => a);
+ copynVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+ (AST.PrimLit "1")) ]))
+ (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
+ (AST.PrimName $ AST.NSimple aPar)])
+ -- return res
+ copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
+ AST.IfaceVarDec sPar naturalTM,
+ AST.IfaceVarDec nPar naturalTM,
+ AST.IfaceVarDec vecPar vectorTM ] vectorTM
+ -- variable res : fsvec_x (0 to n-1);
+ selVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+ (AST.PrimLit "1")) ])
+ )
+ Nothing
+ -- for i res'range loop
+ -- res(i) := vec(f+i*s);
+ -- end loop;
+ selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
+ -- res(i) := vec(f+i*s);
+ selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
+ (AST.PrimName (AST.NSimple iId) AST.:*:
+ AST.PrimName (AST.NSimple sPar)) in
+ AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
+ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
+ -- return res;
+ selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+ ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length);
+ ltplusVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
+ Nothing
+ ltplusExpr = AST.NSimple resId AST.:=
+ ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
+ (AST.PrimName $ AST.NSimple aPar))
+ ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
+ AST.IfaceVarDec vec2Par vectorTM]
+ vectorTM
+ -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
+ plusplusVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
+ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.PrimLit "1")]))
+ Nothing
+ plusplusExpr = AST.NSimple resId AST.:=
+ ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
+ (AST.PrimName $ AST.NSimple vec2Par))
+ plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
+ lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
+ shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ shiftlVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res := a & init(vec)
+ shiftlExpr = AST.NSimple resId AST.:=
+ (AST.PrimName (AST.NSimple aPar) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
+ AST.IfaceVarDec aPar elemTM ] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ shiftrVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- res := tail(vec) & a
+ shiftrExpr = AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimName (AST.NSimple aPar)))
+
+ shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
+ -- return vec'length = 0
+ nullExpr = AST.ReturnSm (Just $
+ AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
+ AST.PrimLit "0")
+ rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ rotlVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- if null(vec) then res := vec else res := last(vec) & init(vec)
+ rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+ [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+ []
+ (Just $ AST.Else [rotlExprRet])
+ where rotlExprRet =
+ AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-1);
+ rotrVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- if null(vec) then res := vec else res := tail(vec) & head(vec)
+ rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+ [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+ []
+ (Just $ AST.Else [rotrExprRet])
+ where rotrExprRet =
+ AST.NSimple resId AST.:=
+ ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+ rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ reverseVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "1")) ]))
+ Nothing
+ -- for i in 0 to res'range loop
+ -- res(vec'length-i-1) := vec(i);
+ -- end loop;
+ reverseFor =
+ AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
+ -- res(vec'length-i-1) := vec(i);
+ reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
+ (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
+ [AST.PrimName $ AST.NSimple iId]))
+ where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
+ (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ AST.PrimName (AST.NSimple iId) AST.:-:
+ (AST.PrimLit "1")
+ -- return res;
+ reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+
+
+-----------------------------------------------------------------------------
+-- A table of builtin functions
+-----------------------------------------------------------------------------
+
+-- A function that generates VHDL for a builtin function
+type BuiltinBuilder =
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
+ -> CoreSyn.CoreBndr -- ^ The function called
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
+ -- dictionary arguments).
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
+ -- ^ The corresponding VHDL concurrent statements and entities
+ -- instantiated.
+
+-- A map of a builtin function to VHDL function builder
+type NameTable = Map.Map String (Int, BuiltinBuilder )
+
+-- | The builtin functions we support. Maps a name to an argument count and a
+-- builder function. If you add a name to this map, don't forget to add
+-- it to VHDL.Constants/builtinIds as well.
+globalNameTable :: NameTable
+globalNameTable = Map.fromList
+ [ (exId , (2, genFCall True ) )
+ , (replaceId , (3, genFCall False ) )
+ , (headId , (1, genFCall True ) )
+ , (lastId , (1, genFCall True ) )
+ , (tailId , (1, genFCall False ) )
+ , (initId , (1, genFCall False ) )
+ , (takeId , (2, genFCall False ) )
+ , (dropId , (2, genFCall False ) )
+ , (selId , (4, genFCall False ) )
+ , (plusgtId , (2, genFCall False ) )
+ , (ltplusId , (2, genFCall False ) )
+ , (plusplusId , (2, genFCall False ) )
+ , (mapId , (2, genMap ) )
+ , (zipWithId , (3, genZipWith ) )
+ , (foldlId , (3, genFoldl ) )
+ , (foldrId , (3, genFoldr ) )
+ , (zipId , (2, genZip ) )
+ , (unzipId , (1, genUnzip ) )
+ , (shiftlId , (2, genFCall False ) )
+ , (shiftrId , (2, genFCall False ) )
+ , (rotlId , (1, genFCall False ) )
+ , (rotrId , (1, genFCall False ) )
+ , (concatId , (1, genConcat ) )
+ , (reverseId , (1, genFCall False ) )
+ , (iteratenId , (3, genIteraten ) )
+ , (iterateId , (2, genIterate ) )
+ , (generatenId , (3, genGeneraten ) )
+ , (generateId , (2, genGenerate ) )
+ , (emptyId , (0, genFCall False ) )
+ , (singletonId , (1, genFCall False ) )
+ , (copynId , (2, genFCall False ) )
+ , (copyId , (1, genCopy ) )
+ , (lengthTId , (1, genFCall False ) )
+ , (nullId , (1, genFCall False ) )
+ , (hwxorId , (2, genOperator2 AST.Xor ) )
+ , (hwandId , (2, genOperator2 AST.And ) )
+ , (hworId , (2, genOperator2 AST.Or ) )
+ , (hwnotId , (1, genOperator1 AST.Not ) )
+ , (equalityId , (2, genOperator2 (AST.:=:) ) )
+ , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
+ , (ltId , (2, genOperator2 (AST.:<:) ) )
+ , (lteqId , (2, genOperator2 (AST.:<=:) ) )
+ , (gtId , (2, genOperator2 (AST.:>:) ) )
+ , (gteqId , (2, genOperator2 (AST.:>=:) ) )
+ , (boolOrId , (2, genOperator2 AST.Or ) )
+ , (boolAndId , (2, genOperator2 AST.And ) )
+ , (boolNot , (1, genOperator1 AST.Not ) )
+ , (plusId , (2, genOperator2 (AST.:+:) ) )
+ , (timesId , (2, genTimes ) )
+ , (negateId , (1, genNegation ) )
+ , (minusId , (2, genOperator2 (AST.:-:) ) )
+ , (fromSizedWordId , (1, genFromSizedWord ) )
+ , (fromRangedWordId , (1, genFromRangedWord ) )
+ , (fromIntegerId , (1, genFromInteger ) )
+ , (resizeWordId , (1, genResize ) )
+ , (resizeIntId , (1, genResize ) )
+ , (sizedIntId , (1, genSizedInt ) )
+ , (smallIntegerId , (1, genFromInteger ) )
+ , (fstId , (1, genFst ) )
+ , (sndId , (1, genSnd ) )
+ , (blockRAMId , (5, genBlockRAM ) )
+ , (splitId , (1, genSplit ) )
+ --, (tfvecId , (1, genTFVec ) )
+ , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
+ ]
--- /dev/null
+--
+-- Functions to create a VHDL testbench from a list of test input.
+--
+module CLasH.VHDL.Testbench where
+
+-- Standard modules
+import qualified Control.Monad as Monad
+import qualified Maybe
+import qualified Data.Map as Map
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import qualified CoreSyn
+import qualified HscTypes
+import qualified Var
+import qualified TysWiredIn
+
+-- Local imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.Constants
+import CLasH.VHDL.Generate
+import CLasH.VHDL.VHDLTools
+import CLasH.VHDL.VHDLTypes
+import CLasH.Normalize
+import CLasH.Utils.Core.BinderTools
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils
+
+createTestbench ::
+ Maybe Int -- ^ Number of cycles to simulate
+ -> [HscTypes.CoreModule] -- ^ Compiled modules
+ -> CoreSyn.CoreExpr -- ^ Input stimuli
+ -> CoreSyn.CoreBndr -- ^ Top Entity
+ -> TranslatorSession CoreSyn.CoreBndr -- ^ The id of the generated archictecture
+createTestbench mCycles cores stimuli top = do
+ stimuli' <- reduceCoreListToHsList cores stimuli
+ -- Create a binder for the testbench. We use the unit type (), since the
+ -- testbench has no outputs and no inputs.
+ bndr <- mkInternalVar "testbench" TysWiredIn.unitTy
+ let entity = createTestbenchEntity bndr
+ MonadState.modify tsEntities (Map.insert bndr entity)
+ arch <- createTestbenchArch mCycles stimuli' top entity
+ MonadState.modify tsArchitectures (Map.insert bndr arch)
+ return bndr
+
+createTestbenchEntity ::
+ CoreSyn.CoreBndr
+ -> Entity
+createTestbenchEntity bndr = entity
+ where
+ vhdl_id = mkVHDLBasicId "testbench"
+ -- Create an AST entity declaration with no ports
+ ent_decl = AST.EntityDec vhdl_id []
+ -- Create a signature with no input and no output ports
+ entity = Entity vhdl_id [] undefined ent_decl
+
+createTestbenchArch ::
+ Maybe Int -- ^ Number of cycles to simulate
+ -> [CoreSyn.CoreExpr] -- ^ Imput stimuli
+ -> CoreSyn.CoreBndr -- ^ Top Entity
+ -> Entity -- ^ The signature to create an architecture for
+ -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
+ -- ^ The architecture and any other entities used.
+createTestbenchArch mCycles stimuli top testent= do
+ signature <- getEntity top
+ let entId = ent_id signature
+ iIface = ent_args signature
+ oIface = ent_res signature
+ iIds = map fst iIface
+ let (oId, oDec, oProc) = case oIface of
+ Just (id, ty) -> ( id
+ , [AST.SigDec id ty Nothing]
+ , [createOutputProc [id]])
+ -- No output port? Just use undefined for the output id, since it won't be
+ -- used by mkAssocElems when there is no output port.
+ Nothing -> (undefined, [], [])
+ let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
+ let finalIDecs = iDecs ++
+ [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
+ AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
+ let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature
+ let mIns = mkComponentInst "totest" entId portmaps
+ (stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds)
+ let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
+ AST.ConWforms []
+ (AST.Wform [AST.WformElem (AST.PrimLit "'0'") (Just $ AST.PrimLit "0 ns"), AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
+ Nothing)) : stimuliAssigns
+ let clkProc = createClkProc
+ let arch = AST.ArchBody
+ (AST.unsafeVHDLBasicId "test")
+ (AST.NSimple $ ent_id testent)
+ (map AST.BDISD (finalIDecs ++ stimuliDecs ++ oDec))
+ (mIns :
+ ( (AST.CSPSm clkProc) : (fmap AST.CSPSm oProc) ++ finalAssigns ) )
+ return (arch, top : used)
+
+createStimuliAssigns ::
+ Maybe Int -- ^ Number of cycles to simulate
+ -> [CoreSyn.CoreExpr] -- ^ Input stimuli
+ -> AST.VHDLId -- ^ Input signal
+ -> TranslatorSession ( [AST.ConcSm]
+ , [AST.SigDec]
+ , Int
+ , [CoreSyn.CoreBndr]) -- ^ (Resulting statements, Needed signals, The number of cycles to simulate, Any entities used)
+createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles, [])
+
+createStimuliAssigns mCycles stimuli signal = do
+ let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
+ let inputlen = length stimuli
+ assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
+ let (stimuli_sms, resvars, useds) = unzip3 assigns
+ sig_dec_maybes <- mapM mkSigDec resvars
+ let sig_decs = Maybe.catMaybes sig_dec_maybes
+ outps <- mapM (\x -> MonadState.lift tsType (varToVHDLExpr x)) resvars
+ let wformelems = zipWith genWformElem [0,10..] outps
+ let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
+ case (concat stimuli_sms) of
+ [] -> return ([inassign], [], inputlen, concat useds)
+ stims -> return (stims ++ [inassign], sig_decs, inputlen, concat useds)
+
+createStimulans ::
+ CoreSyn.CoreExpr -- ^ The stimulans
+ -> Int -- ^ The cycle for this stimulans
+ -> TranslatorSession ( [AST.ConcSm]
+ , Var.Var
+ , [CoreSyn.CoreBndr]) -- ^ (The statement, the variable it assigns to (assumed to be available!), Any entities used by this stimulans)
+
+createStimulans expr cycl = do
+ -- There must be a let at top level
+ expr <- normalizeExpr ("test input #" ++ show cycl) expr
+ -- Split the normalized expression. It can't have a function type, so match
+ -- an empty list of argument binders
+ let ([], binds, res) = splitNormalized expr
+ (stimulansbindss, useds) <- unzipM $ Monad.mapM mkConcSm binds
+ sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
+ let sig_decs = map (AST.BDISD) (Maybe.catMaybes sig_dec_maybes)
+ let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbindss)
+ case (sig_decs,(concat stimulansbindss)) of
+ ([],[]) -> return ([], res, concat useds)
+ otherwise -> return ([AST.CSBSm block], res, concat useds)
+
+-- | generates a clock process with a period of 10ns
+createClkProc :: AST.ProcSm
+createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
+ where sms = -- wait for 5 ns -- (half a cycle)
+ [AST.WaitFor $ AST.PrimLit "5 ns",
+ -- clk <= not clk;
+ AST.NSimple clockId `AST.SigAssign`
+ AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
+
+-- | generate the output process
+createOutputProc :: [AST.VHDLId] -- ^ output signal
+ -> AST.ProcSm
+createOutputProc outs =
+ AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
+ [clockId]
+ [AST.IfSm clkPred (writeOuts outs) [] Nothing]
+ where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
+ (AST.NSimple eventId)
+ Nothing ) `AST.And`
+ (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
+ writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
+ writeOuts [] = []
+ writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
+ writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
+ writeOut outSig suffix =
+ genExprPCall2 writeId
+ (AST.PrimName $ AST.NSimple outputId)
+ ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)
--- /dev/null
+{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
+module CLasH.VHDL.VHDLTools where
+
+-- Standard modules
+import qualified Maybe
+import qualified Data.Either as Either
+import qualified Data.List as List
+import qualified Data.Char as Char
+import qualified Data.Map as Map
+import qualified Control.Monad as Monad
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import qualified CoreSyn
+import qualified Name
+import qualified OccName
+import qualified Var
+import qualified Id
+import qualified TyCon
+import qualified Type
+import qualified DataCon
+import qualified CoreSubst
+import qualified Outputable
+
+-- Local imports
+import CLasH.VHDL.VHDLTypes
+import CLasH.Translator.TranslatorTypes
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils
+import CLasH.Utils.Pretty
+import CLasH.VHDL.Constants
+
+-----------------------------------------------------------------------------
+-- Functions to generate concurrent statements
+-----------------------------------------------------------------------------
+
+-- Create an unconditional assignment statement
+mkUncondAssign ::
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
+ -> AST.Expr -- ^ The expression to assign
+ -> AST.ConcSm -- ^ The resulting concurrent statement
+mkUncondAssign dst expr = mkAssign dst Nothing expr
+
+-- Create a conditional assignment statement
+mkCondAssign ::
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
+ -> AST.Expr -- ^ The condition
+ -> AST.Expr -- ^ The value when true
+ -> AST.Expr -- ^ The value when false
+ -> AST.ConcSm -- ^ The resulting concurrent statement
+mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
+
+-- Create a conditional or unconditional assignment statement
+mkAssign ::
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
+ -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
+ -- and the value to assign when true.
+ -> AST.Expr -- ^ The value to assign when false or no condition
+ -> AST.ConcSm -- ^ The resulting concurrent statement
+mkAssign dst cond false_expr =
+ let
+ -- I'm not 100% how this assignment AST works, but this gets us what we
+ -- want...
+ whenelse = case cond of
+ Just (cond_expr, true_expr) ->
+ let
+ true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+ in
+ [AST.WhenElse true_wform cond_expr]
+ Nothing -> []
+ false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+ dst_name = case dst of
+ Left bndr -> AST.NSimple (varToVHDLId bndr)
+ Right name -> name
+ assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
+ in
+ AST.CSSASm assign
+
+mkAltsAssign ::
+ Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
+ -> [AST.Expr] -- ^ The conditions
+ -> [AST.Expr] -- ^ The expressions
+ -> AST.ConcSm -- ^ The Alt assigns
+mkAltsAssign dst conds exprs
+ | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
+ | otherwise =
+ let
+ whenelses = zipWith mkWhenElse conds exprs
+ false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
+ dst_name = case dst of
+ Left bndr -> AST.NSimple (varToVHDLId bndr)
+ Right name -> name
+ assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
+ in
+ AST.CSSASm assign
+ where
+ mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
+ mkWhenElse cond true_expr =
+ let
+ true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+ in
+ AST.WhenElse true_wform cond
+
+mkAssocElems ::
+ [AST.Expr] -- ^ The argument that are applied to function
+ -> AST.VHDLName -- ^ The binder in which to store the result
+ -> Entity -- ^ The entity to map against.
+ -> [AST.AssocElem] -- ^ The resulting port maps
+mkAssocElems args res entity =
+ arg_maps ++ (Maybe.maybeToList res_map_maybe)
+ where
+ arg_ports = ent_args entity
+ res_port_maybe = ent_res entity
+ -- Create an expression of res to map against the output port
+ res_expr = vhdlNameToVHDLExpr res
+ -- Map each of the input ports
+ arg_maps = zipWith mkAssocElem (map fst arg_ports) args
+ -- Map the output port, if present
+ res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
+
+-- | Create an VHDL port -> signal association
+mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
+mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
+
+-- | Create an aggregate signal
+mkAggregateSignal :: [AST.Expr] -> AST.Expr
+mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
+
+mkComponentInst ::
+ String -- ^ The portmap label
+ -> AST.VHDLId -- ^ The entity name
+ -> [AST.AssocElem] -- ^ The port assignments
+ -> AST.ConcSm
+mkComponentInst label entity_id portassigns = AST.CSISm compins
+ where
+ -- We always have a clock port, so no need to map it anywhere but here
+ clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
+ resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
+ compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL Exprs
+-----------------------------------------------------------------------------
+
+varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
+varToVHDLExpr var =
+ case Id.isDataConWorkId_maybe var of
+ -- This is a dataconstructor.
+ Just dc -> dataconToVHDLExpr dc
+ -- Not a datacon, just another signal.
+ Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
+
+-- Turn a VHDLName into an AST expression
+vhdlNameToVHDLExpr = AST.PrimName
+
+-- Turn a VHDL Id into an AST expression
+idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
+
+-- Turn a Core expression into an AST expression
+exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
+
+-- Turn a alternative constructor into an AST expression. For
+-- dataconstructors, this is only the constructor itself, not any arguments it
+-- has. Should not be called with a DEFAULT constructor.
+altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
+altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
+
+altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
+altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
+
+-- Turn a datacon (without arguments!) into a VHDL expression.
+dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
+dataconToVHDLExpr dc = do
+ typemap <- MonadState.get tsTypes
+ htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
+ case htype_either of
+ -- No errors
+ Right htype -> do
+ let dcname = DataCon.dataConName dc
+ case htype of
+ (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+ (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+ otherwise -> do
+ let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
+ case existing_ty of
+ Just ty -> do
+ let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+ return lit
+ Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
+ -- Error when constructing htype
+ Left err -> error err
+
+-----------------------------------------------------------------------------
+-- Functions dealing with names, variables and ids
+-----------------------------------------------------------------------------
+
+-- Creates a VHDL Id from a binder
+varToVHDLId ::
+ CoreSyn.CoreBndr
+ -> AST.VHDLId
+varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
+ where
+ lowers :: String -> Int
+ lowers xs = length [x | x <- xs, Char.isLower x]
+
+-- Creates a VHDL Name from a binder
+varToVHDLName ::
+ CoreSyn.CoreBndr
+ -> AST.VHDLName
+varToVHDLName = AST.NSimple . varToVHDLId
+
+-- Extracts the binder name as a String
+varToString ::
+ CoreSyn.CoreBndr
+ -> String
+varToString = OccName.occNameString . Name.nameOccName . Var.varName
+
+-- Get the string version a Var's unique
+varToStringUniq :: Var.Var -> String
+varToStringUniq = show . Var.varUnique
+
+-- Extracts the string version of the name
+nameToString :: Name.Name -> String
+nameToString = OccName.occNameString . Name.nameOccName
+
+-- Shortcut for Basic VHDL Ids.
+-- Can only contain alphanumerics and underscores. The supplied string must be
+-- a valid basic id, otherwise an error value is returned. This function is
+-- not meant to be passed identifiers from a source file, use mkVHDLExtId for
+-- that.
+mkVHDLBasicId :: String -> AST.VHDLId
+mkVHDLBasicId s =
+ AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
+ where
+ -- Strip invalid characters.
+ strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
+ -- Strip leading numbers and underscores
+ strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
+ -- Strip multiple adjacent underscores
+ strip_multiscore = concatMap (\cs ->
+ case cs of
+ ('_':_) -> "_"
+ _ -> cs
+ ) . List.group
+
+-- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
+-- different characters than basic ids, but can never be used to refer to
+-- basic ids.
+-- Use extended Ids for any values that are taken from the source file.
+mkVHDLExtId :: String -> AST.VHDLId
+mkVHDLExtId s =
+ AST.unsafeVHDLExtId $ strip_invalid s
+ where
+ -- Allowed characters, taken from ForSyde's mkVHDLExtId
+ allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
+ strip_invalid = filter (`elem` allowed)
+
+-- Create a record field selector that selects the given label from the record
+-- stored in the given binder.
+mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
+mkSelectedName name label =
+ AST.NSelected $ name AST.:.: (AST.SSimple label)
+
+-- Create an indexed name that selects a given element from a vector.
+mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
+-- Special case for already indexed names. Just add an index
+mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
+ AST.NIndexed (AST.IndexedName name (indexes++[index]))
+-- General case for other names
+mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
+
+-----------------------------------------------------------------------------
+-- Functions dealing with VHDL types
+-----------------------------------------------------------------------------
+builtin_types :: TypeMap
+builtin_types =
+ Map.fromList [
+ (BuiltinType "Bit", Just (std_logicTM, Nothing)),
+ (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
+ ]
+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+ ty_either <- mkHTypeEither ty
+ return $ case ty_either of
+ Left _ -> False
+ Right _ -> True
+
+-- | Turn a Core type into a HType, returning an error using the given
+-- error string if the type was not representable.
+mkHType :: (TypedThing t, Outputable.Outputable t) =>
+ String -> t -> TypeSession HType
+mkHType msg ty = do
+ htype_either <- mkHTypeEither ty
+ case htype_either of
+ Right htype -> return htype
+ Left err -> error $ msg ++ err
+
+-- | Turn a Core type into a HType. Returns either an error message if
+-- the type was not representable, or the HType generated.
+mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
+ t -> TypeSession (Either String HType)
+mkHTypeEither tything =
+ case getType tything of
+ Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
+ Just ty -> mkHTypeEither' ty
+
+mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
+mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
+ | isStateType ty = return $ Right StateType
+ | otherwise =
+ case Type.splitTyConApp_maybe ty of
+ Just (tycon, args) -> do
+ typemap <- MonadState.get tsTypes
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
+ case builtinTyMaybe of
+ (Just x) -> return $ Right $ BuiltinType name
+ Nothing ->
+ case name of
+ "Vector" -> do
+ let el_ty = tfvec_elem ty
+ elem_htype_either <- mkHTypeEither el_ty
+ case elem_htype_either of
+ -- Could create element type
+ Right elem_htype -> do
+ len <- tfp_to_int (tfvec_len_ty ty)
+ return $ Right $ VecType len elem_htype
+ -- Could not create element type
+ Left err -> return $ Left $
+ "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
+ "Unsigned" -> do
+ len <- tfp_to_int (sized_word_len_ty ty)
+ return $ Right $ SizedWType len
+ "Signed" -> do
+ len <- tfp_to_int (sized_word_len_ty ty)
+ return $ Right $ SizedIType len
+ "Index" -> do
+ bound <- tfp_to_int (ranged_word_bound_ty ty)
+ return $ Right $ RangedWType bound
+ otherwise ->
+ mkTyConHType tycon args
+ Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
+
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
+mkTyConHType tycon args =
+ case TyCon.tyConDataCons tycon of
+ -- Not an algebraic type
+ [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
+ [dc] -> do
+ let arg_tys = DataCon.dataConRepArgTys dc
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
+ elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
+ case Either.partitionEithers elem_htys_either of
+ ([], [elem_hty]) ->
+ return $ Right elem_hty
+ -- No errors in element types
+ ([], elem_htys) ->
+ return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
+ -- There were errors in element types
+ (errors, _) -> return $ Left $
+ "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+ ++ (concat errors)
+ dcs -> do
+ let arg_tys = concatMap DataCon.dataConRepArgTys dcs
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ case real_arg_tys of
+ [] ->
+ return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
+ xs -> return $ Left $
+ "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
+ where
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+-- Returns an error value, using the given message, when no type could be
+-- created. Returns Nothing when the type is valid, but empty.
+vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
+ String -> t -> TypeSession (Maybe AST.TypeMark)
+vhdlTy msg ty = do
+ htype <- mkHType msg ty
+ vhdlTyMaybe htype
+
+vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
+vhdlTyMaybe htype = do
+ typemap <- MonadState.get tsTypes
+ -- If not a builtin type, try the custom types
+ let existing_ty = Map.lookup htype typemap
+ case existing_ty of
+ -- Found a type, return it
+ Just (Just (t, _)) -> return $ Just t
+ Just (Nothing) -> return Nothing
+ -- No type yet, try to construct it
+ Nothing -> do
+ newty <- (construct_vhdl_ty htype)
+ MonadState.modify tsTypes (Map.insert htype newty)
+ case newty of
+ Just (ty_id, ty_def) -> do
+ MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ return $ Just ty_id
+ Nothing -> return Nothing
+
+-- Construct a new VHDL type for the given Haskell type. Returns an error
+-- message or the resulting typemark and typedef.
+construct_vhdl_ty :: HType -> TypeSession TypeMapRec
+-- State types don't generate VHDL
+construct_vhdl_ty htype =
+ case htype of
+ StateType -> return Nothing
+ (SizedWType w) -> mkUnsignedTy w
+ (SizedIType i) -> mkSignedTy i
+ (RangedWType u) -> mkNaturalTy 0 u
+ (VecType n e) -> mkVectorTy (VecType n e)
+ -- Create a custom type from this tycon
+ otherwise -> mkTyconTy htype
+
+-- | Create VHDL type for a custom tycon
+mkTyconTy :: HType -> TypeSession TypeMapRec
+mkTyconTy htype =
+ case htype of
+ (AggrType tycon args) -> do
+ elemTysMaybe <- mapM vhdlTyMaybe args
+ case Maybe.catMaybes elemTysMaybe of
+ [] -> -- No non-empty members
+ return Nothing
+ elem_tys -> do
+ let elems = zipWith AST.ElementDec recordlabels elem_tys
+ let elem_names = concatMap prettyShow elem_tys
+ let ty_id = mkVHDLExtId $ tycon ++ elem_names
+ let ty_def = AST.TDR $ AST.RecordTypeDef elems
+ let tupshow = mkTupleShow elem_tys ty_id
+ MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
+ return $ Just (ty_id, Just $ Left ty_def)
+ (EnumType tycon dcs) -> do
+ let elems = map mkVHDLExtId dcs
+ let ty_id = mkVHDLExtId tycon
+ let ty_def = AST.TDE $ AST.EnumTypeDef elems
+ let enumShow = mkEnumShow elems ty_id
+ MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
+ return $ Just (ty_id, Just $ Left ty_def)
+ otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
+ where
+ -- Generate a bunch of labels for fields of a record
+ recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+
+-- | Create a VHDL vector type
+mkVectorTy ::
+ HType -- ^ The Haskell type of the Vector
+ -> TypeSession TypeMapRec
+ -- ^ An error message or The typemark created.
+
+mkVectorTy (VecType len elHType) = do
+ typesMap <- MonadState.get tsTypes
+ elTyTmMaybe <- vhdlTyMaybe elHType
+ case elTyTmMaybe of
+ (Just elTyTm) -> do
+ let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
+ let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
+ case existing_uvec_ty of
+ Just (Just t) -> do
+ let ty_def = AST.SubtypeIn t (Just range)
+ return (Just (ty_id, Just $ Right ty_def))
+ Nothing -> do
+ let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
+ let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
+ MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
+ MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
+ let vecShowFuns = mkVectorShow elTyTm vec_id
+ mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
+ let ty_def = AST.SubtypeIn vec_id (Just range)
+ return (Just (ty_id, Just $ Right ty_def))
+ -- Vector of empty elements becomes empty itself.
+ Nothing -> return Nothing
+mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
+
+mkNaturalTy ::
+ Int -- ^ The minimum bound (> 0)
+ -> Int -- ^ The maximum bound (> minimum bound)
+ -> TypeSession TypeMapRec
+ -- ^ An error message or The typemark created.
+mkNaturalTy min_bound max_bound = do
+ let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
+ let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+ let ty_def = AST.SubtypeIn unsignedTM (Just range)
+ return (Just (ty_id, Just $ Right ty_def))
+
+mkUnsignedTy ::
+ Int -- ^ Haskell type of the unsigned integer
+ -> TypeSession TypeMapRec
+mkUnsignedTy size = do
+ let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_def = AST.SubtypeIn unsignedTM (Just range)
+ return (Just (ty_id, Just $ Right ty_def))
+
+mkSignedTy ::
+ Int -- ^ Haskell type of the signed integer
+ -> TypeSession TypeMapRec
+mkSignedTy size = do
+ let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_def = AST.SubtypeIn signedTM (Just range)
+ return (Just (ty_id, Just $ Right ty_def))
+
+-- Finds the field labels for VHDL type generated for the given Core type,
+-- which must result in a record type.
+getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
+getFieldLabels ty = do
+ -- Ensure that the type is generated (but throw away it's VHDLId)
+ let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
+ vhdlTy error_msg ty
+ -- Get the types map, lookup and unpack the VHDL TypeDef
+ types <- MonadState.get tsTypes
+ -- Assume the type for which we want labels is really translatable
+ htype <- mkHType error_msg ty
+ case Map.lookup htype types of
+ Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype)
+ Just Nothing -> return [] -- The type is empty
+ Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+ Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)
+
+mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
+mytydecl (_, Nothing) = Nothing
+mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
+
+mkTupleShow ::
+ [AST.TypeMark] -- ^ type of each tuple element
+ -> AST.TypeMark -- ^ type of the tuple
+ -> AST.SubProgBody
+mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
+ where
+ tupPar = AST.unsafeVHDLBasicId "tup"
+ showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
+ showExpr = AST.ReturnSm (Just $
+ AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
+ where
+ showMiddle = if null elemTMs then
+ AST.PrimLit "''"
+ else
+ foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
+ map ((genExprFCall showId).
+ AST.PrimName .
+ AST.NSelected .
+ (AST.NSimple tupPar AST.:.:).
+ tupVHDLSuffix)
+ (take tupSize recordlabels)
+ recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+ tupSize = length elemTMs
+
+mkEnumShow ::
+ [AST.VHDLId]
+ -> AST.TypeMark
+ -> AST.SubProgBody
+mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
+ where
+ enumPar = AST.unsafeVHDLBasicId "enum"
+ showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
+ showExpr = AST.ReturnSm (Just $
+ AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
+
+mkVectorShow ::
+ AST.TypeMark -- ^ elemtype
+ -> AST.TypeMark -- ^ vectype
+ -> [(String,AST.SubProgBody)]
+mkVectorShow elemTM vectorTM =
+ [ (headId, AST.SubProgBody headSpec [] [headExpr])
+ , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
+ , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
+ ]
+ where
+ vecPar = AST.unsafeVHDLBasicId "vec"
+ resId = AST.unsafeVHDLBasicId "res"
+ headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
+ -- return vec(0);
+ headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
+ (AST.NSimple vecPar) [AST.PrimLit "0"])))
+ vecSlice init last = AST.PrimName (AST.NSlice
+ (AST.SliceName
+ (AST.NSimple vecPar)
+ (AST.ToRange init last)))
+ tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+ -- variable res : fsvec_x (0 to vec'length-2);
+ tailVar =
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
+ (AST.PrimLit "2")) ]))
+ Nothing
+ -- res AST.:= vec(1 to vec'length-1)
+ tailExpr = AST.NSimple resId AST.:= (vecSlice
+ (AST.PrimLit "1")
+ (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
+ AST.:-: AST.PrimLit "1"))
+ tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+ showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
+ doShowId = AST.unsafeVHDLExtId "doshow"
+ doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
+ where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
+ stringTM
+ -- case vec'len is
+ -- when 0 => return "";
+ -- when 1 => return head(vec);
+ -- when others => return show(head(vec)) & ',' &
+ -- doshow (tail(vec));
+ -- end case;
+ doShowRet =
+ AST.CaseSm (AST.PrimName (AST.NAttribute $
+ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
+ [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
+ [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
+ AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
+ [AST.ReturnSm (Just $
+ genExprFCall showId
+ (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
+ AST.CaseSmAlt [AST.Others]
+ [AST.ReturnSm (Just $
+ genExprFCall showId
+ (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
+ AST.PrimLit "','" AST.:&:
+ genExprFCall doShowId
+ (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
+ -- return '<' & doshow(vec) & '>';
+ showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
+ genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
+ AST.PrimLit "'>'" )
+
+mkBuiltInShow :: [AST.SubProgBody]
+mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
+ , AST.SubProgBody showBoolSpec [] [showBoolExpr]
+ , AST.SubProgBody showSingedSpec [] [showSignedExpr]
+ , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
+ -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
+ ]
+ where
+ bitPar = AST.unsafeVHDLBasicId "s"
+ boolPar = AST.unsafeVHDLBasicId "b"
+ signedPar = AST.unsafeVHDLBasicId "sint"
+ unsignedPar = AST.unsafeVHDLBasicId "uint"
+ -- naturalPar = AST.unsafeVHDLBasicId "nat"
+ showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
+ -- if s = '1' then return "'1'" else return "'0'"
+ showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
+ [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
+ []
+ (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
+ showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
+ -- if b then return "True" else return "False"
+ showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
+ [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
+ []
+ (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
+ showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+ showSignedExpr = AST.ReturnSm (Just $
+ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
+ where
+ signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
+ showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
+ showUnsignedExpr = AST.ReturnSm (Just $
+ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
+ where
+ unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
+ -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
+ -- showNaturalExpr = AST.ReturnSm (Just $
+ -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
+
+
+genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
+genExprFCall fName args =
+ AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
+
+genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
+genExprPCall2 entid arg1 arg2 =
+ AST.ProcCall (AST.NSimple entid) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
+
+mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
+mkSigDec bndr = do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
+ type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
+ case type_mark_maybe of
+ Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ Nothing -> return Nothing
+
+-- | Does the given thing have a non-empty type?
+hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
+ t -> TranslatorSession Bool
+hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)
--- /dev/null
+--
+-- Some types used by the VHDL module.
+--
+module CLasH.VHDL.VHDLTypes where
+
+-- VHDL imports
+import qualified Language.VHDL.AST as AST
+
+-- A description of a port of an entity
+type Port = (AST.VHDLId, AST.TypeMark)
+
+-- A description of a VHDL entity. Contains both the entity itself as well as
+-- info on how to map a haskell value (argument / result) on to the entity's
+-- ports.
+data Entity = Entity {
+ ent_id :: AST.VHDLId, -- ^ The id of the entity
+ ent_args :: [Port], -- ^ A port for each non-empty function argument
+ ent_res :: Maybe Port, -- ^ The output port
+ ent_dec :: AST.EntityDec -- ^ The complete entity declaration
+} deriving (Show);
+
+type Architecture = AST.ArchBody
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
--- /dev/null
+{-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
+module Data.Param.Index
+ ( Index
+ , fromNaturalT
+ , fromUnsigned
+ , rangeT
+ ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Data.Bits
+import Types
+import Types.Data.Num.Decimal.Literals.TH
+
+import Data.Param.Integer
+
+instance NaturalT nT => Lift (Index nT) where
+ lift (Index i) = sigE [| (Index i) |] (decIndexT (fromIntegerT (undefined :: nT)))
+
+decIndexT :: Integer -> Q Type
+decIndexT n = appT (conT (''Index)) (decLiteralT n)
+
+fromNaturalT :: ( NaturalT n
+ , NaturalT upper
+ , (n :<=: upper) ~ True ) => n -> Index upper
+fromNaturalT x = Index (fromIntegerT x)
+
+fromUnsigned ::
+ ( NaturalT nT
+ , Integral (Unsigned nT)
+ ) => Unsigned nT -> Index ((Pow2 nT) :-: D1)
+fromUnsigned unsigned = Index (toInteger unsigned)
+
+rangeT :: Index nT -> nT
+rangeT _ = undefined
+
+instance NaturalT nT => Eq (Index nT) where
+ (Index x) == (Index y) = x == y
+ (Index x) /= (Index y) = x /= y
+
+instance NaturalT nT => Show (Index nT) where
+ showsPrec prec n =
+ showsPrec prec $ toInteger n
+
+instance NaturalT nT => Ord (Index nT) where
+ a `compare` b = toInteger a `compare` toInteger b
+
+instance NaturalT nT => Bounded (Index nT) where
+ minBound = 0
+ maxBound = Index (fromIntegerT (undefined :: nT))
+
+instance NaturalT nT => Enum (Index nT) where
+ succ x
+ | x == maxBound = error $ "Enum.succ{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
+ | otherwise = x + 1
+ pred x
+ | x == minBound = error $ "Enum.succ{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
+ | otherwise = x - 1
+
+ fromEnum (Index x)
+ | x > toInteger (maxBound :: Int) =
+ error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index greater than maxBound :: Int"
+ | x < toInteger (minBound :: Int) =
+ error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index smaller than minBound :: Int"
+ | otherwise =
+ fromInteger x
+ toEnum x
+ | x > fromIntegral (maxBound :: Index nT) =
+ error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index greater than maxBound :: Index " ++ show (fromIntegerT (undefined :: nT))
+ | x < fromIntegral (minBound :: Index nT) =
+ error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index smaller than minBound :: Index " ++ show (fromIntegerT (undefined :: nT))
+ | otherwise =
+ fromInteger $ toInteger x
+
+instance NaturalT nT => Num (Index nT) where
+ (Index a) + (Index b) =
+ fromInteger $ a + b
+ (Index a) * (Index b) =
+ fromInteger $ a * b
+ (Index a) - (Index b) =
+ fromInteger $ a - b
+ fromInteger n
+ | n > fromIntegerT (undefined :: nT) =
+ error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index larger than " ++ show (fromIntegerT (undefined :: nT)) ++ ", n: " ++ show n
+ fromInteger n
+ | n < 0 =
+ error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index smaller than 0, n: " ++ show n
+ fromInteger n =
+ Index n
+ abs s = s
+ signum s
+ | s == 0 =
+ 0
+ | otherwise =
+ 1
+
+instance NaturalT nT => Real (Index nT) where
+ toRational n = toRational $ toInteger n
+
+instance NaturalT nT => Integral (Index nT) where
+ a `quotRem` b =
+ let (quot, rem) = toInteger a `quotRem` toInteger b
+ in (fromInteger quot, fromInteger rem)
+ toInteger s@(Index x) = x
--- /dev/null
+module Data.Param.Integer
+ ( Signed(..)
+ , Unsigned(..)
+ , Index (..)
+ ) where
+
+import Types
+
+newtype (NaturalT nT) => Signed nT = Signed Integer
+
+newtype (NaturalT nT) => Unsigned nT = Unsigned Integer
+
+newtype (NaturalT upper) => Index upper = Index Integer
\ No newline at end of file
--- /dev/null
+{-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
+module Data.Param.Signed
+ ( Signed
+ , resize
+ ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Data.Bits
+import Types
+import Types.Data.Num.Decimal.Literals.TH
+
+import Data.Param.Integer
+
+instance NaturalT nT => Lift (Signed nT) where
+ lift (Signed i) = sigE [| (Signed i) |] (decSignedT (fromIntegerT (undefined :: nT)))
+
+decSignedT :: Integer -> Q Type
+decSignedT n = appT (conT (''Signed)) (decLiteralT n)
+
+resize :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'
+resize a = fromInteger (toInteger a)
+
+sizeT :: Signed nT
+ -> nT
+sizeT _ = undefined
+
+mask :: forall nT . NaturalT nT
+ => nT
+ -> Integer
+mask _ = bit (fromIntegerT (undefined :: nT)) - 1
+
+signBit :: forall nT . NaturalT nT
+ => nT
+ -> Int
+signBit _ = fromIntegerT (undefined :: nT) - 1
+
+isNegative :: forall nT . NaturalT nT
+ => Signed nT
+ -> Bool
+isNegative (Signed x) =
+ testBit x $ signBit (undefined :: nT)
+
+instance NaturalT nT => Eq (Signed nT) where
+ (Signed x) == (Signed y) = x == y
+ (Signed x) /= (Signed y) = x /= y
+
+instance NaturalT nT => Show (Signed nT) where
+ showsPrec prec n =
+ showsPrec prec $ toInteger n
+
+instance NaturalT nT => Read (Signed nT) where
+ readsPrec prec str =
+ [ (fromInteger n, str)
+ | (n, str) <- readsPrec prec str ]
+
+instance NaturalT nT => Ord (Signed nT) where
+ a `compare` b = toInteger a `compare` toInteger b
+
+instance NaturalT nT => Bounded (Signed nT) where
+ minBound = Signed $ negate $ 1 `shiftL` (fromIntegerT (undefined :: nT) - 1)
+ maxBound = Signed $ (1 `shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1
+
+instance NaturalT nT => Enum (Signed nT) where
+ succ x
+ | x == maxBound = error $ "Enum.succ{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
+ | otherwise = x + 1
+ pred x
+ | x == minBound = error $ "Enum.succ{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
+ | otherwise = x - 1
+
+ fromEnum (Signed x)
+ | x > toInteger (maxBound :: Int) =
+ error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed greater than maxBound :: Int"
+ | x < toInteger (minBound :: Int) =
+ error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed smaller than minBound :: Int"
+ | otherwise =
+ fromInteger x
+ toEnum x
+ | x' > toInteger (maxBound :: Signed nT) =
+ error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed greater than maxBound :: Signed " ++ show (fromIntegerT (undefined :: nT))
+ | x' < toInteger (minBound :: Signed nT) =
+ error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed smaller than minBound :: Signed " ++ show (fromIntegerT (undefined :: nT))
+ | otherwise =
+ fromInteger x'
+ where x' = toInteger x
+
+instance NaturalT nT => Num (Signed nT) where
+ (Signed a) + (Signed b) =
+ fromInteger $ a + b
+ (Signed a) * (Signed b) =
+ fromInteger $ a * b
+ negate (Signed n) =
+ fromInteger $ (n `xor` mask (undefined :: nT)) + 1
+ a - b =
+ a + (negate b)
+
+ fromInteger n
+ | n > 0 =
+ Signed $ n .&. mask (undefined :: nT)
+ fromInteger n
+ | n < 0 =
+ negate $ fromInteger $ negate n
+ fromInteger _ =
+ Signed 0
+
+ abs s
+ | isNegative s =
+ negate s
+ | otherwise =
+ s
+ signum s
+ | isNegative s =
+ -1
+ | s == 0 =
+ 0
+ | otherwise =
+ 1
+
+instance NaturalT nT => Real (Signed nT) where
+ toRational n = toRational $ toInteger n
+
+instance NaturalT nT => Integral (Signed nT) where
+ a `quot` b =
+ fromInteger $ toInteger a `quot` toInteger b
+ a `rem` b =
+ fromInteger $ toInteger a `rem` toInteger b
+ a `div` b =
+ fromInteger $ toInteger a `div` toInteger b
+ a `mod` b =
+ fromInteger $ toInteger a `mod` toInteger b
+ a `quotRem` b =
+ let (quot, rem) = toInteger a `quotRem` toInteger b
+ in (fromInteger quot, fromInteger rem)
+ a `divMod` b =
+ let (div, mod) = toInteger a `divMod` toInteger b
+ in (fromInteger div, fromInteger mod)
+ toInteger s@(Signed x) =
+ if isNegative s
+ then let Signed x' = negate s in negate x'
+ else x
+
+instance NaturalT nT => Bits (Signed nT) where
+ (Signed a) .&. (Signed b) = Signed $ a .&. b
+ (Signed a) .|. (Signed b) = Signed $ a .|. b
+ (Signed a) `xor` Signed b = Signed $ a `xor` b
+ complement (Signed x) = Signed $ x `xor` mask (undefined :: nT)
+ (Signed x) `shiftL` b
+ | b < 0 = error $ "Bits.shiftL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
+ | otherwise =
+ Signed $ mask (undefined :: nT) .&. (x `shiftL` b)
+ s@(Signed x) `shiftR` b
+ | b < 0 = error $ "Bits.shiftR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
+ | isNegative s =
+ Signed $ mask (undefined :: nT) .&.
+ ((x `shiftR` b) .|. (mask (undefined :: nT) `shiftL` (fromIntegerT (undefined :: nT) - b)))
+ | otherwise =
+ Signed $ (mask (undefined :: nT)) .&. (x `shiftR` b)
+ (Signed a) `rotateL` b
+ | b < 0 =
+ error $ "Bits.rotateL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
+ | otherwise =
+ Signed $ mask (undefined :: nT) .&.
+ ((a `shiftL` b) .|. (a `shiftR` (fromIntegerT (undefined :: nT) - b)))
+ (Signed a) `rotateR` b
+ | b < 0 =
+ error $ "Bits.rotateR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
+ | otherwise =
+ Signed $ mask (undefined :: nT) .&.
+ ((a `shiftR` b) .|. (a `shiftL` (fromIntegerT (undefined :: nT) - b)))
+ bitSize _ = fromIntegerT (undefined :: nT)
+ isSigned _ = True
--- /dev/null
+{-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
+module Data.Param.Unsigned
+ ( Unsigned
+ , resize
+ , fromIndex
+ ) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Data.Bits
+import Types
+import Types.Data.Num.Decimal.Literals.TH
+
+import Data.Param.Integer
+
+instance NaturalT nT => Lift (Unsigned nT) where
+ lift (Unsigned i) = sigE [| (Unsigned i) |] (decUnsignedT (fromIntegerT (undefined :: nT)))
+
+decUnsignedT :: Integer -> Q Type
+decUnsignedT n = appT (conT (''Unsigned)) (decLiteralT n)
+
+fromIndex ::
+ ( NaturalT nT
+ , NaturalT nT'
+ , ((Pow2 nT') :>: nT) ~ True
+ , Integral (Index nT)
+ ) => Index nT -> Unsigned nT'
+fromIndex index = Unsigned (toInteger index)
+
+resize :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'
+resize a = fromInteger (toInteger a)
+
+sizeT :: Unsigned nT
+ -> nT
+sizeT _ = undefined
+
+mask :: forall nT . NaturalT nT
+ => nT
+ -> Integer
+mask _ = bit (fromIntegerT (undefined :: nT)) - 1
+
+instance NaturalT nT => Eq (Unsigned nT) where
+ (Unsigned x) == (Unsigned y) = x == y
+ (Unsigned x) /= (Unsigned y) = x /= y
+
+instance NaturalT nT => Show (Unsigned nT) where
+ showsPrec prec n =
+ showsPrec prec $ toInteger n
+
+instance NaturalT nT => Read (Unsigned nT) where
+ readsPrec prec str =
+ [ (fromInteger n, str)
+ | (n, str) <- readsPrec prec str ]
+
+instance NaturalT nT => Ord (Unsigned nT) where
+ a `compare` b = toInteger a `compare` toInteger b
+
+instance NaturalT nT => Bounded (Unsigned nT) where
+ minBound = 0
+ maxBound = Unsigned $ (1 `shiftL` (fromIntegerT (undefined :: nT))) - 1
+
+instance NaturalT nT => Enum (Unsigned nT) where
+ succ x
+ | x == maxBound = error $ "Enum.succ{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
+ | otherwise = x + 1
+ pred x
+ | x == minBound = error $ "Enum.succ{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
+ | otherwise = x - 1
+
+ fromEnum (Unsigned x)
+ | x > toInteger (maxBound :: Int) =
+ error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned greater than maxBound :: Int"
+ | x < toInteger (minBound :: Int) =
+ error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned smaller than minBound :: Int"
+ | otherwise =
+ fromInteger x
+ toEnum x
+ | x > fromIntegral (maxBound :: Unsigned nT) =
+ error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned greater than maxBound :: Unsigned " ++ show (fromIntegerT (undefined :: nT))
+ | x < fromIntegral (minBound :: Unsigned nT) =
+ error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned smaller than minBound :: Unsigned " ++ show (fromIntegerT (undefined :: nT))
+ | otherwise =
+ fromInteger $ toInteger x
+
+instance NaturalT nT => Num (Unsigned nT) where
+ (Unsigned a) + (Unsigned b) =
+ fromInteger $ a + b
+ (Unsigned a) * (Unsigned b) =
+ fromInteger $ a * b
+ negate s@(Unsigned n) =
+ fromInteger $ (n `xor` mask (sizeT s)) + 1
+ a - b =
+ a + (negate b)
+
+ fromInteger n
+ | n > 0 =
+ Unsigned $ n .&. mask (undefined :: nT)
+ fromInteger n
+ | n < 0 =
+ negate $ fromInteger $ negate n
+ fromInteger _ =
+ Unsigned 0
+
+ abs s = s
+ signum s
+ | s == 0 =
+ 0
+ | otherwise =
+ 1
+
+instance NaturalT nT => Real (Unsigned nT) where
+ toRational n = toRational $ toInteger n
+
+instance NaturalT nT => Integral (Unsigned nT) where
+ a `quot` b =
+ fromInteger $ toInteger a `quot` toInteger b
+ a `rem` b =
+ fromInteger $ toInteger a `rem` toInteger b
+ a `div` b =
+ fromInteger $ toInteger a `div` toInteger b
+ a `mod` b =
+ fromInteger $ toInteger a `mod` toInteger b
+ a `quotRem` b =
+ let (quot, rem) = toInteger a `quotRem` toInteger b
+ in (fromInteger quot, fromInteger rem)
+ a `divMod` b =
+ let (div, mod) = toInteger a `divMod` toInteger b
+ in (fromInteger div, fromInteger mod)
+ toInteger s@(Unsigned x) = x
+
+instance NaturalT nT => Bits (Unsigned nT) where
+ (Unsigned a) .&. (Unsigned b) = Unsigned $ a .&. b
+ (Unsigned a) .|. (Unsigned b) = Unsigned $ a .|. b
+ (Unsigned a) `xor` Unsigned b = Unsigned $ a `xor` b
+ complement (Unsigned x) = Unsigned $ x `xor` mask (undefined :: nT)
+ s@(Unsigned x) `shiftL` b
+ | b < 0 = error $ "Bits.shiftL{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"
+ | otherwise =
+ Unsigned $ mask (undefined :: nT) .&. (x `shiftL` b)
+ s@(Unsigned x) `shiftR` b
+ | b < 0 = error $ "Bits.shiftR{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"
+ | otherwise =
+ Unsigned $ (x `shiftR` b)
+ s@(Unsigned x) `rotateL` b
+ | b < 0 =
+ error $ "Bits.rotateL{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"
+ | otherwise =
+ Unsigned $ mask (undefined :: nT) .&.
+ ((x `shiftL` b) .|. (x `shiftR` (bitSize s - b)))
+ s@(Unsigned x) `rotateR` b
+ | b < 0 =
+ error $ "Bits.rotateR{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"
+ | otherwise =
+ Unsigned $ mask (undefined :: nT) .&.
+ ((x `shiftR` b) .|. (x `shiftL` (bitSize s - b)))
+ bitSize _ = fromIntegerT (undefined :: nT)
+ isSigned _ = False
--- /dev/null
+{-# LANGUAGE StandaloneDeriving, ExistentialQuantification, ScopedTypeVariables, TemplateHaskell, TypeOperators, TypeFamilies #-}
+module Data.Param.Vector
+ ( Vector
+ , empty
+ , (+>)
+ , singleton
+ , vectorTH
+ , unsafeVector
+ , readVector
+ , length
+ , lengthT
+ , fromVector
+ , null
+ , (!)
+ , replace
+ , head
+ , last
+ , init
+ , tail
+ , take
+ , drop
+ , select
+ , (<+)
+ , (++)
+ , map
+ , zipWith
+ , foldl
+ , foldr
+ , zip
+ , unzip
+ , shiftl
+ , shiftr
+ , rotl
+ , rotr
+ , concat
+ , reverse
+ , iterate
+ , iteraten
+ , generate
+ , generaten
+ , copy
+ , copyn
+ , split
+ ) where
+
+import Types
+import Types.Data.Num
+import Types.Data.Num.Decimal.Literals.TH
+import Data.Param.Index
+
+import Data.Typeable
+import qualified Prelude as P
+import Prelude hiding (
+ null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
+ zipWith, zip, unzip, concat, reverse, iterate )
+import qualified Data.Foldable as DF (Foldable, foldr)
+import qualified Data.Traversable as DT (Traversable(traverse))
+import Language.Haskell.TH hiding (Pred)
+import Language.Haskell.TH.Syntax (Lift(..))
+
+newtype (NaturalT s) => Vector s a = Vector {unVec :: [a]}
+ deriving Eq
+
+-- deriving instance (NaturalT s, Typeable s, Data s, Typeable a, Data a) => Data (TFVec s a)
+
+-- ==========================
+-- = Constructing functions =
+-- ==========================
+
+empty :: Vector D0 a
+empty = Vector []
+
+(+>) :: a -> Vector s a -> Vector (Succ s) a
+x +> (Vector xs) = Vector (x:xs)
+
+infix 5 +>
+
+singleton :: a -> Vector D1 a
+singleton x = x +> empty
+
+-- FIXME: Not the most elegant solution... but it works for now in clash
+vectorTH :: (Lift a) => [a] -> ExpQ
+-- vectorTH xs = sigE [| (TFVec xs) |] (decTFVecT (toInteger (P.length xs)) xs)
+vectorTH [] = [| empty |]
+vectorTH [x] = [| singleton x |]
+vectorTH (x:xs) = [| x +> $(vectorTH xs) |]
+
+unsafeVector :: NaturalT s => s -> [a] -> Vector s a
+unsafeVector l xs
+ | fromIntegerT l /= P.length xs =
+ error (show 'unsafeVector P.++ ": dynamic/static lenght mismatch")
+ | otherwise = Vector xs
+
+readVector :: (Read a, NaturalT s) => String -> Vector s a
+readVector = read
+
+-- =======================
+-- = Observing functions =
+-- =======================
+length :: forall s a . NaturalT s => Vector s a -> Int
+length _ = fromIntegerT (undefined :: s)
+
+lengthT :: NaturalT s => Vector s a -> s
+lengthT = undefined
+
+fromVector :: NaturalT s => Vector s a -> [a]
+fromVector (Vector xs) = xs
+
+null :: Vector D0 a -> Bool
+null _ = True
+
+(!) :: ( PositiveT s
+ , NaturalT u
+ , (s :>: u) ~ True) => Vector s a -> Index u -> a
+(Vector xs) ! i = xs !! (fromInteger (toInteger i))
+
+-- ==========================
+-- = Transforming functions =
+-- ==========================
+replace :: (PositiveT s, NaturalT u, (s :>: u) ~ True) =>
+ Vector s a -> Index u -> a -> Vector s a
+replace (Vector xs) i y = Vector $ replace' xs (toInteger i) y
+ where replace' [] _ _ = []
+ replace' (_:xs) 0 y = (y:xs)
+ replace' (x:xs) n y = x : (replace' xs (n-1) y)
+
+head :: PositiveT s => Vector s a -> a
+head = P.head . unVec
+
+tail :: PositiveT s => Vector s a -> Vector (Pred s) a
+tail = liftV P.tail
+
+last :: PositiveT s => Vector s a -> a
+last = P.last . unVec
+
+init :: PositiveT s => Vector s a -> Vector (Pred s) a
+init = liftV P.init
+
+take :: NaturalT i => i -> Vector s a -> Vector (Min s i) a
+take i = liftV $ P.take (fromIntegerT i)
+
+drop :: NaturalT i => i -> Vector s a -> Vector (s :-: (Min s i)) a
+drop i = liftV $ P.drop (fromIntegerT i)
+
+select :: (NaturalT f, NaturalT s, NaturalT n, (f :<: i) ~ True,
+ (((s :*: n) :+: f) :<=: i) ~ True) =>
+ f -> s -> n -> Vector i a -> Vector n a
+select f s n = liftV (select' f' s' n')
+ where (f', s', n') = (fromIntegerT f, fromIntegerT s, fromIntegerT n)
+ select' f s n = ((selectFirst0 s n).(P.drop f))
+ selectFirst0 :: Int -> Int -> [a] -> [a]
+ selectFirst0 s n l@(x:_)
+ | n > 0 = x : selectFirst0 s (n-1) (P.drop s l)
+ | otherwise = []
+ selectFirst0 _ 0 [] = []
+
+(<+) :: Vector s a -> a -> Vector (Succ s) a
+(<+) (Vector xs) x = Vector (xs P.++ [x])
+
+(++) :: Vector s a -> Vector s2 a -> Vector (s :+: s2) a
+(++) = liftV2 (P.++)
+
+infixl 5 <+
+infixr 5 ++
+
+map :: (a -> b) -> Vector s a -> Vector s b
+map f = liftV (P.map f)
+
+zipWith :: (a -> b -> c) -> Vector s a -> Vector s b -> Vector s c
+zipWith f = liftV2 (P.zipWith f)
+
+foldl :: (a -> b -> a) -> a -> Vector s b -> a
+foldl f e = (P.foldl f e) . unVec
+
+foldr :: (b -> a -> a) -> a -> Vector s b -> a
+foldr f e = (P.foldr f e) . unVec
+
+zip :: Vector s a -> Vector s b -> Vector s (a, b)
+zip = liftV2 P.zip
+
+unzip :: Vector s (a, b) -> (Vector s a, Vector s b)
+unzip (Vector xs) = let (a,b) = P.unzip xs in (Vector a, Vector b)
+
+shiftl :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
+ Vector s a -> a -> Vector s a
+shiftl xs x = x +> init xs
+
+shiftr :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
+ Vector s a -> a -> Vector s a
+shiftr xs x = tail xs <+ x
+
+rotl :: forall s a . NaturalT s => Vector s a -> Vector s a
+rotl = liftV rotl'
+ where vlen = fromIntegerT (undefined :: s)
+ rotl' [] = []
+ rotl' xs = let (i,[l]) = splitAt (vlen - 1) xs
+ in l : i
+
+rotr :: NaturalT s => Vector s a -> Vector s a
+rotr = liftV rotr'
+ where
+ rotr' [] = []
+ rotr' (x:xs) = xs P.++ [x]
+
+concat :: Vector s1 (Vector s2 a) -> Vector (s1 :*: s2) a
+concat = liftV (P.foldr ((P.++).unVec) [])
+
+reverse :: Vector s a -> Vector s a
+reverse = liftV P.reverse
+
+iterate :: NaturalT s => (a -> a) -> a -> Vector s a
+iterate = iteraten (undefined :: s)
+
+iteraten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
+iteraten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.iterate f x)
+
+generate :: NaturalT s => (a -> a) -> a -> Vector s a
+generate = generaten (undefined :: s)
+
+generaten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
+generaten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.tail $ P.iterate f x)
+
+copy :: NaturalT s => a -> Vector s a
+copy x = copyn (undefined :: s) x
+
+copyn :: NaturalT s => s -> a -> Vector s a
+copyn s x = iteraten s id x
+
+split :: ( NaturalT s
+ -- , IsEven s ~ True
+ ) => Vector s a -> (Vector (Div2 s) a, Vector (Div2 s) a)
+split (Vector xs) = (Vector (P.take vlen xs), Vector (P.drop vlen xs))
+ where
+ vlen = round ((fromIntegral (P.length xs)) / 2)
+
+-- =============
+-- = Instances =
+-- =============
+instance Show a => Show (Vector s a) where
+ showsPrec _ = showV.unVec
+ where showV [] = showString "<>"
+ showV (x:xs) = showChar '<' . shows x . showl xs
+ where showl [] = showChar '>'
+ showl (x:xs) = showChar ',' . shows x .
+ showl xs
+
+instance (Read a, NaturalT nT) => Read (Vector nT a) where
+ readsPrec _ str
+ | all fitsLength possibilities = P.map toReadS possibilities
+ | otherwise = error (fName P.++ ": string/dynamic length mismatch")
+ where
+ fName = "Data.Param.TFVec.read"
+ expectedL = fromIntegerT (undefined :: nT)
+ possibilities = readVectorList str
+ fitsLength (_, l, _) = l == expectedL
+ toReadS (xs, _, rest) = (Vector xs, rest)
+
+instance NaturalT s => DF.Foldable (Vector s) where
+ foldr = foldr
+
+instance NaturalT s => Functor (Vector s) where
+ fmap = map
+
+instance NaturalT s => DT.Traversable (Vector s) where
+ traverse f = (fmap Vector).(DT.traverse f).unVec
+
+instance (Lift a, NaturalT nT) => Lift (Vector nT a) where
+ lift (Vector xs) = [| unsafeVectorCoerse
+ $(decLiteralV (fromIntegerT (undefined :: nT)))
+ (Vector xs) |]
+
+-- ======================
+-- = Internal Functions =
+-- ======================
+liftV :: ([a] -> [b]) -> Vector nT a -> Vector nT' b
+liftV f = Vector . f . unVec
+
+liftV2 :: ([a] -> [b] -> [c]) -> Vector s a -> Vector s2 b -> Vector s3 c
+liftV2 f a b = Vector (f (unVec a) (unVec b))
+
+splitAtM :: Int -> [a] -> Maybe ([a],[a])
+splitAtM n xs = splitAtM' n [] xs
+ where splitAtM' 0 xs ys = Just (xs, ys)
+ splitAtM' n xs (y:ys) | n > 0 = do
+ (ls, rs) <- splitAtM' (n-1) xs ys
+ return (y:ls,rs)
+ splitAtM' _ _ _ = Nothing
+
+unsafeVectorCoerse :: nT' -> Vector nT a -> Vector nT' a
+unsafeVectorCoerse _ (Vector v) = (Vector v)
+
+readVectorList :: Read a => String -> [([a], Int, String)]
+readVectorList = readParen' False (\r -> [pr | ("<",s) <- lexVector r,
+ pr <- readl s])
+ where
+ readl s = [([],0,t) | (">",t) <- lexVector s] P.++
+ [(x:xs,1+n,u) | (x,t) <- reads s,
+ (xs, n, u) <- readl' t]
+ readl' s = [([],0,t) | (">",t) <- lexVector s] P.++
+ [(x:xs,1+n,v) | (",",t) <- lex s,
+ (x,u) <- reads t,
+ (xs,n,v) <- readl' u]
+ readParen' b g = if b then mandatory else optional
+ where optional r = g r P.++ mandatory r
+ mandatory r = [(x,n,u) | ("(",s) <- lexVector r,
+ (x,n,t) <- optional s,
+ (")",u) <- lexVector t]
+
+-- Custom lexer for FSVecs, we cannot use lex directly because it considers
+-- sequences of < and > as unique lexemes, and that breaks nested FSVecs, e.g.
+-- <<1,2><3,4>>
+lexVector :: ReadS String
+lexVector ('>':rest) = [(">",rest)]
+lexVector ('<':rest) = [("<",rest)]
+lexVector str = lex str
+
--- /dev/null
+Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+ * Neither the name of the copyright holder nor the
+ names of its contributors may be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
--- /dev/null
+name: clash
+version: 0.1
+build-type: Simple
+synopsis: CAES Language for Synchronous Hardware (CLaSH)
+description: CLaSH is a tool-chain/language to translate subsets of
+ Haskell to synthesizable VHDL. It does this by translating
+ the intermediate System Fc (GHC Core) representation to a
+ VHDL AST, which is then written to file.
+category: Language, Hardware
+license: BSD3
+license-file: LICENSE
+homepage: http://clash.ewi.utwente.nl/
+package-url: http://github.com/christiaanb/clash/tree/master/cλash
+copyright: Copyright (c) 2009-2010 Christiaan Baaij &
+ Matthijs Kooijman
+author: Christiaan Baaij & Matthijs Kooijman
+stability: alpha
+maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl
+Cabal-Version: >= 1.2
+
+Library
+ build-depends: ghc >= 6.12, pretty, vhdl > 0.1, haskell98, syb,
+ data-accessor, containers, base >= 4 && < 5, transformers,
+ filepath, template-haskell, data-accessor-template,
+ data-accessor-transformers, prettyclass, directory,
+ tfp, th-lift, time
+
+ exposed-modules: CLasH.HardwareTypes
+ CLasH.Translator
+ CLasH.Translator.Annotations
+
+ other-modules: Data.Param.Integer
+ Data.Param.Signed
+ Data.Param.Unsigned
+ Data.Param.Index
+ Data.Param.Vector
+ CLasH.Translator.TranslatorTypes
+ CLasH.Normalize
+ CLasH.Normalize.NormalizeTypes
+ CLasH.Normalize.NormalizeTools
+ CLasH.VHDL
+ CLasH.VHDL.Constants
+ CLasH.VHDL.Generate
+ CLasH.VHDL.Testbench
+ CLasH.VHDL.VHDLTools
+ CLasH.VHDL.VHDLTypes
+ CLasH.Utils
+ CLasH.Utils.GhcTools
+ CLasH.Utils.HsTools
+ CLasH.Utils.Pretty
+ CLasH.Utils.Core.BinderTools
+ CLasH.Utils.Core.CoreShow
+ CLasH.Utils.Core.CoreTools
+
+
+++ /dev/null
-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, FlexibleContexts, TypeFamilies, TypeOperators #-}
-
-module CLasH.HardwareTypes
- ( module Types
- , module Data.Param.Vector
- , module Data.Param.Index
- , module Data.Param.Signed
- , module Data.Param.Unsigned
- , module Prelude
- , Bit(..)
- , State(..)
- , resizeInt
- , resizeWord
- , hwand
- , hwor
- , hwxor
- , hwnot
- , RAM
- , MemState
- , blockRAM
- ) where
-
-import qualified Prelude as P
-import Prelude hiding (
- null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
- zipWith, zip, unzip, concat, reverse, iterate )
-import Types
-import Data.Param.Vector
-import Data.Param.Index
-import qualified Data.Param.Signed as Signed
-import Data.Param.Signed hiding (resize)
-import qualified Data.Param.Unsigned as Unsigned
-import Data.Param.Unsigned hiding (resize)
-
-import Language.Haskell.TH.Lift
-import Data.Typeable
-
-newtype State s = State s deriving (P.Show)
-
-resizeInt :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'
-resizeInt = Signed.resize
-
-resizeWord :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'
-resizeWord = Unsigned.resize
-
--- The plain Bit type
-data Bit = High | Low
- deriving (P.Show, P.Eq, P.Read, Typeable)
-
-deriveLift ''Bit
-
-hwand :: Bit -> Bit -> Bit
-hwor :: Bit -> Bit -> Bit
-hwxor :: Bit -> Bit -> Bit
-hwnot :: Bit -> Bit
-
-High `hwand` High = High
-_ `hwand` _ = Low
-
-High `hwor` _ = High
-_ `hwor` High = High
-Low `hwor` Low = Low
-
-High `hwxor` Low = High
-Low `hwxor` High = High
-_ `hwxor` _ = Low
-
-hwnot High = Low
-hwnot Low = High
-
-type RAM s a = Vector (s :+: D1) a
-
-type MemState s a = State (RAM s a)
-
-blockRAM ::
- (NaturalT s
- ,PositiveT (s :+: D1)
- ,((s :+: D1) :>: s) ~ True ) =>
- (MemState s a) ->
- a ->
- Index s ->
- Index s ->
- Bool ->
- ((MemState s a), a )
-blockRAM (State mem) data_in rdaddr wraddr wrenable =
- ((State mem'), data_out)
- where
- data_out = mem!rdaddr
- -- Only write data_in to memory if write is enabled
- mem' = if wrenable then
- replace mem wraddr data_in
- else
- mem
+++ /dev/null
---
--- Functions to bring a Core expression in normal form. This module provides a
--- top level function "normalize", and defines the actual transformation passes that
--- are performed.
---
-module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where
-
--- Standard modules
-import Debug.Trace
-import qualified Maybe
-import qualified List
-import qualified Control.Monad.Trans.Class as Trans
-import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-import qualified Data.Monoid as Monoid
-import qualified Data.Map as Map
-
--- GHC API
-import CoreSyn
-import qualified CoreUtils
-import qualified BasicTypes
-import qualified Type
-import qualified TysWiredIn
-import qualified Id
-import qualified Var
-import qualified Name
-import qualified DataCon
-import qualified VarSet
-import qualified CoreFVs
-import qualified Class
-import qualified MkCore
-import Outputable ( showSDoc, ppr, nest )
-
--- Local imports
-import CLasH.Normalize.NormalizeTypes
-import CLasH.Translator.TranslatorTypes
-import CLasH.Normalize.NormalizeTools
-import CLasH.VHDL.Constants (builtinIds)
-import qualified CLasH.Utils as Utils
-import CLasH.Utils.Core.CoreTools
-import CLasH.Utils.Core.BinderTools
-import CLasH.Utils.Pretty
-
-----------------------------------------------------------------
--- Cleanup transformations
-----------------------------------------------------------------
-
---------------------------------
--- β-reduction
---------------------------------
-beta :: Transform
--- Substitute arg for x in expr. For value lambda's, also clone before
--- substitution.
-beta c (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg c expr
- | otherwise = setChanged >> substitute_clone x arg c expr
--- Leave all other expressions unchanged
-beta c expr = return expr
-
---------------------------------
--- Unused let binding removal
---------------------------------
-letremoveunused :: Transform
-letremoveunused c expr@(Let (NonRec b bound) res) = do
- let used = expr_uses_binders [b] res
- if used
- then return expr
- else change res
-letremoveunused c expr@(Let (Rec binds) res) = do
- -- Filter out all unused binds.
- let binds' = filter dobind binds
- -- Only set the changed flag if binds got removed
- changeif (length binds' /= length binds) (Let (Rec binds') res)
- where
- bound_exprs = map snd binds
- -- For each bind check if the bind is used by res or any of the bound
- -- expressions
- dobind (bndr, _) = any (expr_uses_binders [bndr]) (res:bound_exprs)
--- Leave all other expressions unchanged
-letremoveunused c expr = return expr
-
---------------------------------
--- empty let removal
---------------------------------
--- Remove empty (recursive) lets
-letremove :: Transform
-letremove c (Let (Rec []) res) = change res
--- Leave all other expressions unchanged
-letremove c expr = return expr
-
---------------------------------
--- Simple let binding removal
---------------------------------
--- Remove a = b bindings from let expressions everywhere
-letremovesimple :: Transform
-letremovesimple = inlinebind (\(b, e) -> Trans.lift $ is_local_var e)
-
---------------------------------
--- Cast propagation
---------------------------------
--- Try to move casts as much downward as possible.
-castprop :: Transform
-castprop c (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
-castprop c expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
- where
- alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
--- Leave all other expressions unchanged
-castprop c expr = return expr
-
---------------------------------
--- Cast simplification. Mostly useful for state packing and unpacking, but
--- perhaps for others as well.
---------------------------------
-castsimpl :: Transform
-castsimpl c expr@(Cast val ty) = do
- -- Don't extract values that are already simpl
- local_var <- Trans.lift $ is_local_var val
- -- Don't extract values that are not representable, to prevent loops with
- -- inlinenonrep
- repr <- isRepr val
- if (not local_var) && repr
- then do
- -- Generate a binder for the expression
- id <- Trans.lift $ mkBinderFor val "castval"
- -- Extract the expression
- change $ Let (NonRec id val) (Cast (Var id) ty)
- else
- return expr
--- Leave all other expressions unchanged
-castsimpl c expr = return expr
-
---------------------------------
--- Top level function inlining
---------------------------------
--- This transformation inlines simple top level bindings. Simple
--- currently means that the body is only a single application (though
--- the complexity of the arguments is not currently checked) or that the
--- normalized form only contains a single binding. This should catch most of the
--- cases where a top level function is created that simply calls a type class
--- method with a type and dictionary argument, e.g.
--- fromInteger = GHC.Num.fromInteger (SizedWord D8) $dNum
--- which is later called using simply
--- fromInteger (smallInteger 10)
---
--- These useless wrappers are created by GHC automatically. If we don't
--- inline them, we get loads of useless components cluttering the
--- generated VHDL.
---
--- Note that the inlining could also inline simple functions defined by
--- the user, not just GHC generated functions. It turns out to be near
--- impossible to reliably determine what functions are generated and
--- what functions are user-defined. Instead of guessing (which will
--- inline less than we want) we will just inline all simple functions.
---
--- Only functions that are actually completely applied and bound by a
--- variable in a let expression are inlined. These are the expressions
--- that will eventually generate instantiations of trivial components.
--- By not inlining any other reference, we also prevent looping problems
--- with funextract and inlinedict.
-inlinetoplevel :: Transform
-inlinetoplevel (LetBinding:_) expr | not (is_fun expr) =
- case collectArgs expr of
- (Var f, args) -> do
- body_maybe <- needsInline f
- case body_maybe of
- Just body -> do
- -- Regenerate all uniques in the to-be-inlined expression
- body_uniqued <- Trans.lift $ genUniques body
- -- And replace the variable reference with the unique'd body.
- change (mkApps body_uniqued args)
- -- No need to inline
- Nothing -> return expr
- -- This is not an application of a binder, leave it unchanged.
- _ -> return expr
-
--- Leave all other expressions unchanged
-inlinetoplevel c expr = return expr
-
--- | Does the given binder need to be inlined? If so, return the body to
--- be used for inlining.
-needsInline :: CoreBndr -> TransformMonad (Maybe CoreExpr)
-needsInline f = do
- body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- -- No body available?
- Nothing -> return Nothing
- Just body -> case CoreSyn.collectArgs body of
- -- The body is some (top level) binder applied to 0 or more
- -- arguments. That should be simple enough to inline.
- (Var f, args) -> return $ Just body
- -- Body is more complicated, try normalizing it
- _ -> do
- norm_maybe <- Trans.lift $ getNormalized_maybe False f
- case norm_maybe of
- -- Noth normalizeable
- Nothing -> return Nothing
- Just norm -> case splitNormalizedNonRep norm of
- -- The function has just a single binding, so that's simple
- -- enough to inline.
- (args, [bind], Var res) -> return $ Just norm
- -- More complicated function, don't inline
- _ -> return Nothing
-
-
-----------------------------------------------------------------
--- Program structure transformations
-----------------------------------------------------------------
-
---------------------------------
--- η expansion
---------------------------------
--- Make sure all parameters to the normalized functions are named by top
--- level lambda expressions. For this we apply η expansion to the
--- function body (possibly enclosed in some lambda abstractions) while
--- it has a function type. Eventually this will result in a function
--- body consisting of a bunch of nested lambdas containing a
--- non-function value (e.g., a complete application).
-eta :: Transform
-eta c expr | is_fun expr && not (is_lam expr) && all (== LambdaBody) c = do
- let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
- id <- Trans.lift $ mkInternalVar "param" arg_ty
- change (Lam id (App expr (Var id)))
--- Leave all other expressions unchanged
-eta c e = return e
-
---------------------------------
--- Application propagation
---------------------------------
--- Move applications into let and case expressions.
-appprop :: Transform
--- Propagate the application into the let
-appprop c (App (Let binds expr) arg) = change $ Let binds (App expr arg)
--- Propagate the application into each of the alternatives
-appprop c (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
- where
- alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
- ty' = CoreUtils.applyTypeToArg ty arg
--- Leave all other expressions unchanged
-appprop c expr = return expr
-
---------------------------------
--- Let recursification
---------------------------------
--- Make all lets recursive, so other transformations don't need to
--- handle non-recursive lets
-letrec :: Transform
-letrec c expr@(Let (NonRec bndr val) res) =
- change $ Let (Rec [(bndr, val)]) res
-
--- Leave all other expressions unchanged
-letrec c expr = return expr
-
---------------------------------
--- let flattening
---------------------------------
--- Takes a let that binds another let, and turns that into two nested lets.
--- e.g., from:
--- let b = (let b' = expr' in res') in res
--- to:
--- let b' = expr' in (let b = res' in res)
-letflat :: Transform
--- Turn a nonrec let that binds a let into two nested lets.
-letflat c (Let (NonRec b (Let binds res')) res) =
- change $ Let binds (Let (NonRec b res') res)
-letflat c (Let (Rec binds) expr) = do
- -- Flatten each binding.
- binds' <- Utils.concatM $ Monad.mapM flatbind binds
- -- Return the new let. We don't use change here, since possibly nothing has
- -- changed. If anything has changed, flatbind has already flagged that
- -- change.
- return $ Let (Rec binds') expr
- where
- -- Turns a binding of a let into a multiple bindings, or any other binding
- -- into a list with just that binding
- flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
- flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
- flatbind (b, Let (NonRec b' expr') expr) = change [(b, expr), (b', expr')]
- flatbind (b, expr) = return [(b, expr)]
--- Leave all other expressions unchanged
-letflat c expr = return expr
-
---------------------------------
--- Return value simplification
---------------------------------
--- Ensure the return value of a function follows proper normal form. eta
--- expansion ensures the body starts with lambda abstractions, this
--- transformation ensures that the lambda abstractions always contain a
--- recursive let and that, when the return value is representable, the
--- let contains a local variable reference in its body.
-
--- Extract the return value from the body of the top level lambdas (of
--- which ther could be zero), unless it is a let expression (in which
--- case the next clause applies).
-retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do
- local_var <- Trans.lift $ is_local_var expr
- repr <- isRepr expr
- if not local_var && repr
- then do
- id <- Trans.lift $ mkBinderFor expr "res"
- change $ Let (Rec [(id, expr)]) (Var id)
- else
- return expr
--- Extract the return value from the body of a let expression, which is
--- itself the body of the top level lambdas (of which there could be
--- zero).
-retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do
- -- Don't extract values that are already a local variable, to prevent
- -- loops with ourselves.
- local_var <- Trans.lift $ is_local_var body
- -- Don't extract values that are not representable, to prevent loops with
- -- inlinenonrep
- repr <- isRepr body
- if not local_var && repr
- then do
- id <- Trans.lift $ mkBinderFor body "res"
- change $ Let (Rec ((id, body):binds)) (Var id)
- else
- return expr
--- Leave all other expressions unchanged
-retvalsimpl c expr = return expr
-
---------------------------------
--- Representable arguments simplification
---------------------------------
--- Make sure that all arguments of a representable type are simple variables.
-appsimpl :: Transform
--- Simplify all representable arguments. Do this by introducing a new Let
--- that binds the argument and passing the new binder in the application.
-appsimpl c expr@(App f arg) = do
- -- Check runtime representability
- repr <- isRepr arg
- local_var <- Trans.lift $ is_local_var arg
- if repr && not local_var
- then do -- Extract representable arguments
- id <- Trans.lift $ mkBinderFor arg "arg"
- change $ Let (NonRec id arg) (App f (Var id))
- else -- Leave non-representable arguments unchanged
- return expr
--- Leave all other expressions unchanged
-appsimpl c expr = return expr
-
-----------------------------------------------------------------
--- Built-in function transformations
-----------------------------------------------------------------
-
---------------------------------
--- Function-typed argument extraction
---------------------------------
--- This transform takes any function-typed argument that cannot be propagated
--- (because the function that is applied to it is a builtin function), and
--- puts it in a brand new top level binder. This allows us to for example
--- apply map to a lambda expression This will not conflict with inlinenonrep,
--- since that only inlines local let bindings, not top level bindings.
-funextract :: Transform
-funextract c expr@(App _ _) | is_var fexpr = do
- body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- -- We don't have a function body for f, so we can perform this transform.
- Nothing -> do
- -- Find the new arguments
- args' <- mapM doarg args
- -- And update the arguments. We use return instead of changed, so the
- -- changed flag doesn't get set if none of the args got changed.
- return $ MkCore.mkCoreApps fexpr args'
- -- We have a function body for f, leave this application to funprop
- Just _ -> return expr
- where
- -- Find the function called and the arguments
- (fexpr, args) = collectArgs expr
- Var f = fexpr
- -- Change any arguments that have a function type, but are not simple yet
- -- (ie, a variable or application). This means to create a new function
- -- for map (\f -> ...) b, but not for map (foo a) b.
- --
- -- We could use is_applicable here instead of is_fun, but I think
- -- arguments to functions could only have forall typing when existential
- -- typing is enabled. Not sure, though.
- doarg arg | not (is_simple arg) && is_fun arg = do
- -- Create a new top level binding that binds the argument. Its body will
- -- be extended with lambda expressions, to take any free variables used
- -- by the argument expression.
- let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
- let body = MkCore.mkCoreLams free_vars arg
- id <- Trans.lift $ mkBinderFor body "fun"
- Trans.lift $ addGlobalBind id body
- -- Replace the argument with a reference to the new function, applied to
- -- all vars it uses.
- change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
- -- Leave all other arguments untouched
- doarg arg = return arg
-
--- Leave all other expressions unchanged
-funextract c expr = return expr
-
-
-
-
-----------------------------------------------------------------
--- Case normalization transformations
-----------------------------------------------------------------
-
---------------------------------
--- Scrutinee simplification
---------------------------------
--- Make sure the scrutinee of a case expression is a local variable
--- reference.
-scrutsimpl :: Transform
--- Don't touch scrutinees that are already simple
-scrutsimpl c expr@(Case (Var _) _ _ _) = return expr
--- Replace all other cases with a let that binds the scrutinee and a new
--- simple scrutinee, but only when the scrutinee is representable (to prevent
--- loops with inlinenonrep, though I don't think a non-representable scrutinee
--- will be supported anyway...)
-scrutsimpl c expr@(Case scrut b ty alts) = do
- repr <- isRepr scrut
- if repr
- then do
- id <- Trans.lift $ mkBinderFor scrut "scrut"
- change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
- else
- return expr
--- Leave all other expressions unchanged
-scrutsimpl c expr = return expr
-
---------------------------------
--- Scrutinee binder removal
---------------------------------
--- A case expression can have an extra binder, to which the scrutinee is bound
--- after bringing it to WHNF. This is used for forcing evaluation of strict
--- arguments. Since strictness does not matter for us (rather, everything is
--- sort of strict), this binder is ignored when generating VHDL, and must thus
--- be wild in the normal form.
-scrutbndrremove :: Transform
--- If the scrutinee is already simple, and the bndr is not wild yet, replace
--- all occurences of the binder with the scrutinee variable.
-scrutbndrremove c (Case (Var scrut) bndr ty alts) | bndr_used = do
- alts' <- mapM subs_bndr alts
- change $ Case (Var scrut) wild ty alts'
- where
- is_used (_, _, expr) = expr_uses_binders [bndr] expr
- bndr_used = or $ map is_used alts
- subs_bndr (con, bndrs, expr) = do
- expr' <- substitute bndr (Var scrut) c expr
- return (con, bndrs, expr')
- wild = MkCore.mkWildBinder (Id.idType bndr)
--- Leave all other expressions unchanged
-scrutbndrremove c expr = return expr
-
---------------------------------
--- Case normalization
---------------------------------
--- Turn a case expression with any number of alternatives with any
--- number of non-wild binders into as set of case and let expressions,
--- all of which are in normal form (e.g., a bunch of extractor case
--- expressions to extract all fields from the scrutinee, a number of let
--- bindings to bind each alternative and a single selector case to
--- select the right value.
-casesimpl :: Transform
--- This is already a selector case (or, if x does not appear in bndrs, a very
--- simple case statement that will be removed by caseremove below). Just leave
--- it be.
-casesimpl c expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
--- Make sure that all case alternatives have only wild binders and simple
--- expressions.
--- This is done by creating a new let binding for each non-wild binder, which
--- is bound to a new simple selector case statement and for each complex
--- expression. We do this only for representable types, to prevent loops with
--- inlinenonrep.
-casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
- (bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
- let bindings = concat bindingss
- -- Replace the case with a let with bindings and a case
- let newlet = mkNonRecLets bindings (Case scrut bndr ty alts')
- -- If there are no non-wild binders, or this case is already a simple
- -- selector (i.e., a single alt with exactly one binding), already a simple
- -- selector altan no bindings (i.e., no wild binders in the original case),
- -- don't change anything, otherwise, replace the case.
- if null bindings then return expr else change newlet
- where
- -- Check if the scrutinee binder is used
- is_used (_, _, expr) = expr_uses_binders [bndr] expr
- bndr_used = or $ map is_used alts
- -- Generate a single wild binder, since they are all the same
- wild = MkCore.mkWildBinder
- -- Wilden the binders of one alt, producing a list of bindings as a
- -- sideeffect.
- doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
- doalt (con, bndrs, expr) = do
- -- Make each binder wild, if possible
- bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
- let (newbndrs, bindings_maybe) = unzip bndrs_res
- -- Extract a complex expression, if possible. For this we check if any of
- -- the new list of bndrs are used by expr. We can't use free_vars here,
- -- since that looks at the old bndrs.
- let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
- (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
- -- Create a new alternative
- let newalt = (con, newbndrs, expr')
- let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
- return (bindings, newalt)
- where
- -- Make wild alternatives for each binder
- wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
- -- A set of all the binders that are used by the expression
- free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
- -- Look at the ith binder in the case alternative. Return a new binder
- -- for it (either the same one, or a wild one) and optionally a let
- -- binding containing a case expression.
- dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
- dobndr b i = do
- repr <- isRepr b
- -- Is b wild (e.g., not a free var of expr. Since b is only in scope
- -- in expr, this means that b is unused if expr does not use it.)
- let wild = not (VarSet.elemVarSet b free_vars)
- -- Create a new binding for any representable binder that is not
- -- already wild and is representable (to prevent loops with
- -- inlinenonrep).
- if (not wild) && repr
- then do
- caseexpr <- Trans.lift $ mkSelCase scrut i
- -- Create a new binder that will actually capture a value in this
- -- case statement, and return it.
- return (wildbndrs!!i, Just (b, caseexpr))
- else
- -- Just leave the original binder in place, and don't generate an
- -- extra selector case.
- return (b, Nothing)
- -- Process the expression of a case alternative. Accepts an expression
- -- and whether this expression uses any of the binders in the
- -- alternative. Returns an optional new binding and a new expression.
- doexpr :: CoreExpr -> Bool -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreExpr)
- doexpr expr uses_bndrs = do
- local_var <- Trans.lift $ is_local_var expr
- repr <- isRepr expr
- -- Extract any expressions that do not use any binders from this
- -- alternative, is not a local var already and is representable (to
- -- prevent loops with inlinenonrep).
- if (not uses_bndrs) && (not local_var) && repr
- then do
- id <- Trans.lift $ mkBinderFor expr "caseval"
- -- We don't flag a change here, since casevalsimpl will do that above
- -- based on Just we return here.
- return (Just (id, expr), Var id)
- else
- -- Don't simplify anything else
- return (Nothing, expr)
--- Leave all other expressions unchanged
-casesimpl c expr = return expr
-
---------------------------------
--- Case removal
---------------------------------
--- Remove case statements that have only a single alternative and only wild
--- binders.
-caseremove :: Transform
--- Replace a useless case by the value of its single alternative
-caseremove c (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
- -- Find if any of the binders are used by expr
- where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` b:bndrs))) expr
--- Leave all other expressions unchanged
-caseremove c expr = return expr
-
---------------------------------
--- Case of known constructor simplification
---------------------------------
--- If a case expressions scrutinizes a datacon application, we can
--- determine which alternative to use and remove the case alltogether.
--- We replace it with a let expression the binds every binder in the
--- alternative bound to the corresponding argument of the datacon. We do
--- this instead of substituting the binders, to prevent duplication of
--- work and preserve sharing wherever appropriate.
-knowncase :: Transform
-knowncase context expr@(Case scrut@(App _ _) bndr ty alts) | not bndr_used = do
- case collectArgs scrut of
- (Var f, args) -> case Id.isDataConId_maybe f of
- -- Not a dataconstructor? Don't change anything (probably a
- -- function, then)
- Nothing -> return expr
- Just dc -> do
- let (altcon, bndrs, res) = case List.find (\(altcon, bndrs, res) -> altcon == (DataAlt dc)) alts of
- Just alt -> alt -- Return the alternative found
- Nothing -> head alts -- If the datacon is not present, the first must be the default alternative
- -- Double check if we have either the correct alternative, or
- -- the default.
- if altcon /= (DataAlt dc) && altcon /= DEFAULT then error ("Normalize.knowncase: Invalid core, datacon not found in alternatives and DEFAULT alternative is not first? " ++ pprString expr) else return ()
- -- Find out how many arguments to drop (type variables and
- -- predicates like dictionaries).
- let (tvs, preds, _, _) = DataCon.dataConSig dc
- let count = length tvs + length preds
- -- Create a let expression that binds each of the binders in
- -- this alternative to the corresponding argument of the data
- -- constructor.
- let binds = zip bndrs (drop count args)
- change $ Let (Rec binds) res
- _ -> return expr -- Scrutinee is not an application of a var
- where
- is_used (_, _, expr) = expr_uses_binders [bndr] expr
- bndr_used = or $ map is_used alts
-
--- Leave all other expressions unchanged
-knowncase c expr = return expr
-
-
-
-
-----------------------------------------------------------------
--- Unrepresentable value removal transformations
-----------------------------------------------------------------
-
---------------------------------
--- Non-representable binding inlining
---------------------------------
--- Remove a = B bindings, with B of a non-representable type, from let
--- expressions everywhere. This means that any value that we can't generate a
--- signal for, will be inlined and hopefully turned into something we can
--- represent.
---
--- This is a tricky function, which is prone to create loops in the
--- transformations. To fix this, we make sure that no transformation will
--- create a new let binding with a non-representable type. These other
--- transformations will just not work on those function-typed values at first,
--- but the other transformations (in particular β-reduction) should make sure
--- that the type of those values eventually becomes representable.
-inlinenonrep :: Transform
-inlinenonrep = inlinebind ((Monad.liftM not) . isRepr . snd)
-
---------------------------------
--- Function specialization
---------------------------------
--- Remove all applications to non-representable arguments, by duplicating the
--- function called with the non-representable parameter replaced by the free
--- variables of the argument passed in.
-argprop :: Transform
--- Transform any application of a named function (i.e., skip applications of
--- lambda's). Also skip applications that have arguments with free type
--- variables, since we can't inline those.
-argprop c expr@(App _ _) | is_var fexpr = do
- -- Find the body of the function called
- body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- Just body -> do
- -- Process each of the arguments in turn
- (args', changed) <- Writer.listen $ mapM doarg args
- -- See if any of the arguments changed
- case Monoid.getAny changed of
- True -> do
- let (newargs', newparams', oldargs) = unzip3 args'
- let newargs = concat newargs'
- let newparams = concat newparams'
- -- Create a new body that consists of a lambda for all new arguments and
- -- the old body applied to some arguments.
- let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
- -- Create a new function with the same name but a new body
- newf <- Trans.lift $ mkFunction f newbody
-
- Trans.lift $ MonadState.modify tsInitStates (\ismap ->
- let init_state_maybe = Map.lookup f ismap in
- case init_state_maybe of
- Nothing -> ismap
- Just init_state -> Map.insert newf init_state ismap)
- -- Replace the original application with one of the new function to the
- -- new arguments.
- change $ MkCore.mkCoreApps (Var newf) newargs
- False ->
- -- Don't change the expression if none of the arguments changed
- return expr
-
- -- If we don't have a body for the function called, leave it unchanged (it
- -- should be a primitive function then).
- Nothing -> return expr
- where
- -- Find the function called and the arguments
- (fexpr, args) = collectArgs expr
- Var f = fexpr
-
- -- Process a single argument and return (args, bndrs, arg), where args are
- -- the arguments to replace the given argument in the original
- -- application, bndrs are the binders to include in the top-level lambda
- -- in the new function body, and arg is the argument to apply to the old
- -- function body.
- doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr)
- doarg arg = do
- repr <- isRepr arg
- bndrs <- Trans.lift getGlobalBinders
- let interesting var = Var.isLocalVar var && (var `notElem` bndrs)
- if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
- then do
- -- Propagate all complex arguments that are not representable, but not
- -- arguments with free type variables (since those would require types
- -- not known yet, which will always be known eventually).
- -- Find interesting free variables, each of which should be passed to
- -- the new function instead of the original function argument.
- --
- -- Interesting vars are those that are local, but not available from the
- -- top level scope (functions from this module are defined as local, but
- -- they're not local to this function, so we can freely move references
- -- to them into another function).
- let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
- -- Mark the current expression as changed
- setChanged
- -- TODO: Clone the free_vars (and update references in arg), since
- -- this might cause conflicts if two arguments that are propagated
- -- share a free variable. Also, we are now introducing new variables
- -- into a function that are not fresh, which violates the binder
- -- uniqueness invariant.
- return (map Var free_vars, free_vars, arg)
- else do
- -- Representable types will not be propagated, and arguments with free
- -- type variables will be propagated later.
- -- Note that we implicitly remove any type variables in the type of
- -- the original argument by using the type of the actual argument
- -- for the new formal parameter.
- -- TODO: preserve original naming?
- id <- Trans.lift $ mkBinderFor arg "param"
- -- Just pass the original argument to the new function, which binds it
- -- to a new id and just pass that new id to the old function body.
- return ([arg], [id], mkReferenceTo id)
--- Leave all other expressions unchanged
-argprop c expr = return expr
-
---------------------------------
--- Non-representable result inlining
---------------------------------
--- This transformation takes a function (top level binding) that has a
--- non-representable result (e.g., a tuple containing a function, or an
--- Integer. The latter can occur in some cases as the result of the
--- fromIntegerT function) and inlines enough of the function to make the
--- result representable again.
---
--- This is done by first normalizing the function and then "inlining"
--- the result. Since no unrepresentable let bindings are allowed in
--- normal form, we can be sure that all free variables of the result
--- expression will be representable (Note that we probably can't
--- guarantee that all representable parts of the expression will be free
--- variables, so we might inline more than strictly needed).
---
--- The new function result will be a tuple containing all free variables
--- of the old result, so the old result can be rebuild at the caller.
---
--- We take care not to inline dictionary id's, which are top level
--- bindings with a non-representable result type as well, since those
--- will never become VHDL signals directly. There is a separate
--- transformation (inlinedict) that specifically inlines dictionaries
--- only when it is useful.
-inlinenonrepresult :: Transform
-
--- Apply to any (application of) a reference to a top level function
--- that is fully applied (i.e., dos not have a function type) but is not
--- representable. We apply in any context, since non-representable
--- expressions are generally left alone and can occur anywhere.
-inlinenonrepresult context expr | not (is_fun expr) =
- case collectArgs expr of
- (Var f, args) | not (Id.isDictId f) -> do
- repr <- isRepr expr
- if not repr
- then do
- body_maybe <- Trans.lift $ getNormalized_maybe True f
- case body_maybe of
- Just body -> do
- let (bndrs, binds, res) = splitNormalizedNonRep body
- if has_free_tyvars res
- then
- -- Don't touch anything with free type variables, since
- -- we can't return those. We'll wait until argprop
- -- removed those variables.
- return expr
- else do
- -- Get the free local variables of res
- global_bndrs <- Trans.lift getGlobalBinders
- let interesting var = Var.isLocalVar var && (var `notElem` global_bndrs)
- let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting res
- let free_var_types = map Id.idType free_vars
- let n_free_vars = length free_vars
- -- Get a tuple datacon to wrap around the free variables
- let fvs_datacon = TysWiredIn.tupleCon BasicTypes.Boxed n_free_vars
- let fvs_datacon_id = DataCon.dataConWorkId fvs_datacon
- -- Let the function now return a tuple with references to
- -- all free variables of the old return value. First pass
- -- all the types of the variables, since tuple
- -- constructors are polymorphic.
- let newres = mkApps (Var fvs_datacon_id) (map Type free_var_types ++ map Var free_vars)
- -- Recreate the function body with the changed return value
- let newbody = mkLams bndrs (Let (Rec binds) newres)
- -- Create the new function
- f' <- Trans.lift $ mkFunction f newbody
-
- -- Call the new function
- let newapp = mkApps (Var f') args
- res_bndr <- Trans.lift $ mkBinderFor newapp "res"
- -- Create extractor case expressions to extract each of the
- -- free variables from the tuple.
- sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1]
-
- -- Bind the res_bndr to the result of the new application
- -- and each of the free variables to the corresponding
- -- selector case. Replace the let body with the original
- -- body of the called function (which can still access all
- -- of its free variables, from the let).
- let binds = (res_bndr, newapp):(zip free_vars sel_cases)
- let letexpr = Let (Rec binds) res
-
- -- Finally, regenarate all uniques in the new expression,
- -- since the free variables could otherwise become
- -- duplicated. It is not strictly necessary to regenerate
- -- res, since we're moving that expression, but it won't
- -- hurt.
- letexpr_uniqued <- Trans.lift $ genUniques letexpr
- change letexpr_uniqued
- Nothing -> return expr
- else
- -- Don't touch representable expressions or (applications of)
- -- dictionary ids.
- return expr
- -- Not a reference to or application of a top level function
- _ -> return expr
--- Leave all other expressions unchanged
-inlinenonrepresult c expr = return expr
-
---------------------------------
--- ClassOp resolution
---------------------------------
--- Resolves any class operation to the actual operation whenever
--- possible. Class methods (as well as parent dictionary selectors) are
--- special "functions" that take a type and a dictionary and evaluate to
--- the corresponding method. A dictionary is nothing more than a
--- special dataconstructor applied to the type the dictionary is for,
--- each of the superclasses and all of the class method definitions for
--- that particular type. Since dictionaries all always inlined (top
--- levels dictionaries are inlined by inlinedict, local dictionaries are
--- inlined by inlinenonrep), we will eventually have something like:
---
--- baz
--- @ CLasH.HardwareTypes.Bit
--- (D:Baz @ CLasH.HardwareTypes.Bit bitbaz)
---
--- Here, baz is the method selector for the baz method, while
--- D:Baz is the dictionary constructor for the Baz and bitbaz is the baz
--- method defined in the Baz Bit instance declaration.
---
--- To resolve this, we can look at the ClassOp IdInfo from the baz Id,
--- which contains the Class it is defined for. From the Class, we can
--- get a list of all selectors (both parent class selectors as well as
--- method selectors). Since the arguments to D:Baz (after the type
--- argument) correspond exactly to this list, we then look up baz in
--- that list and replace the entire expression by the corresponding
--- argument to D:Baz.
---
--- We don't resolve methods that have a builtin translation (such as
--- ==), since the actual implementation is not always (easily)
--- translateable. For example, when deriving ==, GHC generates code
--- using $con2tag functions to translate a datacon to an int and compare
--- that with GHC.Prim.==# . Better to avoid that for now.
-classopresolution :: Transform
-classopresolution c expr@(App (App (Var sel) ty) dict) | not is_builtin =
- case Id.isClassOpId_maybe sel of
- -- Not a class op selector
- Nothing -> return expr
- Just cls -> case collectArgs dict of
- (_, []) -> return expr -- Dict is not an application (e.g., not inlined yet)
- (Var dictdc, (ty':selectors)) | not (Maybe.isJust (Id.isDataConId_maybe dictdc)) -> return expr -- Dictionary is not a datacon yet (but e.g., a top level binder)
- | tyargs_neq ty ty' -> error $ "Normalize.classopresolution: Applying class selector to dictionary without matching type?\n" ++ pprString expr
- | otherwise ->
- let selector_ids = Class.classSelIds cls in
- -- Find the selector used in the class' list of selectors
- case List.elemIndex sel selector_ids of
- Nothing -> error $ "Normalize.classopresolution: Selector not found in class' selector list? This should not happen!\nExpression: " ++ pprString expr ++ "\nClass: " ++ show cls ++ "\nSelectors: " ++ show selector_ids
- -- Get the corresponding argument from the dictionary
- Just n -> change (selectors!!n)
- (_, _) -> return expr -- Not applying a variable? Don't touch
- where
- -- Compare two type arguments, returning True if they are _not_
- -- equal
- tyargs_neq (Type ty1) (Type ty2) = not $ Type.coreEqType ty1 ty2
- tyargs_neq _ _ = True
- -- Is this a builtin function / method?
- is_builtin = elem (Name.getOccString sel) builtinIds
-
--- Leave all other expressions unchanged
-classopresolution c expr = return expr
-
---------------------------------
--- Dictionary inlining
---------------------------------
--- Inline all top level dictionaries, that are in a position where
--- classopresolution can actually resolve them. This makes this
--- transformation look similar to classoperesolution below, but we'll
--- keep them separated for clarity. By not inlining other dictionaries,
--- we prevent expression sizes exploding when huge type level integer
--- dictionaries are inlined which can never be expanded (in casts, for
--- example).
-inlinedict c expr@(App (App (Var sel) ty) (Var dict)) | not is_builtin && is_classop = do
- body_maybe <- Trans.lift $ getGlobalBind dict
- case body_maybe of
- -- No body available (no source available, or a local variable /
- -- argument)
- Nothing -> return expr
- Just body -> change (App (App (Var sel) ty) body)
- where
- -- Is this a builtin function / method?
- is_builtin = elem (Name.getOccString sel) builtinIds
- -- Are we dealing with a class operation selector?
- is_classop = Maybe.isJust (Id.isClassOpId_maybe sel)
-
--- Leave all other expressions unchanged
-inlinedict c expr = return expr
-
-
-{-
---------------------------------
--- Identical let binding merging
---------------------------------
--- Merge two bindings in a let if they are identical
--- TODO: We would very much like to use GHC's CSE module for this, but that
--- doesn't track if something changed or not, so we can't use it properly.
-letmerge :: Transform
-letmerge c expr@(Let _ _) = do
- let (binds, res) = flattenLets expr
- binds' <- domerge binds
- return $ mkNonRecLets binds' res
- where
- domerge :: [(CoreBndr, CoreExpr)] -> TransformMonad [(CoreBndr, CoreExpr)]
- domerge [] = return []
- domerge (e:es) = do
- es' <- mapM (mergebinds e) es
- es'' <- domerge es'
- return (e:es'')
-
- -- Uses the second bind to simplify the second bind, if applicable.
- mergebinds :: (CoreBndr, CoreExpr) -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
- mergebinds (b1, e1) (b2, e2)
- -- Identical expressions? Replace the second binding with a reference to
- -- the first binder.
- | CoreUtils.cheapEqExpr e1 e2 = change $ (b2, Var b1)
- -- Different expressions? Don't change
- | otherwise = return (b2, e2)
--- Leave all other expressions unchanged
-letmerge c expr = return expr
--}
-
---------------------------------
--- End of transformations
---------------------------------
-
-
-
-
--- What transforms to run?
-transforms = [ ("inlinedict", inlinedict)
- , ("inlinetoplevel", inlinetoplevel)
- , ("inlinenonrepresult", inlinenonrepresult)
- , ("knowncase", knowncase)
- , ("classopresolution", classopresolution)
- , ("argprop", argprop)
- , ("funextract", funextract)
- , ("eta", eta)
- , ("beta", beta)
- , ("appprop", appprop)
- , ("castprop", castprop)
- , ("letremovesimple", letremovesimple)
- , ("letrec", letrec)
- , ("letremove", letremove)
- , ("retvalsimpl", retvalsimpl)
- , ("letflat", letflat)
- , ("scrutsimpl", scrutsimpl)
- , ("scrutbndrremove", scrutbndrremove)
- , ("casesimpl", casesimpl)
- , ("caseremove", caseremove)
- , ("inlinenonrep", inlinenonrep)
- , ("appsimpl", appsimpl)
- , ("letremoveunused", letremoveunused)
- , ("castsimpl", castsimpl)
- ]
-
--- | Returns the normalized version of the given function, or an error
--- if it is not a known global binder.
-getNormalized ::
- Bool -- ^ Allow the result to be unrepresentable?
- -> CoreBndr -- ^ The function to get
- -> TranslatorSession CoreExpr -- The normalized function body
-getNormalized result_nonrep bndr = do
- norm <- getNormalized_maybe result_nonrep bndr
- return $ Maybe.fromMaybe
- (error $ "Normalize.getNormalized: Unknown or non-representable function requested: " ++ show bndr)
- norm
-
--- | Returns the normalized version of the given function, or Nothing
--- when the binder is not a known global binder or is not normalizeable.
-getNormalized_maybe ::
- Bool -- ^ Allow the result to be unrepresentable?
- -> CoreBndr -- ^ The function to get
- -> TranslatorSession (Maybe CoreExpr) -- The normalized function body
-
-getNormalized_maybe result_nonrep bndr = do
- expr_maybe <- getGlobalBind bndr
- normalizeable <- isNormalizeable result_nonrep bndr
- if not normalizeable || Maybe.isNothing expr_maybe
- then
- -- Binder not normalizeable or not found
- return Nothing
- else do
- -- Binder found and is monomorphic. Normalize the expression
- -- and cache the result.
- normalized <- Utils.makeCached bndr tsNormalized $
- normalizeExpr (show bndr) (Maybe.fromJust expr_maybe)
- return (Just normalized)
-
--- | Normalize an expression
-normalizeExpr ::
- String -- ^ What are we normalizing? For debug output only.
- -> CoreSyn.CoreExpr -- ^ The expression to normalize
- -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
-
-normalizeExpr what expr = do
- startcount <- MonadState.get tsTransformCounter
- expr_uniqued <- genUniques expr
- -- Do a debug print, if requested
- let expr_uniqued' = Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") expr_uniqued
- -- Normalize this expression
- expr' <- dotransforms transforms expr_uniqued'
- endcount <- MonadState.get tsTransformCounter
- -- Do a debug print, if requested
- Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr') ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
- return expr'
-
--- | Split a normalized expression into the argument binders, top level
--- bindings and the result binder. This function returns an error if
--- the type of the expression is not representable.
-splitNormalized ::
- CoreExpr -- ^ The normalized expression
- -> ([CoreBndr], [Binding], CoreBndr)
-splitNormalized expr =
- case splitNormalizedNonRep expr of
- (args, binds, Var res) -> (args, binds, res)
- _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
-
--- Split a normalized expression, whose type can be unrepresentable.
-splitNormalizedNonRep::
- CoreExpr -- ^ The normalized expression
- -> ([CoreBndr], [Binding], CoreExpr)
-splitNormalizedNonRep expr = (args, binds, resexpr)
- where
- (args, letexpr) = CoreSyn.collectBinders expr
- (binds, resexpr) = flattenLets letexpr
+++ /dev/null
---
--- This module provides functions for program transformations.
---
-module CLasH.Normalize.NormalizeTools where
-
--- Standard modules
-import qualified Data.Monoid as Monoid
-import qualified Data.Either as Either
-import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified Control.Monad.Trans.Class as Trans
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- GHC API
-import CoreSyn
-import qualified Name
-import qualified Id
-import qualified CoreSubst
-import qualified Type
-import qualified CoreUtils
-import Outputable ( showSDoc, ppr, nest )
-
--- Local imports
-import CLasH.Normalize.NormalizeTypes
-import CLasH.Translator.TranslatorTypes
-import CLasH.VHDL.Constants (builtinIds)
-import CLasH.Utils
-import qualified CLasH.Utils.Core.CoreTools as CoreTools
-import qualified CLasH.VHDL.VHDLTools as VHDLTools
-
--- Apply the given transformation to all expressions in the given expression,
--- including the expression itself.
-everywhere :: Transform -> Transform
-everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
-
-data NormDbgLevel =
- NormDbgNone -- ^ No debugging
- | NormDbgFinal -- ^ Print functions before / after normalization
- | NormDbgApplied -- ^ Print expressions before / after applying transformations
- | NormDbgAll -- ^ Print expressions when a transformation does not apply
- deriving (Eq, Ord)
-normalize_debug = NormDbgFinal
-
--- Applies a transform, optionally showing some debug output.
-apply :: (String, Transform) -> Transform
-apply (name, trans) ctx expr = do
- -- Apply the transformation and find out if it changed anything
- (expr', any_changed) <- Writer.listen $ trans ctx expr
- let changed = Monoid.getAny any_changed
- -- If it changed, increase the transformation counter
- Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1))
- -- Prepare some debug strings
- let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n"
- let context = "Context: " ++ show ctx ++ "\n"
- let after = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
- traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $
- traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before ++ context) $
- return expr'
-
--- Apply the first transformation, followed by the second transformation, and
--- keep applying both for as long as expression still changes.
-applyboth :: Transform -> Transform -> Transform
-applyboth first second context expr = do
- -- Apply the first
- expr' <- first context expr
- -- Apply the second
- (expr'', changed) <- Writer.listen $ second context expr'
- if Monoid.getAny $ changed
- then
- applyboth first second context expr''
- else
- return expr''
-
--- Apply the given transformation to all direct subexpressions (only), not the
--- expression itself.
-subeverywhere :: Transform -> Transform
-subeverywhere trans c (App a b) = do
- a' <- trans (AppFirst:c) a
- b' <- trans (AppSecond:c) b
- return $ App a' b'
-
-subeverywhere trans c (Let (NonRec b bexpr) expr) = do
- bexpr' <- trans (LetBinding:c) bexpr
- expr' <- trans (LetBody:c) expr
- return $ Let (NonRec b bexpr') expr'
-
-subeverywhere trans c (Let (Rec binds) expr) = do
- expr' <- trans (LetBody:c) expr
- binds' <- mapM transbind binds
- return $ Let (Rec binds') expr'
- where
- transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
- transbind (b, e) = do
- e' <- trans (LetBinding:c) e
- return (b, e')
-
-subeverywhere trans c (Lam x expr) = do
- expr' <- trans (LambdaBody:c) expr
- return $ Lam x expr'
-
-subeverywhere trans c (Case scrut b t alts) = do
- scrut' <- trans (Other:c) scrut
- alts' <- mapM transalt alts
- return $ Case scrut' b t alts'
- where
- transalt :: CoreAlt -> TransformMonad CoreAlt
- transalt (con, binders, expr) = do
- expr' <- trans (Other:c) expr
- return (con, binders, expr')
-
-subeverywhere trans c (Var x) = return $ Var x
-subeverywhere trans c (Lit x) = return $ Lit x
-subeverywhere trans c (Type x) = return $ Type x
-
-subeverywhere trans c (Cast expr ty) = do
- expr' <- trans (Other:c) expr
- return $ Cast expr' ty
-
-subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
-
--- Runs each of the transforms repeatedly inside the State monad.
-dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
-dotransforms transs expr = do
- (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply trans) [] e) expr transs
- if Monoid.getAny changed then dotransforms transs expr' else return expr'
-
--- Inline all let bindings that satisfy the given condition
-inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
-inlinebind condition context expr@(Let (Rec binds) res) = do
- -- Find all bindings that adhere to the condition
- res_eithers <- mapM docond binds
- case Either.partitionEithers res_eithers of
- -- No replaces? No change
- ([], _) -> return expr
- (replace, others) -> do
- -- Substitute the to be replaced binders with their expression
- newexpr <- do_substitute replace (Let (Rec others) res)
- change newexpr
- where
- -- Apply the condition to a let binding and return an Either
- -- depending on whether it needs to be inlined or not.
- docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
- docond b = do
- res <- condition b
- return $ case res of True -> Left b; False -> Right b
-
- -- Apply the given list of substitutions to the the given expression
- do_substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> TransformMonad CoreExpr
- do_substitute [] expr = return expr
- do_substitute ((bndr, val):reps) expr = do
- -- Perform this substitution in the expression
- expr' <- substitute_clone bndr val context expr
- -- And in the substitution values we will be using next
- reps' <- mapM (subs_bind bndr val) reps
- -- And then perform the remaining substitutions
- do_substitute reps' expr'
-
- -- Replace the given binder with the given expression in the
- -- expression oft the given let binding
- subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
- subs_bind bndr expr (b, v) = do
- v' <- substitute_clone bndr expr (LetBinding:context) v
- return (b, v')
-
-
--- Leave all other expressions unchanged
-inlinebind _ context expr = return expr
-
--- Sets the changed flag in the TransformMonad, to signify that some
--- transform has changed the result
-setChanged :: TransformMonad ()
-setChanged = Writer.tell (Monoid.Any True)
-
--- Sets the changed flag and returns the given value.
-change :: a -> TransformMonad a
-change val = do
- setChanged
- return val
-
--- Returns the given value and sets the changed flag if the bool given is
--- True. Note that this will not unset the changed flag if the bool is False.
-changeif :: Bool -> a -> TransformMonad a
-changeif True val = change val
-changeif False val = return val
-
--- | Creates a transformation that substitutes the given binder with the given
--- expression (This can be a type variable, replace by a Type expression).
--- Does not set the changed flag.
-substitute :: CoreBndr -> CoreExpr -> Transform
--- Use CoreSubst to subst a type var in an expression
-substitute find repl context expr = do
- let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
- return $ CoreSubst.substExpr subst expr
-
--- | Creates a transformation that substitutes the given binder with the given
--- expression. This does only work for value expressions! All binders in the
--- expression are cloned before the replacement, to guarantee uniqueness.
-substitute_clone :: CoreBndr -> CoreExpr -> Transform
--- If we see the var to find, replace it by a uniqued version of repl
-substitute_clone find repl context (Var var) | find == var = do
- repl' <- Trans.lift $ CoreTools.genUniques repl
- change repl'
-
--- For all other expressions, just look in subexpressions
-substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr
-
--- Is the given expression representable at runtime, based on the type?
-isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
-isRepr tything = Trans.lift (isRepr' tything)
-
-isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
-isRepr' tything = case CoreTools.getType tything of
- Nothing -> return False
- Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
-
-is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
-is_local_var (CoreSyn.Var v) = do
- bndrs <- getGlobalBinders
- return $ v `notElem` bndrs
-is_local_var _ = return False
-
--- Is the given binder defined by the user?
-isUserDefined :: CoreSyn.CoreBndr -> Bool
--- System names are certain to not be user defined
-isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
--- Builtin functions are usually not user-defined either (and would
--- break currently if they are...)
-isUserDefined bndr = str `notElem` builtinIds
- where
- str = Name.getOccString bndr
-
--- | Is the given binder normalizable? This means that its type signature can be
--- represented in hardware, which should (?) guarantee that it can be made
--- into hardware. This checks whether all the arguments and (optionally)
--- the return value are
--- representable.
-isNormalizeable ::
- Bool -- ^ Allow the result to be unrepresentable?
- -> CoreBndr -- ^ The binder to check
- -> TranslatorSession Bool -- ^ Is it normalizeable?
-isNormalizeable result_nonrep bndr = do
- let ty = Id.idType bndr
- let (arg_tys, res_ty) = Type.splitFunTys ty
- let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys)
- andM $ mapM isRepr' check_tys
+++ /dev/null
-module CLasH.Normalize.NormalizeTypes where
-
--- Standard modules
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Monoid as Monoid
-
--- GHC API
-import qualified CoreSyn
-
--- Local imports
-import CLasH.Translator.TranslatorTypes
-
--- Wrap a writer around a TranslatorSession, to run a single transformation
--- over a single expression and track if the expression was changed.
-type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession
-
--- | In what context does a core expression occur?
-data CoreContext = AppFirst -- ^ The expression is the first
- -- argument of an application (i.e.,
- -- it is applied)
- | AppSecond -- ^ The expression is the second
- -- argument of an application
- -- (i.e., something is applied to it)
- | LetBinding -- ^ The expression is bound in a
- -- (recursive or non-recursive) let
- -- expression.
- | LetBody -- ^ The expression is the body of a
- -- let expression
- | LambdaBody -- ^ The expression is the body of a
- -- lambda abstraction
- | Other -- ^ Another context
- deriving (Eq, Show)
--- | Transforms a CoreExpr and keeps track if it has changed.
-type Transform = [CoreContext] -> CoreSyn.CoreExpr -> TransformMonad CoreSyn.CoreExpr
+++ /dev/null
-module CLasH.Translator
- (
- makeVHDLAnnotations
- ) where
-
--- Standard Modules
-import qualified System.Directory as Directory
-import qualified Maybe
-import qualified Monad
-import qualified System.FilePath as FilePath
-import qualified Control.Monad.Trans.State as State
-import Text.PrettyPrint.HughesPJ (render)
-import Data.Accessor.Monad.Trans.State
-import qualified Data.Map as Map
-import qualified Data.Time.Clock as Clock
-import Debug.Trace
-
--- GHC API
-import qualified CoreSyn
-import qualified HscTypes
-import qualified UniqSupply
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-import qualified Language.VHDL.FileIO as FileIO
-import qualified Language.VHDL.Ppr as Ppr
-
--- Local Imports
-import CLasH.Translator.TranslatorTypes
-import CLasH.Translator.Annotations
-import CLasH.Utils
-import CLasH.Utils.GhcTools
-import CLasH.VHDL
-import CLasH.VHDL.VHDLTools
-import CLasH.VHDL.Testbench
-
--- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
--- and Test Inputs found in the Files.
-makeVHDLAnnotations ::
- FilePath -- ^ The GHC Library Dir
- -> [FilePath] -- ^ The FileNames
- -> IO ()
-makeVHDLAnnotations libdir filenames =
- makeVHDL libdir filenames finder
- where
- finder = findSpec (hasCLasHAnnotation isTopEntity)
- (hasCLasHAnnotation isInitState)
- (isCLasHAnnotation isInitState)
- (hasCLasHAnnotation isTestInput)
-
--- | Turn Haskell to VHDL, using the given finder functions to find the Top
--- Entity, Initial State and Test Inputs in the Haskell Files.
-makeVHDL ::
- FilePath -- ^ The GHC Library Dir
- -> [FilePath] -- ^ The Filenames
- -> Finder
- -> IO ()
-makeVHDL libdir filenames finder = do
- start <- Clock.getCurrentTime
- -- Load the modules
- (cores, env, specs) <- loadModules libdir filenames (Just finder)
- -- Translate to VHDL
- vhdl <- moduleToVHDL env cores specs
- -- Write VHDL to file. Just use the first entity for the name
- let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
- let dir = "./vhdl/" ++ (show top_entity) ++ "/"
- prepareDir dir
- mapM_ (writeVHDL dir) vhdl
- end <- Clock.getCurrentTime
- trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $
- return ()
-
--- | Translate the specified entities in the given modules to VHDL.
-moduleToVHDL ::
- HscTypes.HscEnv -- ^ The GHC Environment
- -> [HscTypes.CoreModule] -- ^ The Core Modules
- -> [EntitySpec] -- ^ The entities to generate
- -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env cores specs = do
- (vhdl, count) <- runTranslatorSession env $ do
- let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
- -- Store the bindings we loaded
- tsBindings %= Map.fromList all_bindings
- let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs
- tsInitStates %= Map.fromList all_initstates
- test_binds <- catMaybesM $ Monad.mapM mkTest specs
- let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
- vhdl <- case topbinds of
- [] -> error "Could not find top entity requested"
- tops -> createDesignFiles (tops ++ test_binds)
- count <- get tsTransformCounter
- return (vhdl, count)
- mapM_ (putStr . render . Ppr.ppr . snd) vhdl
- putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
- return vhdl
- where
- mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
- -- Create a testbench for any entry that has test input
- mkTest (_, _, Nothing) = return Nothing
- mkTest (Nothing, _, _) = return Nothing
- mkTest (Just top, _, Just input) = do
- bndr <- createTestbench Nothing cores input top
- return $ Just bndr
-
--- Run the given translator session. Generates a new UniqSupply for that
--- session.
-runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
-runTranslatorSession env session = do
- -- Generate a UniqSupply
- -- Running
- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
- -- on the compiler dir of ghc suggests that 'z' is not used to generate
- -- a unique supply anywhere.
- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
- let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
- let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
- return $ State.evalState session init_state
-
--- | Prepares the directory for writing VHDL files. This means creating the
--- dir if it does not exist and removing all existing .vhdl files from it.
-prepareDir :: String -> IO()
-prepareDir dir = do
- -- Create the dir if needed
- Directory.createDirectoryIfMissing True dir
- -- Find all .vhdl files in the directory
- files <- Directory.getDirectoryContents dir
- let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
- -- Prepend the dirname to the filenames
- let abs_to_remove = map (FilePath.combine dir) to_remove
- -- Remove the files
- mapM_ Directory.removeFile abs_to_remove
-
--- | Write the given design file to a file with the given name inside the
--- given dir
-writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
-writeVHDL dir (name, vhdl) = do
- -- Find the filename
- let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
- -- Write the file
- FileIO.writeDesignFile vhdl fname
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
-{-# LANGUAGE DeriveDataTypeable #-}
-module CLasH.Translator.Annotations where
-
-import qualified Language.Haskell.TH as TH
-import Data.Data
-
-data CLasHAnn = TopEntity | InitState TH.Name | TestInput | TestCycles
- deriving (Show, Data, Typeable)
-
-isTopEntity :: CLasHAnn -> Bool
-isTopEntity TopEntity = True
-isTopEntity _ = False
-
-isInitState :: CLasHAnn -> Bool
-isInitState (InitState _) = True
-isInitState _ = False
-
-isTestInput :: CLasHAnn -> Bool
-isTestInput TestInput = True
-isTestInput _ = False
-
-isTestCycles :: CLasHAnn -> Bool
-isTestCycles TestCycles = True
-isTestCycles _ = False
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE TemplateHaskell #-}
---
--- Simple module providing some types used by Translator. These are in a
--- separate module to prevent circular dependencies in Pretty for example.
---
-module CLasH.Translator.TranslatorTypes where
-
--- Standard modules
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Map as Map
-import qualified Data.Accessor.Template
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- GHC API
-import qualified GHC
-import qualified CoreSyn
-import qualified Type
-import qualified HscTypes
-import qualified UniqSupply
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-
--- Local imports
-import CLasH.VHDL.VHDLTypes
-
--- | A specification of an entity we can generate VHDL for. Consists of the
--- binder of the top level entity, an optional initial state and an optional
--- test input.
-type EntitySpec = (Maybe CoreSyn.CoreBndr, Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)], Maybe CoreSyn.CoreExpr)
-
--- | A function that knows which parts of a module to compile
-type Finder =
- HscTypes.CoreModule -- ^ The module to look at
- -> GHC.Ghc [EntitySpec]
-
------------------------------------------------------------------------------
--- The TranslatorSession
------------------------------------------------------------------------------
-
--- A orderable equivalent of CoreSyn's Type for use as a map key
-newtype OrdType = OrdType Type.Type
-instance Eq OrdType where
- (OrdType a) == (OrdType b) = Type.tcEqType a b
-instance Ord OrdType where
- compare (OrdType a) (OrdType b) = Type.tcCmpType a b
-
-data HType = AggrType String [HType] |
- EnumType String [String] |
- VecType Int HType |
- UVecType HType |
- SizedWType Int |
- RangedWType Int |
- SizedIType Int |
- BuiltinType String |
- StateType
- deriving (Eq, Ord, Show)
-
--- A map of a Core type to the corresponding type name, or Nothing when the
--- type would be empty.
-type TypeMapRec = Maybe (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn))
-type TypeMap = Map.Map HType TypeMapRec
-
--- A map of a vector Core element type and function name to the coressponding
--- VHDLId of the function and the function body.
-type TypeFunMap = Map.Map (HType, String) (AST.VHDLId, AST.SubProgBody)
-
-type TfpIntMap = Map.Map OrdType Int
--- A substate that deals with type generation
-data TypeState = TypeState {
- -- | A map of Core type -> VHDL Type
- tsTypes_ :: TypeMap,
- -- | A list of type declarations
- tsTypeDecls_ :: [Maybe AST.PackageDecItem],
- -- | A map of vector Core type -> VHDL type function
- tsTypeFuns_ :: TypeFunMap,
- tsTfpInts_ :: TfpIntMap,
- tsHscEnv_ :: HscTypes.HscEnv
-}
-
--- Derive accessors
-Data.Accessor.Template.deriveAccessors ''TypeState
-
--- Define a session
-type TypeSession = State.State TypeState
--- A global state for the translator
-data TranslatorState = TranslatorState {
- tsUniqSupply_ :: UniqSupply.UniqSupply
- , tsType_ :: TypeState
- , tsBindings_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr
- , tsNormalized_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreExpr
- , tsEntityCounter_ :: Integer
- , tsEntities_ :: Map.Map CoreSyn.CoreBndr Entity
- , tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr])
- , tsInitStates_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr
- , tsTransformCounter_ :: Int -- ^ How many transformations were applied?
-}
-
--- Derive accessors
-Data.Accessor.Template.deriveAccessors ''TranslatorState
-
-type TranslatorSession = State.State TranslatorState
-
------------------------------------------------------------------------------
--- Some accessors
------------------------------------------------------------------------------
-
--- Does the given binder reference a top level binder in the current
--- module(s)?
-isTopLevelBinder :: CoreSyn.CoreBndr -> TranslatorSession Bool
-isTopLevelBinder bndr = do
- bindings <- MonadState.get tsBindings
- return $ Map.member bndr bindings
-
--- Finds the value of a global binding, if available
-getGlobalBind :: CoreSyn.CoreBndr -> TranslatorSession (Maybe CoreSyn.CoreExpr)
-getGlobalBind bndr = do
- bindings <- MonadState.get tsBindings
- return $ Map.lookup bndr bindings
-
--- Adds a new global binding with the given value
-addGlobalBind :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession ()
-addGlobalBind bndr expr = MonadState.modify tsBindings (Map.insert bndr expr)
-
--- Returns a list of all global binders
-getGlobalBinders :: TranslatorSession [CoreSyn.CoreBndr]
-getGlobalBinders = do
- bindings <- MonadState.get tsBindings
- return $ Map.keys bindings
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
-module CLasH.Utils where
-
--- Standard Imports
-import qualified Maybe
-import Data.Accessor
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-import qualified Data.Map as Map
-import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.State as State
-import qualified Debug.Trace as Trace
-
--- Make a caching version of a stateful computatation.
-makeCached :: (Monad m, Ord k) =>
- k -- ^ The key to use for the cache
- -> Accessor s (Map.Map k v) -- ^ The accessor to get at the cache
- -> State.StateT s m v -- ^ How to compute the value to cache?
- -> State.StateT s m v -- ^ The resulting value, from the cache or freshly
- -- computed.
-makeCached key accessor create = do
- cache <- MonadState.get accessor
- case Map.lookup key cache of
- -- Found in cache, just return
- Just value -> return value
- -- Not found, compute it and put it in the cache
- Nothing -> do
- value <- create
- MonadState.modify accessor (Map.insert key value)
- return value
-
-unzipM :: (Monad m) =>
- m [(a, b)]
- -> m ([a], [b])
-unzipM = Monad.liftM unzip
-
-catMaybesM :: (Monad m) =>
- m [Maybe a]
- -> m [a]
-catMaybesM = Monad.liftM Maybe.catMaybes
-
-concatM :: (Monad m) =>
- m [[a]]
- -> m [a]
-concatM = Monad.liftM concat
-
-isJustM :: (Monad m) => m (Maybe a) -> m Bool
-isJustM = Monad.liftM Maybe.isJust
-
-andM, orM :: (Monad m) => m [Bool] -> m Bool
-andM = Monad.liftM and
-orM = Monad.liftM or
-
--- | Monadic versions of any and all. We reimplement them, since there
--- is no ready-made lifting function for them.
-allM, anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
-allM f = andM . (mapM f)
-anyM f = orM . (mapM f)
-
-mapAccumLM :: (Monad m) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
-mapAccumLM _ s [] = return (s, [])
-mapAccumLM f s (x:xs) = do
- (s', y ) <- f s x
- (s'', ys) <- mapAccumLM f s' xs
- return (s'', y:ys)
-
--- Trace the given string if the given bool is True, do nothing
--- otherwise.
-traceIf :: Bool -> String -> a -> a
-traceIf True = Trace.trace
-traceIf False = flip const
+++ /dev/null
---
--- This module contains functions that manipulate binders in various ways.
---
-module CLasH.Utils.Core.BinderTools where
-
--- Standard modules
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- GHC API
-import qualified CoreSyn
-import qualified Type
-import qualified UniqSupply
-import qualified Unique
-import qualified OccName
-import qualified Name
-import qualified Module
-import qualified Var
-import qualified SrcLoc
-import qualified IdInfo
-import qualified CoreUtils
-
--- Local imports
-import CLasH.Translator.TranslatorTypes
-
--- Create a new Unique
-mkUnique :: TranslatorSession Unique.Unique
-mkUnique = do
- us <- MonadState.get tsUniqSupply
- let (us', us'') = UniqSupply.splitUniqSupply us
- MonadState.set tsUniqSupply us'
- return $ UniqSupply.uniqFromSupply us''
-
--- Create a new internal var with the given name and type. A Unique is
--- appended to the given name, to ensure uniqueness (not strictly neccesary,
--- since the Unique is also stored in the name, but this ensures variable
--- names are unique in the output).
-mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var
-mkInternalVar str ty = do
- uniq <- mkUnique
- let occname = OccName.mkVarOcc (str ++ show uniq)
- let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
- return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo
-
--- Create a new type variable with the given name and kind. A Unique is
--- appended to the given name, to ensure uniqueness (not strictly neccesary,
--- since the Unique is also stored in the name, but this ensures variable
--- names are unique in the output).
-mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var
-mkTypeVar str kind = do
- uniq <- mkUnique
- let occname = OccName.mkVarOcc (str ++ show uniq)
- let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
- return $ Var.mkTyVar name kind
-
--- Creates a binder for the given expression with the given name. This
--- works for both value and type level expressions, so it can return a Var or
--- TyVar (which is just an alias for Var).
-mkBinderFor :: CoreSyn.CoreExpr -> String -> TranslatorSession Var.Var
-mkBinderFor (CoreSyn.Type ty) string = mkTypeVar string (Type.typeKind ty)
-mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
-
--- Creates a reference to the given variable. This works for both a normal
--- variable as well as a type variable
-mkReferenceTo :: Var.Var -> CoreSyn.CoreExpr
-mkReferenceTo var | Var.isTyVar var = (CoreSyn.Type $ Type.mkTyVarTy var)
- | otherwise = (CoreSyn.Var var)
-
-cloneVar :: Var.Var -> TranslatorSession Var.Var
-cloneVar v = do
- uniq <- mkUnique
- -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
- -- contains, but vannillaIdInfo is always correct, since it means "no info").
- return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
-
--- Creates a new function with the same name as the given binder (but with a
--- new unique) and with the given function body. Returns the new binder for
--- this function.
-mkFunction :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreBndr
-mkFunction bndr body = do
- let ty = CoreUtils.exprType body
- id <- cloneVar bndr
- let newid = Var.setVarType id ty
- addGlobalBind newid body
- return newid
-
--- Returns the full name of a NamedThing, in the forum
--- modulename.occname
-getFullString :: Name.NamedThing a => a -> String
-getFullString thing = modstr ++ occstr
- where
- name = Name.getName thing
- modstr = case Name.nameModule_maybe name of
- Nothing -> ""
- Just mod -> Module.moduleNameString (Module.moduleName mod) ++ "."
- occstr = Name.getOccString name
+++ /dev/null
-{-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
---
--- This module derives Show instances for CoreSyn types.
---
-module CLasH.Utils.Core.CoreShow where
-
--- GHC API
-import qualified BasicTypes
-import qualified CoreSyn
-import qualified TypeRep
-import qualified TyCon
-import qualified HsTypes
-import qualified HsExpr
-import qualified HsBinds
-import qualified SrcLoc
-import qualified RdrName
-import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)
-
--- Derive Show for core expressions and binders, so we can see the actual
--- structure.
-deriving instance (Show b) => Show (CoreSyn.Expr b)
-deriving instance (Show b) => Show (CoreSyn.Bind b)
-deriving instance Show TypeRep.Type
-deriving instance (Show n, OutputableBndr n) => Show (HsTypes.HsType n)
-deriving instance (Show n, OutputableBndr n) => Show (HsTypes.ConDeclField n)
-deriving instance (Show x) => Show (SrcLoc.Located x)
-deriving instance (Show x, OutputableBndr x) => Show (HsExpr.StmtLR x x)
-deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsTupArg x)
-deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsExpr x)
-deriving instance Show (RdrName.RdrName)
-deriving instance (Show idL, Show idR, OutputableBndr idL, OutputableBndr idR) => Show (HsBinds.HsBindLR idL idR)
-deriving instance Show CoreSyn.Note
-deriving instance Show TyCon.SynTyConRhs
-
-
--- Implement dummy shows, since deriving them will need loads of other shows
--- as well.
-instance Show TypeRep.PredType where
- show t = "_PredType:(" ++ showSDoc (ppr t) ++ ")"
-instance Show TyCon.TyCon where
- show t | TyCon.isAlgTyCon t && not (TyCon.isTupleTyCon t) =
- showtc "AlgTyCon" ""
- | TyCon.isCoercionTyCon t =
- showtc "CoercionTyCon" ""
- | TyCon.isSynTyCon t =
- showtc "SynTyCon" (", synTcRhs = " ++ synrhs)
- | TyCon.isTupleTyCon t =
- showtc "TupleTyCon" ""
- | TyCon.isFunTyCon t =
- showtc "FunTyCon" ""
- | TyCon.isPrimTyCon t =
- showtc "PrimTyCon" ""
- | TyCon.isSuperKindTyCon t =
- showtc "SuperKindTyCon" ""
- | otherwise =
- "_Nonexistant tycon?:(" ++ showSDoc (ppr t) ++ ")_"
- where
- showtc con extra = "(" ++ con ++ " {tyConName = " ++ name ++ extra ++ ", ...})"
- name = show (TyCon.tyConName t)
- synrhs = show (TyCon.synTyConRhs t)
-instance Show BasicTypes.Boxity where
- show b = "_Boxity"
-instance Show HsTypes.HsExplicitForAll where
- show b = "_HsExplicitForAll"
-instance Show HsExpr.HsArrAppType where
- show b = "_HsArrAppType"
-instance Show (HsExpr.MatchGroup x) where
- show b = "_HsMatchGroup"
-instance Show (HsExpr.GroupByClause x) where
- show b = "_GroupByClause"
-instance Show (HsExpr.HsStmtContext x) where
- show b = "_HsStmtContext"
-instance Show (HsBinds.Prag) where
- show b = "_Prag"
-instance Show (HsExpr.GRHSs id) where
- show b = "_GRHSs"
-
-
-instance (Outputable x) => Show x where
- show x = "__" ++ showSDoc (ppr x) ++ "__"
+++ /dev/null
-{-# LANGUAGE PatternGuards, TypeSynonymInstances #-}
--- | This module provides a number of functions to find out things about Core
--- programs. This module does not provide the actual plumbing to work with
--- Core and Haskell (it uses HsTools for this), but only the functions that
--- know about various libraries and know which functions to call.
-module CLasH.Utils.Core.CoreTools where
-
---Standard modules
-import qualified Maybe
-import qualified System.IO.Unsafe
-import qualified Data.Map as Map
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- GHC API
-import qualified GHC
-import qualified Type
-import qualified TcType
-import qualified HsExpr
-import qualified HsTypes
-import qualified HscTypes
-import qualified Name
-import qualified Id
-import qualified TyCon
-import qualified DataCon
-import qualified TysWiredIn
-import qualified DynFlags
-import qualified SrcLoc
-import qualified CoreSyn
-import qualified Var
-import qualified IdInfo
-import qualified VarSet
-import qualified CoreUtils
-import qualified CoreFVs
-import qualified Literal
-import qualified MkCore
-import qualified VarEnv
-
--- Local imports
-import CLasH.Translator.TranslatorTypes
-import CLasH.Utils.GhcTools
-import CLasH.Utils.Core.BinderTools
-import CLasH.Utils.HsTools
-import CLasH.Utils.Pretty
-import CLasH.Utils
-import qualified CLasH.Utils.Core.BinderTools as BinderTools
-
--- | A single binding, used as a shortcut to simplify type signatures.
-type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr)
-
--- | Evaluate a core Type representing type level int from the tfp
--- library to a real int. Checks if the type really is a Dec type and
--- caches the results.
-tfp_to_int :: Type.Type -> TypeSession Int
-tfp_to_int ty = do
- hscenv <- MonadState.get tsHscEnv
- let norm_ty = normalize_tfp_int hscenv ty
- case Type.splitTyConApp_maybe norm_ty of
- Just (tycon, args) -> do
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "Dec" ->
- tfp_to_int' ty
- otherwise -> do
- return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
- Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
-
--- | Evaluate a core Type representing type level int from the tfp
--- library to a real int. Caches the results. Do not use directly, use
--- tfp_to_int instead.
-tfp_to_int' :: Type.Type -> TypeSession Int
-tfp_to_int' ty = do
- lens <- MonadState.get tsTfpInts
- hscenv <- MonadState.get tsHscEnv
- let norm_ty = normalize_tfp_int hscenv ty
- let existing_len = Map.lookup (OrdType norm_ty) lens
- case existing_len of
- Just len -> return len
- Nothing -> do
- let new_len = eval_tfp_int hscenv ty
- MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
- return new_len
-
--- | Evaluate a core Type representing type level int from the tfp
--- library to a real int. Do not use directly, use tfp_to_int instead.
-eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
-eval_tfp_int env ty =
- unsafeRunGhc libdir $ do
- GHC.setSession env
- -- Automatically import modules for any fully qualified identifiers
- setDynFlag DynFlags.Opt_ImplicitImportQualified
-
- let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT"
- let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
- let undef = hsTypedUndef $ coreToHsType ty
- let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
- let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
- let expr = HsExpr.ExprWithTySig app int_ty
- core <- toCore expr
- execCore core
- where
- libdir = DynFlags.topDir dynflags
- dynflags = HscTypes.hsc_dflags env
-
-normalize_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
-normalize_tfp_int env ty =
- System.IO.Unsafe.unsafePerformIO $
- normalizeType env ty
-
-sized_word_len_ty :: Type.Type -> Type.Type
-sized_word_len_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
- [len] = args
-
-sized_int_len_ty :: Type.Type -> Type.Type
-sized_int_len_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
- [len] = args
-
-ranged_word_bound_ty :: Type.Type -> Type.Type
-ranged_word_bound_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
- [len] = args
-
-tfvec_len_ty :: Type.Type -> Type.Type
-tfvec_len_ty ty = len
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
- [len, el_ty] = args
-
--- | Get the element type of a TFVec type
-tfvec_elem :: Type.Type -> Type.Type
-tfvec_elem ty = el_ty
- where
- args = case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> args
- Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
- [len, el_ty] = args
-
--- Is the given core expression a lambda abstraction?
-is_lam :: CoreSyn.CoreExpr -> Bool
-is_lam (CoreSyn.Lam _ _) = True
-is_lam _ = False
-
--- Is the given core expression a let expression?
-is_let :: CoreSyn.CoreExpr -> Bool
-is_let (CoreSyn.Let _ _) = True
-is_let _ = False
-
--- Is the given core expression of a function type?
-is_fun :: CoreSyn.CoreExpr -> Bool
--- Treat Type arguments differently, because exprType is not defined for them.
-is_fun (CoreSyn.Type _) = False
-is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
-
--- Is the given core expression polymorphic (i.e., does it accept type
--- arguments?).
-is_poly :: CoreSyn.CoreExpr -> Bool
--- Treat Type arguments differently, because exprType is not defined for them.
-is_poly (CoreSyn.Type _) = False
-is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
-
--- Is the given core expression a variable reference?
-is_var :: CoreSyn.CoreExpr -> Bool
-is_var (CoreSyn.Var _) = True
-is_var _ = False
-
-is_lit :: CoreSyn.CoreExpr -> Bool
-is_lit (CoreSyn.Lit _) = True
-is_lit _ = False
-
--- Can the given core expression be applied to something? This is true for
--- applying to a value as well as a type.
-is_applicable :: CoreSyn.CoreExpr -> Bool
-is_applicable expr = is_fun expr || is_poly expr
-
--- Is the given core expression a variable or an application?
-is_simple :: CoreSyn.CoreExpr -> Bool
-is_simple (CoreSyn.App _ _) = True
-is_simple (CoreSyn.Var _) = True
-is_simple (CoreSyn.Cast expr _) = is_simple expr
-is_simple _ = False
-
--- Does the given CoreExpr have any free type vars?
-has_free_tyvars :: CoreSyn.CoreExpr -> Bool
-has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
-
--- Does the given type have any free type vars?
-ty_has_free_tyvars :: Type.Type -> Bool
-ty_has_free_tyvars = not . VarSet.isEmptyVarSet . Type.tyVarsOfType
-
--- Does the given CoreExpr have any free local vars?
-has_free_vars :: CoreSyn.CoreExpr -> Bool
-has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
-
--- Does the given expression use any of the given binders?
-expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool
-expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))
-
--- Turns a Var CoreExpr into the Id inside it. Will of course only work for
--- simple Var CoreExprs, not complexer ones.
-exprToVar :: CoreSyn.CoreExpr -> Var.Id
-exprToVar (CoreSyn.Var id) = id
-exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
-
--- Turns a Lit CoreExpr into the Literal inside it.
-exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
-exprToLit (CoreSyn.Lit lit) = lit
-exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
-
--- Removes all the type and dictionary arguments from the given argument list,
--- leaving only the normal value arguments. The type given is the type of the
--- expression applied to this argument list.
-get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
-get_val_args ty args = drop n args
- where
- (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
- -- The first (length tyvars) arguments should be types, the next
- -- (length predtypes) arguments should be dictionaries. We drop this many
- -- arguments, to get at the value arguments.
- n = length tyvars + length predtypes
-
--- Finds out what literal Integer this expression represents.
-getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer
-getIntegerLiteral expr =
- case CoreSyn.collectArgs expr of
- (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)])
- | getFullString f == "GHC.Integer.smallInteger" -> return integer
- (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)])
- | getFullString f == "GHC.Integer.int64ToInteger" -> return integer
- (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)])
- | getFullString f == "GHC.Integer.wordToInteger" -> return integer
- (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)])
- | getFullString f == "GHC.Integer.word64ToInteger" -> return integer
- -- fromIntegerT returns the integer corresponding to the type of its
- -- (third) argument. Since it is polymorphic, the type of that
- -- argument is passed as the first argument, so we can just use that
- -- one.
- (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg])
- | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do
- int <- MonadState.lift tsType $ tfp_to_int dec_ty
- return $ toInteger int
- _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr
-
-reduceCoreListToHsList ::
- [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
- -> CoreSyn.CoreExpr -- ^ The refence to atleast one of the nodes
- -> TranslatorSession [CoreSyn.CoreExpr]
-reduceCoreListToHsList cores app@(CoreSyn.App _ _) = do {
- ; let { (fun, args) = CoreSyn.collectArgs app
- ; len = length args
- } ;
- ; case len of
- 3 -> do {
- ; let topelem = args!!1
- ; case (args!!2) of
- (varz@(CoreSyn.Var id)) -> do {
- ; binds <- mapM (findExpr (isVarName id)) cores
- ; otherelems <- reduceCoreListToHsList cores (head (Maybe.catMaybes binds))
- ; return (topelem:otherelems)
- }
- (appz@(CoreSyn.App _ _)) -> do {
- ; otherelems <- reduceCoreListToHsList cores appz
- ; return (topelem:otherelems)
- }
- otherwise -> return [topelem]
- }
- otherwise -> return []
- }
- where
- isVarName :: Monad m => Var.Var -> Var.Var -> m Bool
- isVarName lookfor bind = return $ (Var.varName lookfor) == (Var.varName bind)
-
-reduceCoreListToHsList _ _ = return []
-
--- Is the given var the State data constructor?
-isStateCon :: Var.Var -> Bool
-isStateCon var =
- -- See if it is a DataConWrapId (not DataConWorkId, since State is a
- -- newtype).
- case Id.idDetails var of
- IdInfo.DataConWrapId dc ->
- -- See if the datacon is the State datacon from the State type.
- let tycon = DataCon.dataConTyCon dc
- tyname = Name.getOccString tycon
- dcname = Name.getOccString dc
- in case (tyname, dcname) of
- ("State", "State") -> True
- _ -> False
- _ -> False
-
--- | Is the given type a State type?
-isStateType :: Type.Type -> Bool
--- Resolve any type synonyms remaining
-isStateType ty | Just ty' <- Type.tcView ty = isStateType ty'
-isStateType ty = Maybe.isJust $ do
- -- Split the type. Don't use normal splitAppTy, since that looks through
- -- newtypes, and we want to see the State newtype.
- (typef, _) <- Type.repSplitAppTy_maybe ty
- -- See if the applied type is a type constructor
- (tycon, _) <- Type.splitTyConApp_maybe typef
- if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State"
- then
- Just ()
- else
- Nothing
-
--- | Does the given TypedThing have a State type?
-hasStateType :: (TypedThing t) => t -> Bool
-hasStateType expr = case getType expr of
- Nothing -> False
- Just ty -> isStateType ty
-
-
--- | Flattens nested lets into a single list of bindings. The expression
--- passed does not have to be a let expression, if it isn't an empty list of
--- bindings is returned.
-flattenLets ::
- CoreSyn.CoreExpr -- ^ The expression to flatten.
- -> ([Binding], CoreSyn.CoreExpr) -- ^ The bindings and resulting expression.
-flattenLets (CoreSyn.Let binds expr) =
- (bindings ++ bindings', expr')
- where
- -- Recursively flatten the contained expression
- (bindings', expr') =flattenLets expr
- -- Flatten our own bindings to remove the Rec / NonRec constructors
- bindings = CoreSyn.flattenBinds [binds]
-flattenLets expr = ([], expr)
-
--- | Create bunch of nested non-recursive let expressions from the given
--- bindings. The first binding is bound at the highest level (and thus
--- available in all other bindings).
-mkNonRecLets :: [Binding] -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr
-mkNonRecLets bindings expr = MkCore.mkCoreLets binds expr
- where
- binds = map (uncurry CoreSyn.NonRec) bindings
-
--- | A class of things that (optionally) have a core Type. The type is
--- optional, since Type expressions don't have a type themselves.
-class TypedThing t where
- getType :: t -> Maybe Type.Type
-
-instance TypedThing CoreSyn.CoreExpr where
- getType (CoreSyn.Type _) = Nothing
- getType expr = Just $ CoreUtils.exprType expr
-
-instance TypedThing CoreSyn.CoreBndr where
- getType = return . Id.idType
-
-instance TypedThing Type.Type where
- getType = return . id
-
--- | Generate new uniques for all binders in the given expression.
--- Does not support making type variables unique, though this could be
--- supported if required (by passing a CoreSubst.Subst instead of VarEnv to
--- genUniques' below).
-genUniques :: CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr
-genUniques = genUniques' VarEnv.emptyVarEnv
-
--- | A helper function to generate uniques, that takes a VarEnv containing the
--- substitutions already performed.
-genUniques' :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr
-genUniques' subst (CoreSyn.Var f) = do
- -- Replace the binder with its new value, if applicable.
- let f' = VarEnv.lookupWithDefaultVarEnv subst f f
- return (CoreSyn.Var f')
--- Leave literals untouched
-genUniques' subst (CoreSyn.Lit l) = return $ CoreSyn.Lit l
-genUniques' subst (CoreSyn.App f arg) = do
- -- Only work on subexpressions
- f' <- genUniques' subst f
- arg' <- genUniques' subst arg
- return (CoreSyn.App f' arg')
--- Don't change type abstractions
-genUniques' subst expr@(CoreSyn.Lam bndr res) | CoreSyn.isTyVar bndr = return expr
-genUniques' subst (CoreSyn.Lam bndr res) = do
- -- Generate a new unique for the bound variable
- (subst', bndr') <- genUnique subst bndr
- res' <- genUniques' subst' res
- return (CoreSyn.Lam bndr' res')
-genUniques' subst (CoreSyn.Let (CoreSyn.NonRec bndr bound) res) = do
- -- Make the binders unique
- (subst', bndr') <- genUnique subst bndr
- bound' <- genUniques' subst' bound
- res' <- genUniques' subst' res
- return $ CoreSyn.Let (CoreSyn.NonRec bndr' bound') res'
-genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
- -- Make each of the binders unique
- (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)
- bounds' <- mapM (genUniques' subst' . snd) binds
- res' <- genUniques' subst' res
- let binds' = zip bndrs' bounds'
- return $ CoreSyn.Let (CoreSyn.Rec binds') res'
-genUniques' subst (CoreSyn.Case scrut bndr ty alts) = do
- -- Process the scrutinee with the original substitution, since non of the
- -- binders bound in the Case statement is in scope in the scrutinee.
- scrut' <- genUniques' subst scrut
- -- Generate a new binder for the scrutinee
- (subst', bndr') <- genUnique subst bndr
- -- Process each of the alts
- alts' <- mapM (doalt subst') alts
- return $ CoreSyn.Case scrut' bndr' ty alts'
- where
- doalt subst (con, bndrs, expr) = do
- (subst', bndrs') <- mapAccumLM genUnique subst bndrs
- expr' <- genUniques' subst' expr
- -- Note that we don't return subst', since bndrs are only in scope in
- -- expr.
- return (con, bndrs', expr')
-genUniques' subst (CoreSyn.Cast expr coercion) = do
- expr' <- genUniques' subst expr
- -- Just process the casted expression
- return $ CoreSyn.Cast expr' coercion
-genUniques' subst (CoreSyn.Note note expr) = do
- expr' <- genUniques' subst expr
- -- Just process the annotated expression
- return $ CoreSyn.Note note expr'
--- Leave types untouched
-genUniques' subst expr@(CoreSyn.Type _) = return expr
-
--- Generate a new unique for the given binder, and extend the given
--- substitution to reflect this.
-genUnique :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> TranslatorSession (VarEnv.VarEnv CoreSyn.CoreBndr, CoreSyn.CoreBndr)
-genUnique subst bndr = do
- bndr' <- BinderTools.cloneVar bndr
- -- Replace all occurences of the old binder with a reference to the new
- -- binder.
- let subst' = VarEnv.extendVarEnv subst bndr bndr'
- return (subst', bndr')
-
--- Create a "selector" case that selects the ith field from a datacon
-mkSelCase :: CoreSyn.CoreExpr -> Int -> TranslatorSession CoreSyn.CoreExpr
-mkSelCase scrut i = do
- let scrut_ty = CoreUtils.exprType scrut
- case Type.splitTyConApp_maybe scrut_ty of
- -- The scrutinee should have a type constructor. We keep the type
- -- arguments around so we can instantiate the field types below
- Just (tycon, tyargs) -> case TyCon.tyConDataCons tycon of
- -- The scrutinee type should have a single dataconstructor,
- -- otherwise we can't construct a valid selector case.
- [datacon] -> do
- let field_tys = DataCon.dataConInstOrigArgTys datacon tyargs
- -- Create a list of wild binders for the fields we don't want
- let wildbndrs = map MkCore.mkWildBinder field_tys
- -- Create a single binder for the field we want
- sel_bndr <- mkInternalVar "sel" (field_tys!!i)
- -- Create a wild binder for the scrutinee
- let scrut_bndr = MkCore.mkWildBinder scrut_ty
- -- Create the case expression
- let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs
- return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]
- dcs -> error $ "CoreTools.mkSelCase: Scrutinee type must have exactly one datacon. Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "' Datacons: " ++ (show dcs) ++ " Type: " ++ (pprString scrut_ty)
- Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)
+++ /dev/null
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module CLasH.Utils.GhcTools where
-
--- Standard modules
-import qualified Monad
-import qualified System.IO.Unsafe
-import qualified Language.Haskell.TH as TH
-import qualified Maybe
-
--- GHC API
-import qualified Annotations
-import qualified CoreSyn
-import qualified CoreUtils
-import qualified DynFlags
-import qualified HscTypes
-import qualified GHC
-import qualified Name
-import qualified Serialized
-import qualified Var
-import qualified Outputable
-import qualified Class
-
--- Local Imports
-import CLasH.Utils.Pretty
-import CLasH.Translator.TranslatorTypes
-import CLasH.Translator.Annotations
-import CLasH.Utils
-
-listBindings :: FilePath -> [FilePath] -> IO ()
-listBindings libdir filenames = do
- (cores,_,_) <- loadModules libdir filenames Nothing
- let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
- mapM listBinding binds
- putStr "\n=========================\n"
- let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
- mapM listClass classes
- return ()
-
-listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
-listBinding (b, e) = do
- putStr "\nBinder: "
- putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]"
- putStr "\nType of Binder: \n"
- putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
- putStr "\n\nExpression: \n"
- putStr $ prettyShow e
- putStr "\n\n"
- putStr $ Outputable.showSDoc $ Outputable.ppr e
- putStr "\n\nType of Expression: \n"
- putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
- putStr "\n\n"
-
-listClass :: Class.Class -> IO ()
-listClass c = do
- putStr "\nClass: "
- putStr $ show (Class.className c)
- putStr "\nSelectors: "
- putStr $ show (Class.classSelIds c)
- putStr "\n"
-
--- | Show the core structure of the given binds in the given file.
-listBind :: FilePath -> [FilePath] -> String -> IO ()
-listBind libdir filenames name = do
- (cores,_,_) <- loadModules libdir filenames Nothing
- bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
- mapM_ listBinding bindings
- return ()
-
--- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
--- be no standard function to do exactly this.
-setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
-setDynFlag dflag = do
- dflags <- GHC.getSessionDynFlags
- let dflags' = DynFlags.dopt_set dflags dflag
- GHC.setSessionDynFlags dflags'
- return ()
-
--- We don't want the IO monad sprinkled around everywhere, so we hide it.
--- This should be safe as long as we only do simple things in the GhcMonad
--- such as interface lookups and evaluating simple expressions that
--- don't have side effects themselves (Or rather, that don't use
--- unsafePerformIO themselves, since normal side effectful function would
--- just return an IO monad when they are evaluated).
-unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
-unsafeRunGhc libDir m =
- System.IO.Unsafe.unsafePerformIO $
- GHC.runGhc (Just libDir) $ do
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- m
-
--- | Loads the given files and turns it into a core module
-loadModules ::
- FilePath -- ^ The GHC Library directory
- -> [String] -- ^ The files that need to be loaded
- -> Maybe Finder -- ^ What entities to build?
- -> IO ( [HscTypes.CoreModule]
- , HscTypes.HscEnv
- , [EntitySpec]
- ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
-loadModules libdir filenames finder =
- GHC.defaultErrorHandler DynFlags.defaultDynFlags $
- GHC.runGhc (Just libdir) $ do
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- cores <- mapM GHC.compileToCoreModule filenames
- env <- GHC.getSession
- specs <- case finder of
- Nothing -> return []
- Just f -> concatM $ mapM f cores
- return (cores, env, specs)
-
-findBinds ::
- Monad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe [CoreSyn.CoreBndr])
-findBinds criteria core = do
- binders <- findBinder criteria core
- case binders of
- [] -> return Nothing
- bndrs -> return $ Just $ map fst bndrs
-
-findBind ::
- Monad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe CoreSyn.CoreBndr)
-findBind criteria core = do
- binders <- findBinds criteria core
- case binders of
- Nothing -> return Nothing
- (Just bndrs) -> return $ Just $ head bndrs
-
-findExprs ::
- Monad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe [CoreSyn.CoreExpr])
-findExprs criteria core = do
- binders <- findBinder criteria core
- case binders of
- [] -> return Nothing
- bndrs -> return $ Just (map snd bndrs)
-
-findExpr ::
- Monad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe CoreSyn.CoreExpr)
-findExpr criteria core = do
- exprs <- findExprs criteria core
- case exprs of
- Nothing -> return Nothing
- (Just exprs) -> return $ Just $ head exprs
-
-findAnns ::
- Monad m =>
- (Var.Var -> m [CLasHAnn])
- -> HscTypes.CoreModule
- -> m [CLasHAnn]
-findAnns criteria core = do
- let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
- anns <- Monad.mapM (criteria . fst) binds
- case anns of
- [] -> return []
- xs -> return $ concat xs
-
--- | Find a binder in module according to a certain criteria
-findBinder ::
- Monad m =>
- (Var.Var -> m Bool) -- ^ The criteria to filter the binders on
- -> HscTypes.CoreModule -- ^ The module to be inspected
- -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
-findBinder criteria core = do
- let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
- Monad.filterM (criteria . fst) binds
-
--- | Determine if a binder has an Annotation meeting a certain criteria
-isCLasHAnnotation ::
- GHC.GhcMonad m =>
- (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
- -> Var.Var -- ^ The Binder
- -> m [CLasHAnn] -- ^ Indicates if binder has the Annotation
-isCLasHAnnotation clashAnn var = do
- let deserializer = Serialized.deserializeWithData
- let target = Annotations.NamedTarget (Var.varName var)
- (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
- let annEnts = filter clashAnn anns
- return annEnts
-
--- | Determine if a binder has an Annotation meeting a certain criteria
-hasCLasHAnnotation ::
- GHC.GhcMonad m =>
- (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
- -> Var.Var -- ^ The Binder
- -> m Bool -- ^ Indicates if binder has the Annotation
-hasCLasHAnnotation clashAnn var = do
- anns <- isCLasHAnnotation clashAnn var
- case anns of
- [] -> return False
- xs -> return True
-
--- | Determine if a binder has a certain name
-hasVarName ::
- Monad m =>
- String -- ^ The name the binder has to have
- -> Var.Var -- ^ The Binder
- -> m Bool -- ^ Indicate if the binder has the name
-hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
-
-
-findInitStates ::
- (Var.Var -> GHC.Ghc Bool) ->
- (Var.Var -> GHC.Ghc [CLasHAnn]) ->
- HscTypes.CoreModule ->
- GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
-findInitStates statec annsc mod = do
- states <- findBinds statec mod
- anns <- findAnns annsc mod
- let funs = Maybe.catMaybes (map extractInits anns)
- exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
- let exprs = Maybe.catMaybes exprs'
- let inits = zipMWith (\a b -> (a,b)) states exprs
- return inits
- where
- extractInits :: CLasHAnn -> Maybe TH.Name
- extractInits (InitState x) = Just x
- extractInits _ = Nothing
- zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
- zipMWith _ Nothing _ = Nothing
- zipMWith f (Just as) bs = Just $ zipWith f as bs
-
--- | Make a complete spec out of a three conditions
-findSpec ::
- (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
- -> Finder
-
-findSpec topc statec annsc testc mod = do
- top <- findBind topc mod
- state <- findExprs statec mod
- anns <- findAnns annsc mod
- test <- findExpr testc mod
- inits <- findInitStates statec annsc mod
- return [(top, inits, test)]
- -- case top of
- -- Just t -> return [(t, state, test)]
- -- Nothing -> return error $ "Could not find top entity requested"
+++ /dev/null
-module CLasH.Utils.HsTools where
-
--- Standard modules
-import qualified Unsafe.Coerce
-import qualified Maybe
-
--- GHC API
-import qualified GHC
-import qualified HscMain
-import qualified HscTypes
-import qualified DynFlags
-import qualified FastString
-import qualified StringBuffer
-import qualified MonadUtils
-import Outputable ( showSDoc, ppr )
-import qualified Outputable
--- Lexer & Parser, i.e. up to HsExpr
-import qualified Lexer
-import qualified Parser
--- HsExpr representation, renaming, typechecking and desugaring
--- (i.e., everything up to Core).
-import qualified HsSyn
-import qualified HsExpr
-import qualified HsTypes
-import qualified HsBinds
-import qualified TcRnMonad
-import qualified TcRnTypes
-import qualified RnExpr
-import qualified RnEnv
-import qualified TcExpr
-import qualified TcEnv
-import qualified TcSimplify
-import qualified TcTyFuns
-import qualified Desugar
-import qualified PrelNames
-import qualified Module
-import qualified OccName
-import qualified RdrName
-import qualified Name
-import qualified SrcLoc
-import qualified LoadIface
-import qualified BasicTypes
--- Core representation and handling
-import qualified CoreSyn
-import qualified Id
-import qualified Type
-import qualified TyCon
-
--- | Translate a HsExpr to a Core expression. This does renaming, type
--- checking, simplification of class instances and desugaring. The result is
--- a let expression that holds the given expression and a number of binds that
--- are needed for any type classes used to work. For example, the HsExpr:
--- \x = x == (1 :: Int)
--- will result in the CoreExpr
--- let
--- $dInt = ...
--- (==) = Prelude.(==) Int $dInt
--- in
--- \x = (==) x 1
-toCore ::
- HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
- -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
-toCore expr = do
- env <- GHC.getSession
- let icontext = HscTypes.hsc_IC env
-
- (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
- -- Translage the TcRn (typecheck-rename) monad into an IO monad
- TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
- (tc_expr, insts) <- TcRnMonad.getLIE $ do
- -- Rename the expression, resulting in a HsExpr Name
- (rn_expr, freevars) <- RnExpr.rnExpr expr
- -- Typecheck the expression, resulting in a HsExpr Id and a list of
- -- Insts
- (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
- return res
- -- Translate the instances into bindings
- --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
- binds <- TcSimplify.tcSimplifyTop insts
- return (binds, tc_expr)
-
- -- Create a let expression with the extra binds (for polymorphism etc.) and
- -- the resulting expression.
- let letexpr = SrcLoc.noLoc $ HsExpr.HsLet
- (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
- tc_expr
- -- Desugar the expression, resulting in core.
- let rdr_env = HscTypes.ic_rn_gbl_env icontext
- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
-
-
--- | Create an Id from a RdrName. Might not work for DataCons...
-mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
-mkId rdr_name = do
- env <- GHC.getSession
- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $
- -- Translage the TcRn (typecheck-rename) monad in an IO monad
- TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $
- -- Automatically import all available modules, so fully qualified names
- -- always work
- TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
- -- Lookup a Name for the RdrName. This finds the package (version) in
- -- which the name resides.
- name <- RnEnv.lookupGlobalOccRn rdr_name
- -- Lookup an Id for the Name. This finds out the the type of the thing
- -- we're looking for.
- --
- -- Note that tcLookupId doesn't seem to work for DataCons. See source for
- -- tcLookupId to find out.
- TcEnv.tcLookupId name
-
-normalizeType ::
- HscTypes.HscEnv
- -> Type.Type
- -> IO Type.Type
-normalizeType env ty = do
- (err, nty) <- MonadUtils.liftIO $
- -- Initialize the typechecker monad
- TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
- -- Normalize the type
- (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
- return nty
- let normalized_ty = Maybe.fromJust nty
- return normalized_ty
-
--- | Translate a core Type to an HsType. Far from complete so far.
-coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
--- Translate TyConApps
-coreToHsType ty = case Type.splitTyConApp_maybe ty of
- Just (tycon, tys) ->
- foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
- where
- tycon_name = TyCon.tyConName tycon
- mod_name = Module.moduleName $ Name.nameModule tycon_name
- occ_name = Name.nameOccName tycon_name
- tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
- tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
- Nothing -> error "HsTools.coreToHsType Cannot translate non-tycon type"
-
--- | Evaluate a CoreExpr and return its value. For this to work, the caller
--- should already know the result type for sure, since the result value is
--- unsafely coerced into this type.
-execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
-execCore expr = do
- -- Setup session flags (yeah, this seems like a noop, but
- -- setSessionDynFlags really does some extra work...)
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- -- Compile the expressions. This runs in the IO monad, but really wants
- -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
- -- understand what it means, but it works.
- env <- GHC.getSession
- let srcspan = SrcLoc.noSrcSpan
- hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
- let res = Unsafe.Coerce.unsafeCoerce hval :: Int
- return $ Unsafe.Coerce.unsafeCoerce hval
-
--- These functions build (parts of) a LHSExpr RdrName.
-
--- | A reference to the Prelude.undefined function.
-hsUndef :: HsExpr.LHsExpr RdrName.RdrName
-hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
-
--- | A typed reference to the Prelude.undefined function.
-hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
-hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
-
--- | Create a qualified RdrName from a module name and a variable name
-mkRdrName :: String -> String -> RdrName.RdrName
-mkRdrName mod var =
- RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
-
--- These three functions are simplified copies of those in HscMain, because
--- those functions are not exported. These versions have all error handling
--- removed.
-hscParseType = hscParseThing Parser.parseType
-hscParseStmt = hscParseThing Parser.parseStmt
-
-hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
-hscParseThing parser dflags str = do
- buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
- let loc = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
- let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
- return thing
-
--- | This function imports the module with the given name, for the renamer /
--- typechecker to use. It also imports any "orphans" and "family instances"
--- from modules included by this module, but not the actual modules
--- themselves. I'm not 100% sure how this works, but it seems that any
--- functions defined in included modules are available just by loading the
--- original module, and by doing this orphan stuff, any (type family or class)
--- instances are available as well.
---
--- Most of the code is based on tcRnImports and rnImportDecl, but those
--- functions do a lot more (which I hope we won't need...).
-importModule :: Module.ModuleName -> TcRnTypes.RnM ()
-importModule mod = do
- let reason = Outputable.text "Hardcoded import" -- Used for trace output
- let pkg = Nothing
- -- Load the interface.
- iface <- LoadIface.loadSrcInterface reason mod False pkg
- -- Load orphan an familiy instance dependencies as well. I think these
- -- dependencies are needed for the type checker to know all instances. Any
- -- other instances (on other packages) are only useful to the
- -- linker, so we can probably safely ignore them here. Dependencies within
- -- the same package are also listed in deps, but I'm not so sure what to do
- -- with them.
- let deps = HscTypes.mi_deps iface
- let orphs = HscTypes.dep_orphs deps
- let finsts = HscTypes.dep_finsts deps
- LoadIface.loadOrphanModules orphs False
- LoadIface.loadOrphanModules finsts True
+++ /dev/null
-module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where
-
--- Standard imports
-import qualified Data.Map as Map
-import Text.PrettyPrint.HughesPJClass
-
--- GHC API
-import qualified CoreSyn
-import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
-
--- VHDL Imports
-import qualified Language.VHDL.Ppr as Ppr
-import qualified Language.VHDL.AST as AST
-import qualified Language.VHDL.AST.Ppr
-
--- Local imports
-import CLasH.VHDL.VHDLTypes
-import CLasH.Utils.Core.CoreShow
-
--- | A version of the default pPrintList method, which uses a custom function
--- f instead of pPrint to print elements.
-printList :: (a -> Doc) -> [a] -> Doc
-printList f = brackets . fsep . punctuate comma . map f
-
-{-
-instance Pretty FuncData where
- pPrint (FuncData flatfunc entity arch) =
- text "Flattened: " $$ nest 15 (ppffunc flatfunc)
- $+$ text "Entity" $$ nest 15 (ppent entity)
- $+$ pparch arch
- where
- ppffunc (Just f) = pPrint f
- ppffunc Nothing = text "Nothing"
- ppent (Just e) = pPrint e
- ppent Nothing = text "Nothing"
- pparch Nothing = text "VHDL architecture not present"
- pparch (Just _) = text "VHDL architecture present"
--}
-
-instance Pretty Entity where
- pPrint (Entity id args res decl) =
- text "Entity: " $$ nest 10 (pPrint id)
- $+$ text "Args: " $$ nest 10 (pPrint args)
- $+$ text "Result: " $$ nest 10 (pPrint res)
- $+$ text "Declaration not shown"
-
-instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
- pPrint (CoreSyn.NonRec b expr) =
- text "NonRec: " $$ nest 10 (prettyBind (b, expr))
- pPrint (CoreSyn.Rec binds) =
- text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
-
-instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
- pPrint = text . show
-
-instance Pretty AST.VHDLId where
- pPrint id = Ppr.ppr id
-
-instance Pretty AST.VHDLName where
- pPrint name = Ppr.ppr name
-
-prettyBind :: (Show b, Show e) => (b, e) -> Doc
-prettyBind (b, expr) =
- text b' <> text " = " <> text expr'
- where
- b' = show b
- expr' = show expr
-
-instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
- pPrint =
- vcat . map ppentry . Map.toList
- where
- ppentry (k, v) =
- pPrint k <> text " : " $$ nest 15 (pPrint v)
-
--- Convenience method for turning an Outputable into a string
-pprString :: (Outputable x) => x -> String
-pprString = showSDoc . ppr
-
-pprStringDebug :: (Outputable x) => x -> String
-pprStringDebug = showSDocDebug . ppr
+++ /dev/null
---
--- Functions to generate VHDL from FlatFunctions
---
-module CLasH.VHDL where
-
--- Standard modules
-import qualified Data.Map as Map
-import qualified Maybe
-import qualified Control.Arrow as Arrow
-import Data.Accessor
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import qualified CoreSyn
-
--- Local imports
-import CLasH.Translator.TranslatorTypes
-import CLasH.VHDL.VHDLTypes
-import CLasH.VHDL.VHDLTools
-import CLasH.VHDL.Constants
-import CLasH.VHDL.Generate
-
-createDesignFiles ::
- [CoreSyn.CoreBndr] -- ^ Top binders
- -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
-
-createDesignFiles topbndrs = do
- bndrss <- mapM recurseArchitectures topbndrs
- let bndrs = concat bndrss
- lunits <- mapM createLibraryUnit bndrs
- typepackage <- createTypesPackage
- let files = map (Arrow.second $ AST.DesignFile full_context) lunits
- return $ typepackage : files
- where
- full_context =
- mkUseAll ["work", "types"]
- : (mkUseAll ["work"]
- : ieee_context)
-
-ieee_context = [
- AST.Library $ mkVHDLBasicId "IEEE",
- mkUseAll ["IEEE", "std_logic_1164"],
- mkUseAll ["IEEE", "numeric_std"],
- mkUseAll ["std", "textio"]
- ]
-
--- | Find out which entities are needed for the given top level binders.
-recurseArchitectures ::
- CoreSyn.CoreBndr -- ^ The top level binder
- -> TranslatorSession [CoreSyn.CoreBndr]
- -- ^ The binders of all needed functions.
-recurseArchitectures bndr = do
- -- See what this binder directly uses
- (_, used) <- getArchitecture bndr
- -- Recursively check what each of the used functions uses
- useds <- mapM recurseArchitectures used
- -- And return all of them
- return $ bndr : (concat useds)
-
--- | Creates the types package, based on the current type state.
-createTypesPackage ::
- TranslatorSession (AST.VHDLId, AST.DesignFile)
- -- ^ The id and content of the types package
-
-createTypesPackage = do
- tyfuns <- MonadState.get (tsType .> tsTypeFuns)
- let tyfun_decls = mkBuiltInShow ++ map snd (Map.elems tyfuns)
- ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
- let ty_decls = Maybe.catMaybes ty_decls_maybes
- let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
- let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
- let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
- return (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
- where
- tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
- tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple highId) Nothing)
- tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
-
--- Create a use foo.bar.all statement. Takes a list of components in the used
--- name. Must contain at least two components
-mkUseAll :: [String] -> AST.ContextItem
-mkUseAll ss =
- AST.Use $ from AST.:.: AST.All
- where
- base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
- from = foldl select base_prefix (tail ss)
- select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
-
-createLibraryUnit ::
- CoreSyn.CoreBndr
- -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
-
-createLibraryUnit bndr = do
- entity <- getEntity bndr
- (arch, _) <- getArchitecture bndr
- return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])
+++ /dev/null
-module CLasH.VHDL.Constants where
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-
--- | A list of all builtin functions. Partly duplicates the name table
--- in VHDL.Generate, but we can't use that map everywhere due to
--- circular dependencie.
-builtinIds = [ exId, replaceId, headId, lastId, tailId, initId, takeId, dropId
- , selId, plusgtId, ltplusId, plusplusId, mapId, zipWithId, foldlId
- , foldrId, zipId, unzipId, shiftlId, shiftrId, rotlId, rotrId
- , concatId, reverseId, iteratenId, iterateId, generatenId, generateId
- , emptyId, singletonId, copynId, copyId, lengthTId, nullId
- , hwxorId, hwandId, hworId, hwnotId, equalityId, inEqualityId, ltId
- , lteqId, gtId, gteqId, boolOrId, boolAndId, plusId, timesId
- , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId
- , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId
- , splitId, minimumId, fromRangedWordId
- ]
---------------
--- Identifiers
---------------
-
--- | reset and clock signal identifiers in String form
-resetStr, clockStr :: String
-resetStr = "resetn"
-clockStr = "clock"
-
--- | reset and clock signal identifiers in basic AST.VHDLId form
-resetId, clockId :: AST.VHDLId
-resetId = AST.unsafeVHDLBasicId resetStr
-clockId = AST.unsafeVHDLBasicId clockStr
-
-integerId :: AST.VHDLId
-integerId = AST.unsafeVHDLBasicId "integer"
-
--- | \"types\" identifier
-typesId :: AST.VHDLId
-typesId = AST.unsafeVHDLBasicId "types"
-
--- | work identifier
-workId :: AST.VHDLId
-workId = AST.unsafeVHDLBasicId "work"
-
--- | std identifier
-stdId :: AST.VHDLId
-stdId = AST.unsafeVHDLBasicId "std"
-
-
--- | textio identifier
-textioId :: AST.VHDLId
-textioId = AST.unsafeVHDLBasicId "textio"
-
--- | range attribute identifier
-rangeId :: AST.VHDLId
-rangeId = AST.unsafeVHDLBasicId "range"
-
-
--- | high attribute identifier
-highId :: AST.VHDLId
-highId = AST.unsafeVHDLBasicId "high"
-
--- | range attribute identifier
-imageId :: AST.VHDLId
-imageId = AST.unsafeVHDLBasicId "image"
-
--- | event attribute identifie
-eventId :: AST.VHDLId
-eventId = AST.unsafeVHDLBasicId "event"
-
-
--- | default function identifier
-defaultId :: AST.VHDLId
-defaultId = AST.unsafeVHDLBasicId "default"
-
--- FSVec function identifiers
-
--- | ex (operator ! in original Haskell source) function identifier
-exId :: String
-exId = "!"
-
--- | sel (function select in original Haskell source) function identifier
-selId :: String
-selId = "select"
-
-
--- | ltplus (function (<+) in original Haskell source) function identifier
-ltplusId :: String
-ltplusId = "<+"
-
-
--- | plusplus (function (++) in original Haskell source) function identifier
-plusplusId :: String
-plusplusId = "++"
-
-
--- | empty function identifier
-emptyId :: String
-emptyId = "empty"
-
--- | plusgt (function (+>) in original Haskell source) function identifier
-plusgtId :: String
-plusgtId = "+>"
-
--- | singleton function identifier
-singletonId :: String
-singletonId = "singleton"
-
--- | length function identifier
-lengthId :: String
-lengthId = "length"
-
-
--- | isnull (function null in original Haskell source) function identifier
-nullId :: String
-nullId = "null"
-
-
--- | replace function identifier
-replaceId :: String
-replaceId = "replace"
-
-
--- | head function identifier
-headId :: String
-headId = "head"
-
-
--- | last function identifier
-lastId :: String
-lastId = "last"
-
-
--- | init function identifier
-initId :: String
-initId = "init"
-
-
--- | tail function identifier
-tailId :: String
-tailId = "tail"
-
--- | minimum ftp function identifier
-minimumId :: String
-minimumId = "minimum"
-
--- | take function identifier
-takeId :: String
-takeId = "take"
-
-
--- | drop function identifier
-dropId :: String
-dropId = "drop"
-
--- | shiftl function identifier
-shiftlId :: String
-shiftlId = "shiftl"
-
--- | shiftr function identifier
-shiftrId :: String
-shiftrId = "shiftr"
-
--- | rotl function identifier
-rotlId :: String
-rotlId = "rotl"
-
--- | reverse function identifier
-rotrId :: String
-rotrId = "rotr"
-
--- | concatenate the vectors in a vector
-concatId :: String
-concatId = "concat"
-
--- | reverse function identifier
-reverseId :: String
-reverseId = "reverse"
-
--- | iterate function identifier
-iterateId :: String
-iterateId = "iterate"
-
--- | iteraten function identifier
-iteratenId :: String
-iteratenId = "iteraten"
-
--- | iterate function identifier
-generateId :: String
-generateId = "generate"
-
--- | iteraten function identifier
-generatenId :: String
-generatenId = "generaten"
-
--- | copy function identifier
-copyId :: String
-copyId = "copy"
-
--- | copyn function identifier
-copynId :: String
-copynId = "copyn"
-
--- | map function identifier
-mapId :: String
-mapId = "map"
-
--- | zipwith function identifier
-zipWithId :: String
-zipWithId = "zipWith"
-
--- | foldl function identifier
-foldlId :: String
-foldlId = "foldl"
-
--- | foldr function identifier
-foldrId :: String
-foldrId = "foldr"
-
--- | zip function identifier
-zipId :: String
-zipId = "zip"
-
--- | unzip function identifier
-unzipId :: String
-unzipId = "unzip"
-
--- | hwxor function identifier
-hwxorId :: String
-hwxorId = "hwxor"
-
--- | hwor function identifier
-hworId :: String
-hworId = "hwor"
-
--- | hwnot function identifier
-hwnotId :: String
-hwnotId = "hwnot"
-
--- | hwand function identifier
-hwandId :: String
-hwandId = "hwand"
-
-lengthTId :: String
-lengthTId = "lengthT"
-
-fstId :: String
-fstId = "fst"
-
-sndId :: String
-sndId = "snd"
-
-splitId :: String
-splitId = "split"
-
--- Equality Operations
-equalityId :: String
-equalityId = "=="
-
-inEqualityId :: String
-inEqualityId = "/="
-
-gtId :: String
-gtId = ">"
-
-ltId :: String
-ltId = "<"
-
-gteqId :: String
-gteqId = ">="
-
-lteqId :: String
-lteqId = "<="
-
-boolOrId :: String
-boolOrId = "||"
-
-boolAndId :: String
-boolAndId = "&&"
-
-boolNot :: String
-boolNot = "not"
-
--- Numeric Operations
-
--- | plus operation identifier
-plusId :: String
-plusId = "+"
-
--- | times operation identifier
-timesId :: String
-timesId = "*"
-
--- | negate operation identifier
-negateId :: String
-negateId = "negate"
-
--- | minus operation identifier
-minusId :: String
-minusId = "-"
-
--- | convert sizedword to ranged
-fromSizedWordId :: String
-fromSizedWordId = "fromUnsigned"
-
-fromRangedWordId :: String
-fromRangedWordId = "fromIndex"
-
-toIntegerId :: String
-toIntegerId = "to_integer"
-
-fromIntegerId :: String
-fromIntegerId = "fromInteger"
-
-toSignedId :: String
-toSignedId = "to_signed"
-
-toUnsignedId :: String
-toUnsignedId = "to_unsigned"
-
-resizeId :: String
-resizeId = "resize"
-
-resizeWordId :: String
-resizeWordId = "resizeWord"
-
-resizeIntId :: String
-resizeIntId = "resizeInt"
-
-smallIntegerId :: String
-smallIntegerId = "smallInteger"
-
-sizedIntId :: String
-sizedIntId = "Signed"
-
-tfvecId :: String
-tfvecId = "Vector"
-
-blockRAMId :: String
-blockRAMId = "blockRAM"
-
--- | output file identifier (from std.textio)
-showIdString :: String
-showIdString = "show"
-
-showId :: AST.VHDLId
-showId = AST.unsafeVHDLExtId showIdString
-
--- | write function identifier (from std.textio)
-writeId :: AST.VHDLId
-writeId = AST.unsafeVHDLBasicId "write"
-
--- | output file identifier (from std.textio)
-outputId :: AST.VHDLId
-outputId = AST.unsafeVHDLBasicId "output"
-
-------------------
--- VHDL type marks
-------------------
-
--- | The Bit type mark
-bitTM :: AST.TypeMark
-bitTM = AST.unsafeVHDLBasicId "Bit"
-
--- | Stardard logic type mark
-std_logicTM :: AST.TypeMark
-std_logicTM = AST.unsafeVHDLBasicId "std_logic"
-
--- | boolean type mark
-booleanTM :: AST.TypeMark
-booleanTM = AST.unsafeVHDLBasicId "boolean"
-
--- | fsvec_index AST. TypeMark
-tfvec_indexTM :: AST.TypeMark
-tfvec_indexTM = AST.unsafeVHDLBasicId "tfvec_index"
-
--- | natural AST. TypeMark
-naturalTM :: AST.TypeMark
-naturalTM = AST.unsafeVHDLBasicId "natural"
-
--- | integer TypeMark
-integerTM :: AST.TypeMark
-integerTM = AST.unsafeVHDLBasicId "integer"
-
--- | signed TypeMark
-signedTM :: AST.TypeMark
-signedTM = AST.unsafeVHDLBasicId "signed"
-
--- | unsigned TypeMark
-unsignedTM :: AST.TypeMark
-unsignedTM = AST.unsafeVHDLBasicId "unsigned"
-
--- | string TypeMark
-stringTM :: AST.TypeMark
-stringTM = AST.unsafeVHDLBasicId "string"
-
--- | tup VHDLName suffix
-tupVHDLSuffix :: AST.VHDLId -> AST.Suffix
-tupVHDLSuffix id = AST.SSimple id
+++ /dev/null
-module CLasH.VHDL.Generate where
-
--- Standard modules
-import qualified Data.List as List
-import qualified Data.Map as Map
-import qualified Control.Monad as Monad
-import qualified Maybe
-import qualified Data.Either as Either
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import qualified CoreSyn
-import qualified Type
-import qualified Var
-import qualified Id
-import qualified IdInfo
-import qualified Literal
-import qualified Name
-import qualified TyCon
-
--- Local imports
-import CLasH.Translator.TranslatorTypes
-import CLasH.VHDL.Constants
-import CLasH.VHDL.VHDLTypes
-import CLasH.VHDL.VHDLTools
-import CLasH.Utils
-import CLasH.Utils.Core.CoreTools
-import CLasH.Utils.Pretty
-import qualified CLasH.Normalize as Normalize
-
------------------------------------------------------------------------------
--- Functions to generate VHDL for user-defined functions.
------------------------------------------------------------------------------
-
--- | Create an entity for a given function
-getEntity ::
- CoreSyn.CoreBndr
- -> TranslatorSession Entity -- ^ The resulting entity
-
-getEntity fname = makeCached fname tsEntities $ do
- expr <- Normalize.getNormalized False fname
- -- Split the normalized expression
- let (args, binds, res) = Normalize.splitNormalized expr
- -- Generate ports for all non-empty types
- args' <- catMaybesM $ mapM mkMap args
- -- TODO: Handle Nothing
- res' <- mkMap res
- count <- MonadState.get tsEntityCounter
- let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
- MonadState.set tsEntityCounter (count + 1)
- let ent_decl = createEntityAST vhdl_id args' res'
- let signature = Entity vhdl_id args' res' ent_decl
- return signature
- where
- mkMap ::
- --[(SignalId, SignalInfo)]
- CoreSyn.CoreBndr
- -> TranslatorSession (Maybe Port)
- mkMap = (\bndr ->
- let
- --info = Maybe.fromMaybe
- -- (error $ "Signal not found in the name map? This should not happen!")
- -- (lookup id sigmap)
- -- Assume the bndr has a valid VHDL id already
- id = varToVHDLId bndr
- ty = Var.varType bndr
- error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
- in do
- type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
- case type_mark_maybe of
- Just type_mark -> return $ Just (id, type_mark)
- Nothing -> return Nothing
- )
-
--- | Create the VHDL AST for an entity
-createEntityAST ::
- AST.VHDLId -- ^ The name of the function
- -> [Port] -- ^ The entity's arguments
- -> Maybe Port -- ^ The entity's result
- -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
-
-createEntityAST vhdl_id args res =
- AST.EntityDec vhdl_id ports
- where
- -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
- ports = map (mkIfaceSigDec AST.In) args
- ++ (Maybe.maybeToList res_port)
- ++ [clk_port,resetn_port]
- -- Add a clk port if we have state
- clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
- resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
- res_port = fmap (mkIfaceSigDec AST.Out) res
-
--- | Create a port declaration
-mkIfaceSigDec ::
- AST.Mode -- ^ The mode for the port (In / Out)
- -> Port -- ^ The id and type for the port
- -> AST.IfaceSigDec -- ^ The resulting port declaration
-
-mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
-
--- | Create an architecture for a given function
-getArchitecture ::
- CoreSyn.CoreBndr -- ^ The function to get an architecture for
- -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
- -- ^ The architecture for this function
-
-getArchitecture fname = makeCached fname tsArchitectures $ do
- expr <- Normalize.getNormalized False fname
- -- Split the normalized expression
- let (args, binds, res) = Normalize.splitNormalized expr
-
- -- Get the entity for this function
- signature <- getEntity fname
- let entity_id = ent_id signature
-
- -- Create signal declarations for all binders in the let expression, except
- -- for the output port (that will already have an output port declared in
- -- the entity).
- sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
- let sig_decs = Maybe.catMaybes sig_dec_maybes
- -- Process each bind, resulting in info about state variables and concurrent
- -- statements.
- (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
- let (in_state_maybes, out_state_maybes) = unzip state_vars
- let (statementss, used_entitiess) = unzip sms
- -- Get initial state, if it's there
- initSmap <- MonadState.get tsInitStates
- let init_state = Map.lookup fname initSmap
- -- Create a state proc, if needed
- (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
- ([in_state], [out_state], Nothing) -> do
- nonEmpty <- hasNonEmptyType in_state
- if nonEmpty
- then error ("No initial state defined for: " ++ show fname)
- else return ([],[])
- ([in_state], [out_state], Just resetval) -> do
- nonEmpty <- hasNonEmptyType in_state
- if nonEmpty
- then mkStateProcSm (in_state, out_state, resetval)
- else error ("Initial state defined for function with only substate: " ++ show fname)
- ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
- ([], [], Nothing) -> return ([],[])
- (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
- -- Join the create statements and the (optional) state_proc
- let statements = concat statementss ++ state_proc
- -- Create the architecture
- let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
- let used_entities = (concat used_entitiess) ++ resbndr
- return (arch, used_entities)
- where
- dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
- -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
- -- ^ ((Input state variable, output state variable), (statements, used entities))
- -- newtype unpacking is just a cast
- dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
- | hasStateType packed && not (hasStateType unpacked)
- = return ((Just bndr, Nothing), ([], []))
- -- With simplCore, newtype packing is just a cast
- dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
- | hasStateType packed && not (hasStateType unpacked)
- = return ((Nothing, Just state), ([], []))
- -- Without simplCore, newtype packing uses a data constructor
- dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
- | isStateCon con
- = return ((Nothing, Just state), ([], []))
- -- Anything else is handled by mkConcSm
- dobind bind = do
- sms <- mkConcSm bind
- return ((Nothing, Nothing), sms)
-
-mkStateProcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
- -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
-mkStateProcSm (old, new, res) = do
- let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
- type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
- let type_mark_old = Maybe.fromMaybe
- (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
- type_mark_old_maybe
- type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
- let type_mark_res' = Maybe.fromMaybe
- (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
- type_mark_res_maybe
- let type_mark_res = if type_mark_old == type_mark_res' then
- type_mark_res'
- else
- error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
- let resvalid = mkVHDLExtId $ varToString res ++ "val"
- let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
- let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
- let res_assign = AST.SigAssign (varToVHDLName old) reswform
- let blocklabel = mkVHDLBasicId "state"
- let statelabel = mkVHDLBasicId "stateupdate"
- let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
- let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
- let clk_assign = AST.SigAssign (varToVHDLName old) wform
- let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
- let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
- signature <- getEntity res
- let entity_id = ent_id signature
- let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
- let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
- let reset_statement = mkComponentInst reslabel entity_id portmaps
- let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
- let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
- let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
- let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
- return ([block],[res])
-
--- | Transforms a core binding into a VHDL concurrent statement
-mkConcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
- -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
- -- ^ The corresponding VHDL concurrent statements and entities
- -- instantiated.
-
-
--- Ignore Cast expressions, they should not longer have any meaning as long as
--- the type works out. Throw away state repacking
-mkConcSm (bndr, to@(CoreSyn.Cast from ty))
- | hasStateType to && hasStateType from
- = return ([],[])
-mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
-
--- Simple a = b assignments are just like applications, but without arguments.
--- We can't just generate an unconditional assignment here, since b might be a
--- top level binding (e.g., a function with no arguments).
-mkConcSm (bndr, CoreSyn.Var v) =
- genApplication (Left bndr) v []
-
-mkConcSm (bndr, app@(CoreSyn.App _ _))= do
- let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- let valargs = get_val_args (Var.varType f) args
- genApplication (Left bndr) f (map Left valargs)
-
--- A single alt case must be a selector. This means the scrutinee is a simple
--- variable, the alternative is a dataalt with a single non-wild binder that
--- is also returned.
-mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
- -- Don't generate VHDL for substate extraction
- | hasStateType bndr = return ([], [])
- | otherwise =
- case alt of
- (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
- nonemptysel <- hasNonEmptyType sel_bndr
- if nonemptysel
- then do
- bndrs' <- Monad.filterM hasNonEmptyType bndrs
- case List.elemIndex sel_bndr bndrs' of
- Just i -> do
- htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
- htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
- case htypeScrt == htypeBndr of
- True -> do
- let sel_name = varToVHDLName scrut
- let sel_expr = AST.PrimName sel_name
- return ([mkUncondAssign (Left bndr) sel_expr], [])
- otherwise ->
- case htypeScrt of
- Right (AggrType _ _) -> do
- labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
- let label = labels!!i
- let sel_name = mkSelectedName (varToVHDLName scrut) label
- let sel_expr = AST.PrimName sel_name
- return ([mkUncondAssign (Left bndr) sel_expr], [])
- _ -> do -- error $ "DIE!"
- let sel_name = varToVHDLName scrut
- let sel_expr = AST.PrimName sel_name
- return ([mkUncondAssign (Left bndr) sel_expr], [])
- Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
- else
- -- A selector case that selects a state value, ignore it.
- return ([], [])
-
- _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
--- Multiple case alt become conditional assignments and have only wild
--- binders in the alts and only variables in the case values and a variable
--- for a scrutinee. We check the constructor of the second alt, since the
--- first is the default case, if there is any.
-mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do
- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
- -- Omit first condition, which is the default
- altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
- let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
- -- Rotate expressions to the left, so that the expression related to the default case is the last
- exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
- return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
-
-mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
-mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-
------------------------------------------------------------------------------
--- Functions to generate VHDL for builtin functions
------------------------------------------------------------------------------
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be expressions.
-genExprArgs wrap dst func args = do
- args' <- argsToVHDLExprs args
- wrap dst func args'
-
--- | Turn the all lefts into VHDL Expressions.
-argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
-argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
-
-argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
-argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
- let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
- ty_maybe <- vhdlTy errmsg expr
- case ty_maybe of
- Just _ -> do
- vhdl_expr <- varToVHDLExpr $ exprToVar expr
- return $ Just vhdl_expr
- Nothing -> return Nothing
-
-argToVHDLExpr (Right expr) = return $ Just expr
-
--- A function to wrap a builder-like function that generates no component
--- instantiations
-genNoInsts ::
- (dst -> func -> args -> TranslatorSession [AST.ConcSm])
- -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
-genNoInsts wrap dst func args = do
- concsms <- wrap dst func args
- return (concsms, [])
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be variables.
-genVarArgs ::
- (dst -> func -> [Var.Var] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genVarArgs wrap = genCoreArgs $ \dst func args -> let
- args' = map exprToVar args
- in
- wrap dst func args'
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be core expressions.
-genCoreArgs ::
- (dst -> func -> [CoreSyn.CoreExpr] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genCoreArgs wrap dst func args = wrap dst func args'
- where
- -- Check (rather crudely) that all arguments are CoreExprs
- args' = case Either.partitionEithers args of
- (exprargs, []) -> exprargs
- (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
-
--- | A function to wrap a builder-like function that produces an expression
--- and expects it to be assigned to the destination.
-genExprRes ::
- ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
- -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
-genExprRes wrap dst func args = do
- expr <- wrap dst func args
- return [mkUncondAssign dst expr]
-
--- | Generate a binary operator application. The first argument should be a
--- constructor from the AST.Expr type, e.g. AST.And.
-genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
-genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
-
--- | Generate a unary operator application
-genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
-genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genOperator1' op _ f [arg] = return $ op arg
-
--- | Generate a unary operator application
-genNegation :: BuiltinBuilder
-genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
-genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
-genNegation' _ f [arg] = do
- arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
- let ty = Var.varType arg
- let (tycon, args) = Type.splitTyConApp ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "Signed" -> return $ AST.Neg arg1
- otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
-
--- | Generate a function call from the destination binder, function name and a
--- list of expressions (its arguments)
-genFCall :: Bool -> BuiltinBuilder
-genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
-genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genFCall' switch (Left res) f args = do
- let fname = varToString f
- let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
- id <- MonadState.lift tsType $ vectorFunId el_ty fname
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
-genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
-genFromSizedWord' (Left res) f args@[arg] =
- return [mkUncondAssign (Left res) arg]
- -- let fname = varToString f
- -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
- -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genFromRangedWord :: BuiltinBuilder
-genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
-genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genFromRangedWord' (Left res) f [arg] = do {
- ; let { ty = Var.varType res
- ; (tycon, args) = Type.splitTyConApp ty
- ; name = Name.getOccString (TyCon.tyConName tycon)
- } ;
- ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
- [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
- }
-genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genResize :: BuiltinBuilder
-genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
-genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genResize' (Left res) f [arg] = do {
- ; let { ty = Var.varType res
- ; (tycon, args) = Type.splitTyConApp ty
- ; name = Name.getOccString (TyCon.tyConName tycon)
- } ;
- ; len <- case name of
- "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
- "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
- [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
- }
-genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genTimes :: BuiltinBuilder
-genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
-genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genTimes' (Left res) f [arg1,arg2] = do {
- ; let { ty = Var.varType res
- ; (tycon, args) = Type.splitTyConApp ty
- ; name = Name.getOccString (TyCon.tyConName tycon)
- } ;
- ; len <- case name of
- "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
- "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
- "Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
- ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
- ; return bitsize
- }
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
- [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
- }
-genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
--- fromInteger turns an Integer into a Num instance. Since Integer is
--- not representable and is only allowed for literals, the actual
--- Integer should be inlined entirely into the fromInteger argument.
-genFromInteger :: BuiltinBuilder
-genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
-genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
-genFromInteger' (Left res) f args = do
- let ty = Var.varType res
- let (tycon, tyargs) = Type.splitTyConApp ty
- let name = Name.getOccString (TyCon.tyConName tycon)
- len <- case name of
- "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
- "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
- "Index" -> do
- bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
- return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
- let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
- case args of
- [integer] -> do -- The type and dictionary arguments are removed by genApplication
- literal <- getIntegerLiteral integer
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
- _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
-
-genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-
-genSizedInt :: BuiltinBuilder
-genSizedInt = genFromInteger
-
-{-
--- This function is useful for use with vectorTH, since that generates
--- explicit references to the TFVec constructor (which is normally
--- hidden). Below implementation is probably not current anymore, but
--- kept here in case we start using vectorTH again.
--- | Generate a Builder for the builtin datacon TFVec
-genTFVec :: BuiltinBuilder
-genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
- -- Generate Assignments for all the binders
- ; letAssigns <- mapM genBinderAssign letBinders
- -- Generate assignments for the result (which might be another let binding)
- ; (resBinders,resAssignments) <- genResAssign letRes
- -- Get all the Assigned binders
- ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
- -- Make signal names for all the assigned binders
- ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
- -- Assign all the signals to the resulting vector
- ; let { vecsigns = mkAggregateSignal sigs
- ; vecassign = mkUncondAssign (Left res) vecsigns
- } ;
- -- Generate all the signal declaration for the assigned binders
- ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
- ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
- -- Setup the VHDL Block
- ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
- ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
- } ;
- -- Return the block statement coressponding to the TFVec literal
- ; return $ [AST.CSBSm block]
- }
- where
- genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
- -- For now we only translate applications
- genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
- let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- let valargs = get_val_args (Var.varType f) args
- apps <- genApplication (Left bndr) f (map Left valargs)
- return (Just bndr, apps)
- genBinderAssign _ = return (Nothing,[])
- genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
- genResAssign app@(CoreSyn.App _ letexpr) = do
- case letexpr of
- (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
- letapps <- mapM genBinderAssign letbndrs
- let bndrs = Maybe.catMaybes (map fst letapps)
- let app = (map snd letapps)
- (vars, apps) <- genResAssign letres
- return ((bndrs ++ vars),((concat app) ++ apps))
- otherwise -> return ([],[])
- genResAssign _ = return ([],[])
-
-genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
- ; let { elems = reduceCoreListToHsList app
- -- Make signal names for all the binders
- ; binders = map (\expr -> case expr of
- (CoreSyn.Var b) -> b
- otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
- ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
- } ;
- ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
- -- Assign all the signals to the resulting vector
- ; let { vecsigns = mkAggregateSignal sigs
- ; vecassign = mkUncondAssign (Left res) vecsigns
- -- Setup the VHDL Block
- ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
- ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
- } ;
- -- Return the block statement coressponding to the TFVec literal
- ; return $ [AST.CSBSm block]
- }
-
-genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
-
-genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
--}
--- | Generate a generate statement for the builtin function "map"
-genMap :: BuiltinBuilder
-genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
- -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
- -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
- -- we must index it (which we couldn't if it was a VHDL Expr, since only
- -- VHDLNames can be indexed).
- -- Setup the generate scheme
- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the mapped_f to
- -- each of the elements in arg, storing to each element in res
- ; resname = mkIndexedName (varToVHDLName res) n_expr
- ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
- ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
- ; valargs = get_val_args (Var.varType real_f) already_mapped_args
- } ;
- ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
- -- Return the generate statement
- ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
- }
-
-genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
-
-genZipWith :: BuiltinBuilder
-genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do {
- -- Setup the generate scheme
- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the zipped_f to
- -- each of the elements in arg1 and arg2, storing to each element in res
- ; resname = mkIndexedName (varToVHDLName res) n_expr
- ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
- ; valargs = get_val_args (Var.varType real_f) already_mapped_args
- ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
- ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
- } ;
- ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2])
- -- Return the generate functions
- ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
- }
-
-genFoldl :: BuiltinBuilder
-genFoldl = genFold True
-
-genFoldr :: BuiltinBuilder
-genFoldr = genFold False
-
-genFold :: Bool -> BuiltinBuilder
-genFold left = genVarArgs (genFold' left)
-
-genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-genFold' left res f args@[folded_f , start ,vec]= do
- len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
- genFold'' len left res f args
-
-genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
--- Special case for an empty input vector, just assign start to res
-genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
- arg <- MonadState.lift tsType $ varToVHDLExpr start
- return ([mkUncondAssign (Left res) arg], [])
-
-genFold'' len left (Left res) f [folded_f, start, vec] = do
- -- The vector length
- --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
- -- An expression for len-1
- let len_min_expr = (AST.PrimLit $ show (len-1))
- -- evec is (TFVec n), so it still needs an element type
- let (nvec, _) = Type.splitAppTy (Var.varType vec)
- -- Put the type of the start value in nvec, this will be the type of our
- -- temporary vector
- let tmp_ty = Type.mkAppTy nvec (Var.varType start)
- let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- -- TODO: Handle Nothing
- Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
- -- Setup the generate scheme
- let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
- let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
- let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
- else AST.DownRange len_min_expr (AST.PrimLit "0")
- let gen_scheme = AST.ForGn n_id gen_range
- -- Make the intermediate vector
- let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
- -- Create the generate statement
- cells' <- sequence [genFirstCell, genOtherCell]
- let (cells, useds) = unzip cells'
- let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
- -- Assign tmp[len-1] or tmp[0] to res
- let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
- (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
- (mkIndexedName tmp_name (AST.PrimLit "0")))
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
- return ([AST.CSBSm block], concat useds)
- where
- -- An id for the counter
- n_id = mkVHDLBasicId "n"
- n_cur = idToVHDLExpr n_id
- -- An expression for previous n
- n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
- else (n_cur AST.:+: (AST.PrimLit "1"))
- -- An id for the tmp result vector
- tmp_id = mkVHDLBasicId "tmp"
- tmp_name = AST.NSimple tmp_id
- -- Generate parts of the fold
- genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
- genFirstCell = do
- len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
- let cond_label = mkVHDLExtId "firstcell"
- -- if n == 0 or n == len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
- else (AST.PrimLit $ show (len-1)))
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from start
- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
- -- Input from vec[current n]
- let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
- (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
- [Right argexpr1, Right argexpr2]
- else
- [Right argexpr2, Right argexpr1]
- )
- -- Return the conditional generate part
- return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-
- genOtherCell = do
- len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
- let cond_label = mkVHDLExtId "othercell"
- -- if n > 0 or n < len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
- else (AST.PrimLit $ show (len-1)))
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from tmp[previous n]
- let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
- -- Input from vec[current n]
- let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
- (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
- [Right argexpr1, Right argexpr2]
- else
- [Right argexpr2, Right argexpr1]
- )
- -- Return the conditional generate part
- return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-
--- | Generate a generate statement for the builtin function "zip"
-genZip :: BuiltinBuilder
-genZip = genNoInsts $ genVarArgs genZip'
-genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genZip' (Left res) f args@[arg1, arg2] = do {
- -- Setup the generate scheme
- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- ; resname' = mkIndexedName (varToVHDLName res) n_expr
- ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
- ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
- } ;
- ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
- ; let { resnameA = mkSelectedName resname' (labels!!0)
- ; resnameB = mkSelectedName resname' (labels!!1)
- ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
- ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
- } ;
- -- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
- }
-
--- | Generate a generate statement for the builtin function "fst"
-genFst :: BuiltinBuilder
-genFst = genNoInsts $ genVarArgs genFst'
-genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genFst' (Left res) f args@[arg] = do {
- ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
- ; let { argexpr' = varToVHDLName arg
- ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
- ; assign = mkUncondAssign (Left res) argexprA
- } ;
- -- Return the generate functions
- ; return [assign]
- }
-
--- | Generate a generate statement for the builtin function "snd"
-genSnd :: BuiltinBuilder
-genSnd = genNoInsts $ genVarArgs genSnd'
-genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genSnd' (Left res) f args@[arg] = do {
- ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
- ; let { argexpr' = varToVHDLName arg
- ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
- ; assign = mkUncondAssign (Left res) argexprB
- } ;
- -- Return the generate functions
- ; return [assign]
- }
-
--- | Generate a generate statement for the builtin function "unzip"
-genUnzip :: BuiltinBuilder
-genUnzip = genNoInsts $ genVarArgs genUnzip'
-genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genUnzip' (Left res) f args@[arg] = do
- let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
- htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
- -- Prepare a unconditional assignment, for the case when either part
- -- of the unzip is a state variable, which will disappear in the
- -- resulting VHDL, making the the unzip no longer required.
- case htype of
- -- A normal vector containing two-tuples
- VecType _ (AggrType _ [_, _]) -> do {
- -- Setup the generate scheme
- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- ; genScheme = AST.ForGn n_id range
- ; resname' = varToVHDLName res
- ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
- } ;
- ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
- ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
- ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
- ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
- ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
- ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
- ; resA_assign = mkUncondAssign (Right resnameA) argexprA
- ; resB_assign = mkUncondAssign (Right resnameB) argexprB
- } ;
- -- Return the generate functions
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
- }
- -- Both elements of the tuple were state, so they've disappeared. No
- -- need to do anything
- VecType _ (AggrType _ []) -> return []
- -- A vector containing aggregates with more than two elements?
- VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
- -- One of the elements of the tuple was state, so there won't be a
- -- tuple (record) in the VHDL output. We can just do a plain
- -- assignment, then.
- VecType _ _ -> do
- argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
- return [mkUncondAssign (Left res) argexpr]
- _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
-
-genCopy :: BuiltinBuilder
-genCopy = genNoInsts genCopy'
-genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]
-genCopy' (Left res) f [arg] = do {
- ; [arg'] <- argsToVHDLExprs [arg]
- ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
- ; out_assign = mkUncondAssign (Left res) resExpr
- }
- ; return [out_assign]
- }
-
-genConcat :: BuiltinBuilder
-genConcat = genNoInsts $ genVarArgs genConcat'
-genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genConcat' (Left res) f args@[arg] = do {
- -- Setup the generate scheme
- ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
- ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
- -- TODO: Use something better than varToString
- ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
- ; n_id = mkVHDLBasicId "n"
- ; n_expr = idToVHDLExpr n_id
- ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
- ; genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the mapped_f to
- -- each of the elements in arg, storing to each element in res
- ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
- ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
- ; resname = vecSlice fromRange toRange
- ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
- ; out_assign = mkUncondAssign (Right resname) argexpr
- } ;
- -- Return the generate statement
- ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
- }
- where
- vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
- (AST.ToRange init last))
-
-genIteraten :: BuiltinBuilder
-genIteraten dst f args = genIterate dst f (tail args)
-
-genIterate :: BuiltinBuilder
-genIterate = genIterateOrGenerate True
-
-genGeneraten :: BuiltinBuilder
-genGeneraten dst f args = genGenerate dst f (tail args)
-
-genGenerate :: BuiltinBuilder
-genGenerate = genIterateOrGenerate False
-
-genIterateOrGenerate :: Bool -> BuiltinBuilder
-genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
-
-genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
-genIterateOrGenerate' iter (Left res) f args = do
- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
- genIterateOrGenerate'' len iter (Left res) f args
-
-genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
--- Special case for an empty input vector, just assign start to res
-genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
-
-genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
- -- The vector length
- -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
- -- An expression for len-1
- let len_min_expr = (AST.PrimLit $ show (len-1))
- -- -- evec is (TFVec n), so it still needs an element type
- -- let (nvec, _) = splitAppTy (Var.varType vec)
- -- -- Put the type of the start value in nvec, this will be the type of our
- -- -- temporary vector
- let tmp_ty = Var.varType res
- let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- -- TODO: Handle Nothing
- Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
- -- Setup the generate scheme
- let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
- let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
- let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
- let gen_scheme = AST.ForGn n_id gen_range
- -- Make the intermediate vector
- let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
- -- Create the generate statement
- cells' <- sequence [genFirstCell, genOtherCell]
- let (cells, useds) = unzip cells'
- let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
- -- Assign tmp[len-1] or tmp[0] to res
- let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
- return ([AST.CSBSm block], concat useds)
- where
- -- An id for the counter
- n_id = mkVHDLBasicId "n"
- n_cur = idToVHDLExpr n_id
- -- An expression for previous n
- n_prev = n_cur AST.:-: (AST.PrimLit "1")
- -- An id for the tmp result vector
- tmp_id = mkVHDLBasicId "tmp"
- tmp_name = AST.NSimple tmp_id
- -- Generate parts of the fold
- genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
- genFirstCell = do
- let cond_label = mkVHDLExtId "firstcell"
- -- if n == 0 or n == len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from start
- argexpr <- MonadState.lift tsType $ varToVHDLExpr start
- let startassign = mkUncondAssign (Right resname) argexpr
- (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
- -- Return the conditional generate part
- let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
- [startassign]
- else
- app_concsms
- )
- return (gensm, used)
-
- genOtherCell = do
- let cond_label = mkVHDLExtId "othercell"
- -- if n > 0 or n < len-1
- let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
- -- Output to tmp[current n]
- let resname = mkIndexedName tmp_name n_cur
- -- Input from tmp[previous n]
- let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
- (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
- -- Return the conditional generate part
- return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
-
-genBlockRAM :: BuiltinBuilder
-genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
-
-genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
-genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
- -- Get the ram type
- let (tup,data_out) = Type.splitAppTy (Var.varType res)
- let (tup',ramvec) = Type.splitAppTy tup
- let Just realram = Type.coreView ramvec
- let Just (tycon, types) = Type.splitTyConApp_maybe realram
- Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
- -- Make the intermediate vector
- let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
- -- Get the data_out name
- -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
- let resname = varToVHDLName res
- -- let resname = mkSelectedName resname' (reslabels!!0)
- let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
- let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
- let assign = mkUncondAssign (Right resname) argexpr
- let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
- return [AST.CSBSm block]
- where
- ram_id = mkVHDLBasicId "ram"
- mkUpdateProcSm :: AST.ConcSm
- mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
- where
- proclabel = mkVHDLBasicId "updateRAM"
- rising_edge = mkVHDLBasicId "rising_edge"
- wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
- ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
- wform = AST.Wform [AST.WformElem data_in Nothing]
- ramassign = AST.SigAssign ramloc wform
- rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
- statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
-
-genSplit :: BuiltinBuilder
-genSplit = genNoInsts $ genVarArgs genSplit'
-
-genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
-genSplit' (Left res) f args@[vecIn] = do {
- ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
- ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
- ; halflen = round ((fromIntegral len) / 2)
- ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
- ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
- ; resname = varToVHDLName res
- ; resnameL = mkSelectedName resname (labels!!0)
- ; resnameR = mkSelectedName resname (labels!!1)
- ; argexprL = vhdlNameToVHDLExpr rangeL
- ; argexprR = vhdlNameToVHDLExpr rangeR
- ; out_assignL = mkUncondAssign (Right resnameL) argexprL
- ; out_assignR = mkUncondAssign (Right resnameR) argexprR
- ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
- }
- ; return [AST.CSBSm block]
- }
- where
- vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
- (AST.ToRange init last))
------------------------------------------------------------------------------
--- Function to generate VHDL for applications
------------------------------------------------------------------------------
-genApplication ::
- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
- -> CoreSyn.CoreBndr -- ^ The function to apply
- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
- -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
- -- ^ The corresponding VHDL concurrent statements and entities
- -- instantiated.
-genApplication dst f args = do
- nonemptydst <- case dst of
- Left bndr -> hasNonEmptyType bndr
- Right _ -> return True
- if nonemptydst
- then
- if Var.isGlobalId f then
- case Var.idDetails f of
- IdInfo.DataConWorkId dc -> case dst of
- -- It's a datacon. Create a record from its arguments.
- Left bndr -> do
- -- We have the bndr, so we can get at the type
- htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
- let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
- case argsNostate of
- [arg] -> do
- [arg'] <- argsToVHDLExprs [arg]
- return ([mkUncondAssign dst arg'], [])
- otherwise ->
- case htype of
- Right (AggrType _ _) -> do
- labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
- args' <- argsToVHDLExprs argsNostate
- return (zipWith mkassign labels args', [])
- where
- mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
- mkassign label arg =
- let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
- mkUncondAssign (Right sel_name) arg
- _ -> do -- error $ "DIE!"
- args' <- argsToVHDLExprs argsNostate
- return ([mkUncondAssign dst (head args')], [])
- Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
- IdInfo.DataConWrapId dc -> case dst of
- -- It's a datacon. Create a record from its arguments.
- Left bndr ->
- case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
- else
- error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
- Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
- IdInfo.VanillaId ->
- -- It's a global value imported from elsewhere. These can be builtin
- -- functions. Look up the function name in the name table and execute
- -- the associated builder if there is any and the argument count matches
- -- (this should always be the case if it typechecks, but just to be
- -- sure...).
- case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
- else
- error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> do
- top <- isTopLevelBinder f
- if top then
- do
- -- Local binder that references a top level binding. Generate a
- -- component instantiation.
- signature <- getEntity f
- args' <- argsToVHDLExprs args
- let entity_id = ent_id signature
- -- TODO: Using show here isn't really pretty, but we'll need some
- -- unique-ish value...
- let label = "comp_ins_" ++ (either show prettyShow) dst
- let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
- return ([mkComponentInst label entity_id portmaps], [f])
- else
- -- Not a top level binder, so this must be a local variable reference.
- -- It should have a representable type (and thus, no arguments) and a
- -- signal should be generated for it. Just generate an unconditional
- -- assignment here.
- -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
- -- f' <- MonadState.lift tsType $ varToVHDLExpr f
- -- return $ ([mkUncondAssign dst f'], [])
- do errtype <- case dst of
- Left bndr -> do
- htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
- return (show htype)
- Right vhd -> return $ show vhd
- error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
- IdInfo.ClassOpId cls ->
- -- FIXME: Not looking for what instance this class op is called for
- -- Is quite stupid of course.
- case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
- else
- error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
- details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
- else do
- top <- isTopLevelBinder f
- if top then
- do
- -- Local binder that references a top level binding. Generate a
- -- component instantiation.
- signature <- getEntity f
- args' <- argsToVHDLExprs args
- let entity_id = ent_id signature
- -- TODO: Using show here isn't really pretty, but we'll need some
- -- unique-ish value...
- let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
- let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
- return ([mkComponentInst label entity_id portmaps], [f])
- else
- -- Not a top level binder, so this must be a local variable reference.
- -- It should have a representable type (and thus, no arguments) and a
- -- signal should be generated for it. Just generate an unconditional
- -- assignment here.
- do f' <- MonadState.lift tsType $ varToVHDLExpr f
- return ([mkUncondAssign dst f'], [])
- else -- Destination has empty type, don't generate anything
- return ([], [])
------------------------------------------------------------------------------
--- Functions to generate functions dealing with vectors.
------------------------------------------------------------------------------
-
--- Returns the VHDLId of the vector function with the given name for the given
--- element type. Generates -- this function if needed.
-vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
-vectorFunId el_ty fname = do
- let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
- -- TODO: Handle the Nothing case?
- elemTM_maybe <- vhdlTy error_msg el_ty
- let elemTM = Maybe.fromMaybe
- (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
- elemTM_maybe
- -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
- -- the VHDLState or something.
- let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
- typefuns <- MonadState.get tsTypeFuns
- el_htype <- mkHType error_msg el_ty
- case Map.lookup (UVecType el_htype, fname) typefuns of
- -- Function already generated, just return it
- Just (id, _) -> return id
- -- Function not generated yet, generate it
- Nothing -> do
- let functions = genUnconsVectorFuns elemTM vectorTM
- case lookup fname functions of
- Just body -> do
- MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
- mapM_ (vectorFunId el_ty) (snd body)
- return function_id
- Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
- where
- function_id = mkVHDLExtId fname
-
-genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
- -> AST.TypeMark -- ^ type of the vector
- -> [(String, (AST.SubProgBody, [String]))]
-genUnconsVectorFuns elemTM vectorTM =
- [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
- , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
- , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
- , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
- , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
- , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
- , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
- , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
- , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
- , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
- , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
- , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
- , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
- , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
- , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
- , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
- , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
- , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
- , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
- , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
- , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
- ]
- where
- ixPar = AST.unsafeVHDLBasicId "ix"
- vecPar = AST.unsafeVHDLBasicId "vec"
- vec1Par = AST.unsafeVHDLBasicId "vec1"
- vec2Par = AST.unsafeVHDLBasicId "vec2"
- nPar = AST.unsafeVHDLBasicId "n"
- leftPar = AST.unsafeVHDLBasicId "nLeft"
- rightPar = AST.unsafeVHDLBasicId "nRight"
- iId = AST.unsafeVHDLBasicId "i"
- iPar = iId
- aPar = AST.unsafeVHDLBasicId "a"
- fPar = AST.unsafeVHDLBasicId "f"
- sPar = AST.unsafeVHDLBasicId "s"
- resId = AST.unsafeVHDLBasicId "res"
- exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec ixPar unsignedTM] elemTM
- exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
- (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
- replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
- , AST.IfaceVarDec iPar unsignedTM
- , AST.IfaceVarDec aPar elemTM
- ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- replaceVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
- replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
- replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
- replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- vecSlice init last = AST.PrimName (AST.NSlice
- (AST.SliceName
- (AST.NSimple vecPar)
- (AST.ToRange init last)))
- lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
- -- return vec(vec'length-1);
- lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
- (AST.NSimple vecPar)
- [AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"])))
- initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-2);
- initVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "2")) ]))
- Nothing
- -- resAST.:= vec(0 to vec'length-2)
- initExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "2"))
- initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
- AST.IfaceVarDec rightPar naturalTM ] naturalTM
- minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
- [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
- []
- (Just $ AST.Else [minimumExprRet])
- where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
- takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec vecPar vectorTM ] vectorTM
- -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
- minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
- ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
- takeVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (minLength AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res AST.:= vec(0 to n-1)
- takeExpr = AST.NSimple resId AST.:=
- (vecSlice (AST.PrimLit "0")
- (minLength AST.:-: AST.PrimLit "1"))
- takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec vecPar vectorTM ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-n-1);
- dropVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
- Nothing
- -- res AST.:= vec(n to vec'length-1)
- dropExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimName $ AST.NSimple nPar)
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"))
- dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
- AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length);
- plusgtVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
- Nothing
- plusgtExpr = AST.NSimple resId AST.:=
- ((AST.PrimName $ AST.NSimple aPar) AST.:&:
- (AST.PrimName $ AST.NSimple vecPar))
- plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
- emptyVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
- Nothing
- emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
- singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
- vectorTM
- -- variable res : fsvec_x (0 to 0) := (others => a);
- singletonVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
- (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName $ AST.NSimple aPar)])
- singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec aPar elemTM ] vectorTM
- -- variable res : fsvec_x (0 to n-1) := (others => a);
- copynVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- ((AST.PrimName (AST.NSimple nPar)) AST.:-:
- (AST.PrimLit "1")) ]))
- (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
- (AST.PrimName $ AST.NSimple aPar)])
- -- return res
- copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
- AST.IfaceVarDec sPar naturalTM,
- AST.IfaceVarDec nPar naturalTM,
- AST.IfaceVarDec vecPar vectorTM ] vectorTM
- -- variable res : fsvec_x (0 to n-1);
- selVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- ((AST.PrimName (AST.NSimple nPar)) AST.:-:
- (AST.PrimLit "1")) ])
- )
- Nothing
- -- for i res'range loop
- -- res(i) := vec(f+i*s);
- -- end loop;
- selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
- -- res(i) := vec(f+i*s);
- selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
- (AST.PrimName (AST.NSimple iId) AST.:*:
- AST.PrimName (AST.NSimple sPar)) in
- AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
- (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
- -- return res;
- selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
- ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec aPar elemTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length);
- ltplusVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
- Nothing
- ltplusExpr = AST.NSimple resId AST.:=
- ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
- (AST.PrimName $ AST.NSimple aPar))
- ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
- AST.IfaceVarDec vec2Par vectorTM]
- vectorTM
- -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
- plusplusVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
- AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- AST.PrimLit "1")]))
- Nothing
- plusplusExpr = AST.NSimple resId AST.:=
- ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
- (AST.PrimName $ AST.NSimple vec2Par))
- plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
- lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
- shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec aPar elemTM ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- shiftlVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res := a & init(vec)
- shiftlExpr = AST.NSimple resId AST.:=
- (AST.PrimName (AST.NSimple aPar) AST.:&:
- (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
- shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec aPar elemTM ] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- shiftrVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- res := tail(vec) & a
- shiftrExpr = AST.NSimple resId AST.:=
- ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
- (AST.PrimName (AST.NSimple aPar)))
-
- shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
- -- return vec'length = 0
- nullExpr = AST.ReturnSm (Just $
- AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
- AST.PrimLit "0")
- rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- rotlVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- if null(vec) then res := vec else res := last(vec) & init(vec)
- rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
- [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
- []
- (Just $ AST.Else [rotlExprRet])
- where rotlExprRet =
- AST.NSimple resId AST.:=
- ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
- (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
- rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-1);
- rotrVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- if null(vec) then res := vec else res := tail(vec) & head(vec)
- rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
- [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
- []
- (Just $ AST.Else [rotrExprRet])
- where rotrExprRet =
- AST.NSimple resId AST.:=
- ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
- (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
- rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- reverseVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "1")) ]))
- Nothing
- -- for i in 0 to res'range loop
- -- res(vec'length-i-1) := vec(i);
- -- end loop;
- reverseFor =
- AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
- -- res(vec'length-i-1) := vec(i);
- reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
- (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
- [AST.PrimName $ AST.NSimple iId]))
- where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
- (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- AST.PrimName (AST.NSimple iId) AST.:-:
- (AST.PrimLit "1")
- -- return res;
- reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
-
-
------------------------------------------------------------------------------
--- A table of builtin functions
------------------------------------------------------------------------------
-
--- A function that generates VHDL for a builtin function
-type BuiltinBuilder =
- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
- -> CoreSyn.CoreBndr -- ^ The function called
- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
- -- dictionary arguments).
- -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
- -- ^ The corresponding VHDL concurrent statements and entities
- -- instantiated.
-
--- A map of a builtin function to VHDL function builder
-type NameTable = Map.Map String (Int, BuiltinBuilder )
-
--- | The builtin functions we support. Maps a name to an argument count and a
--- builder function. If you add a name to this map, don't forget to add
--- it to VHDL.Constants/builtinIds as well.
-globalNameTable :: NameTable
-globalNameTable = Map.fromList
- [ (exId , (2, genFCall True ) )
- , (replaceId , (3, genFCall False ) )
- , (headId , (1, genFCall True ) )
- , (lastId , (1, genFCall True ) )
- , (tailId , (1, genFCall False ) )
- , (initId , (1, genFCall False ) )
- , (takeId , (2, genFCall False ) )
- , (dropId , (2, genFCall False ) )
- , (selId , (4, genFCall False ) )
- , (plusgtId , (2, genFCall False ) )
- , (ltplusId , (2, genFCall False ) )
- , (plusplusId , (2, genFCall False ) )
- , (mapId , (2, genMap ) )
- , (zipWithId , (3, genZipWith ) )
- , (foldlId , (3, genFoldl ) )
- , (foldrId , (3, genFoldr ) )
- , (zipId , (2, genZip ) )
- , (unzipId , (1, genUnzip ) )
- , (shiftlId , (2, genFCall False ) )
- , (shiftrId , (2, genFCall False ) )
- , (rotlId , (1, genFCall False ) )
- , (rotrId , (1, genFCall False ) )
- , (concatId , (1, genConcat ) )
- , (reverseId , (1, genFCall False ) )
- , (iteratenId , (3, genIteraten ) )
- , (iterateId , (2, genIterate ) )
- , (generatenId , (3, genGeneraten ) )
- , (generateId , (2, genGenerate ) )
- , (emptyId , (0, genFCall False ) )
- , (singletonId , (1, genFCall False ) )
- , (copynId , (2, genFCall False ) )
- , (copyId , (1, genCopy ) )
- , (lengthTId , (1, genFCall False ) )
- , (nullId , (1, genFCall False ) )
- , (hwxorId , (2, genOperator2 AST.Xor ) )
- , (hwandId , (2, genOperator2 AST.And ) )
- , (hworId , (2, genOperator2 AST.Or ) )
- , (hwnotId , (1, genOperator1 AST.Not ) )
- , (equalityId , (2, genOperator2 (AST.:=:) ) )
- , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
- , (ltId , (2, genOperator2 (AST.:<:) ) )
- , (lteqId , (2, genOperator2 (AST.:<=:) ) )
- , (gtId , (2, genOperator2 (AST.:>:) ) )
- , (gteqId , (2, genOperator2 (AST.:>=:) ) )
- , (boolOrId , (2, genOperator2 AST.Or ) )
- , (boolAndId , (2, genOperator2 AST.And ) )
- , (boolNot , (1, genOperator1 AST.Not ) )
- , (plusId , (2, genOperator2 (AST.:+:) ) )
- , (timesId , (2, genTimes ) )
- , (negateId , (1, genNegation ) )
- , (minusId , (2, genOperator2 (AST.:-:) ) )
- , (fromSizedWordId , (1, genFromSizedWord ) )
- , (fromRangedWordId , (1, genFromRangedWord ) )
- , (fromIntegerId , (1, genFromInteger ) )
- , (resizeWordId , (1, genResize ) )
- , (resizeIntId , (1, genResize ) )
- , (sizedIntId , (1, genSizedInt ) )
- , (smallIntegerId , (1, genFromInteger ) )
- , (fstId , (1, genFst ) )
- , (sndId , (1, genSnd ) )
- , (blockRAMId , (5, genBlockRAM ) )
- , (splitId , (1, genSplit ) )
- --, (tfvecId , (1, genTFVec ) )
- , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
- ]
+++ /dev/null
---
--- Functions to create a VHDL testbench from a list of test input.
---
-module CLasH.VHDL.Testbench where
-
--- Standard modules
-import qualified Control.Monad as Monad
-import qualified Maybe
-import qualified Data.Map as Map
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import qualified CoreSyn
-import qualified HscTypes
-import qualified Var
-import qualified TysWiredIn
-
--- Local imports
-import CLasH.Translator.TranslatorTypes
-import CLasH.VHDL.Constants
-import CLasH.VHDL.Generate
-import CLasH.VHDL.VHDLTools
-import CLasH.VHDL.VHDLTypes
-import CLasH.Normalize
-import CLasH.Utils.Core.BinderTools
-import CLasH.Utils.Core.CoreTools
-import CLasH.Utils
-
-createTestbench ::
- Maybe Int -- ^ Number of cycles to simulate
- -> [HscTypes.CoreModule] -- ^ Compiled modules
- -> CoreSyn.CoreExpr -- ^ Input stimuli
- -> CoreSyn.CoreBndr -- ^ Top Entity
- -> TranslatorSession CoreSyn.CoreBndr -- ^ The id of the generated archictecture
-createTestbench mCycles cores stimuli top = do
- stimuli' <- reduceCoreListToHsList cores stimuli
- -- Create a binder for the testbench. We use the unit type (), since the
- -- testbench has no outputs and no inputs.
- bndr <- mkInternalVar "testbench" TysWiredIn.unitTy
- let entity = createTestbenchEntity bndr
- MonadState.modify tsEntities (Map.insert bndr entity)
- arch <- createTestbenchArch mCycles stimuli' top entity
- MonadState.modify tsArchitectures (Map.insert bndr arch)
- return bndr
-
-createTestbenchEntity ::
- CoreSyn.CoreBndr
- -> Entity
-createTestbenchEntity bndr = entity
- where
- vhdl_id = mkVHDLBasicId "testbench"
- -- Create an AST entity declaration with no ports
- ent_decl = AST.EntityDec vhdl_id []
- -- Create a signature with no input and no output ports
- entity = Entity vhdl_id [] undefined ent_decl
-
-createTestbenchArch ::
- Maybe Int -- ^ Number of cycles to simulate
- -> [CoreSyn.CoreExpr] -- ^ Imput stimuli
- -> CoreSyn.CoreBndr -- ^ Top Entity
- -> Entity -- ^ The signature to create an architecture for
- -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
- -- ^ The architecture and any other entities used.
-createTestbenchArch mCycles stimuli top testent= do
- signature <- getEntity top
- let entId = ent_id signature
- iIface = ent_args signature
- oIface = ent_res signature
- iIds = map fst iIface
- let (oId, oDec, oProc) = case oIface of
- Just (id, ty) -> ( id
- , [AST.SigDec id ty Nothing]
- , [createOutputProc [id]])
- -- No output port? Just use undefined for the output id, since it won't be
- -- used by mkAssocElems when there is no output port.
- Nothing -> (undefined, [], [])
- let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
- let finalIDecs = iDecs ++
- [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
- AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
- let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature
- let mIns = mkComponentInst "totest" entId portmaps
- (stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds)
- let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
- AST.ConWforms []
- (AST.Wform [AST.WformElem (AST.PrimLit "'0'") (Just $ AST.PrimLit "0 ns"), AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
- Nothing)) : stimuliAssigns
- let clkProc = createClkProc
- let arch = AST.ArchBody
- (AST.unsafeVHDLBasicId "test")
- (AST.NSimple $ ent_id testent)
- (map AST.BDISD (finalIDecs ++ stimuliDecs ++ oDec))
- (mIns :
- ( (AST.CSPSm clkProc) : (fmap AST.CSPSm oProc) ++ finalAssigns ) )
- return (arch, top : used)
-
-createStimuliAssigns ::
- Maybe Int -- ^ Number of cycles to simulate
- -> [CoreSyn.CoreExpr] -- ^ Input stimuli
- -> AST.VHDLId -- ^ Input signal
- -> TranslatorSession ( [AST.ConcSm]
- , [AST.SigDec]
- , Int
- , [CoreSyn.CoreBndr]) -- ^ (Resulting statements, Needed signals, The number of cycles to simulate, Any entities used)
-createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles, [])
-
-createStimuliAssigns mCycles stimuli signal = do
- let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
- let inputlen = length stimuli
- assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
- let (stimuli_sms, resvars, useds) = unzip3 assigns
- sig_dec_maybes <- mapM mkSigDec resvars
- let sig_decs = Maybe.catMaybes sig_dec_maybes
- outps <- mapM (\x -> MonadState.lift tsType (varToVHDLExpr x)) resvars
- let wformelems = zipWith genWformElem [0,10..] outps
- let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
- case (concat stimuli_sms) of
- [] -> return ([inassign], [], inputlen, concat useds)
- stims -> return (stims ++ [inassign], sig_decs, inputlen, concat useds)
-
-createStimulans ::
- CoreSyn.CoreExpr -- ^ The stimulans
- -> Int -- ^ The cycle for this stimulans
- -> TranslatorSession ( [AST.ConcSm]
- , Var.Var
- , [CoreSyn.CoreBndr]) -- ^ (The statement, the variable it assigns to (assumed to be available!), Any entities used by this stimulans)
-
-createStimulans expr cycl = do
- -- There must be a let at top level
- expr <- normalizeExpr ("test input #" ++ show cycl) expr
- -- Split the normalized expression. It can't have a function type, so match
- -- an empty list of argument binders
- let ([], binds, res) = splitNormalized expr
- (stimulansbindss, useds) <- unzipM $ Monad.mapM mkConcSm binds
- sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
- let sig_decs = map (AST.BDISD) (Maybe.catMaybes sig_dec_maybes)
- let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
- let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbindss)
- case (sig_decs,(concat stimulansbindss)) of
- ([],[]) -> return ([], res, concat useds)
- otherwise -> return ([AST.CSBSm block], res, concat useds)
-
--- | generates a clock process with a period of 10ns
-createClkProc :: AST.ProcSm
-createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
- where sms = -- wait for 5 ns -- (half a cycle)
- [AST.WaitFor $ AST.PrimLit "5 ns",
- -- clk <= not clk;
- AST.NSimple clockId `AST.SigAssign`
- AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
-
--- | generate the output process
-createOutputProc :: [AST.VHDLId] -- ^ output signal
- -> AST.ProcSm
-createOutputProc outs =
- AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
- [clockId]
- [AST.IfSm clkPred (writeOuts outs) [] Nothing]
- where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
- (AST.NSimple eventId)
- Nothing ) `AST.And`
- (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
- writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
- writeOuts [] = []
- writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
- writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
- writeOut outSig suffix =
- genExprPCall2 writeId
- (AST.PrimName $ AST.NSimple outputId)
- ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)
+++ /dev/null
-{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
-module CLasH.VHDL.VHDLTools where
-
--- Standard modules
-import qualified Maybe
-import qualified Data.Either as Either
-import qualified Data.List as List
-import qualified Data.Char as Char
-import qualified Data.Map as Map
-import qualified Control.Monad as Monad
-import qualified Data.Accessor.Monad.Trans.State as MonadState
-
--- VHDL Imports
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import qualified CoreSyn
-import qualified Name
-import qualified OccName
-import qualified Var
-import qualified Id
-import qualified TyCon
-import qualified Type
-import qualified DataCon
-import qualified CoreSubst
-import qualified Outputable
-
--- Local imports
-import CLasH.VHDL.VHDLTypes
-import CLasH.Translator.TranslatorTypes
-import CLasH.Utils.Core.CoreTools
-import CLasH.Utils
-import CLasH.Utils.Pretty
-import CLasH.VHDL.Constants
-
------------------------------------------------------------------------------
--- Functions to generate concurrent statements
------------------------------------------------------------------------------
-
--- Create an unconditional assignment statement
-mkUncondAssign ::
- Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> AST.Expr -- ^ The expression to assign
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkUncondAssign dst expr = mkAssign dst Nothing expr
-
--- Create a conditional assignment statement
-mkCondAssign ::
- Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> AST.Expr -- ^ The condition
- -> AST.Expr -- ^ The value when true
- -> AST.Expr -- ^ The value when false
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
-
--- Create a conditional or unconditional assignment statement
-mkAssign ::
- Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
- -- and the value to assign when true.
- -> AST.Expr -- ^ The value to assign when false or no condition
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkAssign dst cond false_expr =
- let
- -- I'm not 100% how this assignment AST works, but this gets us what we
- -- want...
- whenelse = case cond of
- Just (cond_expr, true_expr) ->
- let
- true_wform = AST.Wform [AST.WformElem true_expr Nothing]
- in
- [AST.WhenElse true_wform cond_expr]
- Nothing -> []
- false_wform = AST.Wform [AST.WformElem false_expr Nothing]
- dst_name = case dst of
- Left bndr -> AST.NSimple (varToVHDLId bndr)
- Right name -> name
- assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
- in
- AST.CSSASm assign
-
-mkAltsAssign ::
- Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> [AST.Expr] -- ^ The conditions
- -> [AST.Expr] -- ^ The expressions
- -> AST.ConcSm -- ^ The Alt assigns
-mkAltsAssign dst conds exprs
- | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
- | otherwise =
- let
- whenelses = zipWith mkWhenElse conds exprs
- false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
- dst_name = case dst of
- Left bndr -> AST.NSimple (varToVHDLId bndr)
- Right name -> name
- assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
- in
- AST.CSSASm assign
- where
- mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
- mkWhenElse cond true_expr =
- let
- true_wform = AST.Wform [AST.WformElem true_expr Nothing]
- in
- AST.WhenElse true_wform cond
-
-mkAssocElems ::
- [AST.Expr] -- ^ The argument that are applied to function
- -> AST.VHDLName -- ^ The binder in which to store the result
- -> Entity -- ^ The entity to map against.
- -> [AST.AssocElem] -- ^ The resulting port maps
-mkAssocElems args res entity =
- arg_maps ++ (Maybe.maybeToList res_map_maybe)
- where
- arg_ports = ent_args entity
- res_port_maybe = ent_res entity
- -- Create an expression of res to map against the output port
- res_expr = vhdlNameToVHDLExpr res
- -- Map each of the input ports
- arg_maps = zipWith mkAssocElem (map fst arg_ports) args
- -- Map the output port, if present
- res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
-
--- | Create an VHDL port -> signal association
-mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
-mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
-
--- | Create an aggregate signal
-mkAggregateSignal :: [AST.Expr] -> AST.Expr
-mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
-
-mkComponentInst ::
- String -- ^ The portmap label
- -> AST.VHDLId -- ^ The entity name
- -> [AST.AssocElem] -- ^ The port assignments
- -> AST.ConcSm
-mkComponentInst label entity_id portassigns = AST.CSISm compins
- where
- -- We always have a clock port, so no need to map it anywhere but here
- clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
- resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
- compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
-
------------------------------------------------------------------------------
--- Functions to generate VHDL Exprs
------------------------------------------------------------------------------
-
-varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
-varToVHDLExpr var =
- case Id.isDataConWorkId_maybe var of
- -- This is a dataconstructor.
- Just dc -> dataconToVHDLExpr dc
- -- Not a datacon, just another signal.
- Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
-
--- Turn a VHDLName into an AST expression
-vhdlNameToVHDLExpr = AST.PrimName
-
--- Turn a VHDL Id into an AST expression
-idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
-
--- Turn a Core expression into an AST expression
-exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
-
--- Turn a alternative constructor into an AST expression. For
--- dataconstructors, this is only the constructor itself, not any arguments it
--- has. Should not be called with a DEFAULT constructor.
-altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
-altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
-
-altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
-altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
-
--- Turn a datacon (without arguments!) into a VHDL expression.
-dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
-dataconToVHDLExpr dc = do
- typemap <- MonadState.get tsTypes
- htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
- case htype_either of
- -- No errors
- Right htype -> do
- let dcname = DataCon.dataConName dc
- case htype of
- (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
- (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
- otherwise -> do
- let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
- case existing_ty of
- Just ty -> do
- let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
- return lit
- Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
- -- Error when constructing htype
- Left err -> error err
-
------------------------------------------------------------------------------
--- Functions dealing with names, variables and ids
------------------------------------------------------------------------------
-
--- Creates a VHDL Id from a binder
-varToVHDLId ::
- CoreSyn.CoreBndr
- -> AST.VHDLId
-varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
- where
- lowers :: String -> Int
- lowers xs = length [x | x <- xs, Char.isLower x]
-
--- Creates a VHDL Name from a binder
-varToVHDLName ::
- CoreSyn.CoreBndr
- -> AST.VHDLName
-varToVHDLName = AST.NSimple . varToVHDLId
-
--- Extracts the binder name as a String
-varToString ::
- CoreSyn.CoreBndr
- -> String
-varToString = OccName.occNameString . Name.nameOccName . Var.varName
-
--- Get the string version a Var's unique
-varToStringUniq :: Var.Var -> String
-varToStringUniq = show . Var.varUnique
-
--- Extracts the string version of the name
-nameToString :: Name.Name -> String
-nameToString = OccName.occNameString . Name.nameOccName
-
--- Shortcut for Basic VHDL Ids.
--- Can only contain alphanumerics and underscores. The supplied string must be
--- a valid basic id, otherwise an error value is returned. This function is
--- not meant to be passed identifiers from a source file, use mkVHDLExtId for
--- that.
-mkVHDLBasicId :: String -> AST.VHDLId
-mkVHDLBasicId s =
- AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
- where
- -- Strip invalid characters.
- strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
- -- Strip leading numbers and underscores
- strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
- -- Strip multiple adjacent underscores
- strip_multiscore = concatMap (\cs ->
- case cs of
- ('_':_) -> "_"
- _ -> cs
- ) . List.group
-
--- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
--- different characters than basic ids, but can never be used to refer to
--- basic ids.
--- Use extended Ids for any values that are taken from the source file.
-mkVHDLExtId :: String -> AST.VHDLId
-mkVHDLExtId s =
- AST.unsafeVHDLExtId $ strip_invalid s
- where
- -- Allowed characters, taken from ForSyde's mkVHDLExtId
- allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
- strip_invalid = filter (`elem` allowed)
-
--- Create a record field selector that selects the given label from the record
--- stored in the given binder.
-mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
-mkSelectedName name label =
- AST.NSelected $ name AST.:.: (AST.SSimple label)
-
--- Create an indexed name that selects a given element from a vector.
-mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
--- Special case for already indexed names. Just add an index
-mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
- AST.NIndexed (AST.IndexedName name (indexes++[index]))
--- General case for other names
-mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
-
------------------------------------------------------------------------------
--- Functions dealing with VHDL types
------------------------------------------------------------------------------
-builtin_types :: TypeMap
-builtin_types =
- Map.fromList [
- (BuiltinType "Bit", Just (std_logicTM, Nothing)),
- (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
- ]
-
--- Is the given type representable at runtime?
-isReprType :: Type.Type -> TypeSession Bool
-isReprType ty = do
- ty_either <- mkHTypeEither ty
- return $ case ty_either of
- Left _ -> False
- Right _ -> True
-
--- | Turn a Core type into a HType, returning an error using the given
--- error string if the type was not representable.
-mkHType :: (TypedThing t, Outputable.Outputable t) =>
- String -> t -> TypeSession HType
-mkHType msg ty = do
- htype_either <- mkHTypeEither ty
- case htype_either of
- Right htype -> return htype
- Left err -> error $ msg ++ err
-
--- | Turn a Core type into a HType. Returns either an error message if
--- the type was not representable, or the HType generated.
-mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
- t -> TypeSession (Either String HType)
-mkHTypeEither tything =
- case getType tything of
- Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
- Just ty -> mkHTypeEither' ty
-
-mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
-mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
- | isStateType ty = return $ Right StateType
- | otherwise =
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> do
- typemap <- MonadState.get tsTypes
- let name = Name.getOccString (TyCon.tyConName tycon)
- let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
- case builtinTyMaybe of
- (Just x) -> return $ Right $ BuiltinType name
- Nothing ->
- case name of
- "Vector" -> do
- let el_ty = tfvec_elem ty
- elem_htype_either <- mkHTypeEither el_ty
- case elem_htype_either of
- -- Could create element type
- Right elem_htype -> do
- len <- tfp_to_int (tfvec_len_ty ty)
- return $ Right $ VecType len elem_htype
- -- Could not create element type
- Left err -> return $ Left $
- "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
- "Unsigned" -> do
- len <- tfp_to_int (sized_word_len_ty ty)
- return $ Right $ SizedWType len
- "Signed" -> do
- len <- tfp_to_int (sized_word_len_ty ty)
- return $ Right $ SizedIType len
- "Index" -> do
- bound <- tfp_to_int (ranged_word_bound_ty ty)
- return $ Right $ RangedWType bound
- otherwise ->
- mkTyConHType tycon args
- Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
-
-mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
-mkTyConHType tycon args =
- case TyCon.tyConDataCons tycon of
- -- Not an algebraic type
- [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
- [dc] -> do
- let arg_tys = DataCon.dataConRepArgTys dc
- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
- let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
- elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
- case Either.partitionEithers elem_htys_either of
- ([], [elem_hty]) ->
- return $ Right elem_hty
- -- No errors in element types
- ([], elem_htys) ->
- return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
- -- There were errors in element types
- (errors, _) -> return $ Left $
- "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
- ++ (concat errors)
- dcs -> do
- let arg_tys = concatMap DataCon.dataConRepArgTys dcs
- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
- case real_arg_tys of
- [] ->
- return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
- xs -> return $ Left $
- "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
- where
- tyvars = TyCon.tyConTyVars tycon
- subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
-
--- Translate a Haskell type to a VHDL type, generating a new type if needed.
--- Returns an error value, using the given message, when no type could be
--- created. Returns Nothing when the type is valid, but empty.
-vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
- String -> t -> TypeSession (Maybe AST.TypeMark)
-vhdlTy msg ty = do
- htype <- mkHType msg ty
- vhdlTyMaybe htype
-
-vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
-vhdlTyMaybe htype = do
- typemap <- MonadState.get tsTypes
- -- If not a builtin type, try the custom types
- let existing_ty = Map.lookup htype typemap
- case existing_ty of
- -- Found a type, return it
- Just (Just (t, _)) -> return $ Just t
- Just (Nothing) -> return Nothing
- -- No type yet, try to construct it
- Nothing -> do
- newty <- (construct_vhdl_ty htype)
- MonadState.modify tsTypes (Map.insert htype newty)
- case newty of
- Just (ty_id, ty_def) -> do
- MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
- return $ Just ty_id
- Nothing -> return Nothing
-
--- Construct a new VHDL type for the given Haskell type. Returns an error
--- message or the resulting typemark and typedef.
-construct_vhdl_ty :: HType -> TypeSession TypeMapRec
--- State types don't generate VHDL
-construct_vhdl_ty htype =
- case htype of
- StateType -> return Nothing
- (SizedWType w) -> mkUnsignedTy w
- (SizedIType i) -> mkSignedTy i
- (RangedWType u) -> mkNaturalTy 0 u
- (VecType n e) -> mkVectorTy (VecType n e)
- -- Create a custom type from this tycon
- otherwise -> mkTyconTy htype
-
--- | Create VHDL type for a custom tycon
-mkTyconTy :: HType -> TypeSession TypeMapRec
-mkTyconTy htype =
- case htype of
- (AggrType tycon args) -> do
- elemTysMaybe <- mapM vhdlTyMaybe args
- case Maybe.catMaybes elemTysMaybe of
- [] -> -- No non-empty members
- return Nothing
- elem_tys -> do
- let elems = zipWith AST.ElementDec recordlabels elem_tys
- let elem_names = concatMap prettyShow elem_tys
- let ty_id = mkVHDLExtId $ tycon ++ elem_names
- let ty_def = AST.TDR $ AST.RecordTypeDef elems
- let tupshow = mkTupleShow elem_tys ty_id
- MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
- return $ Just (ty_id, Just $ Left ty_def)
- (EnumType tycon dcs) -> do
- let elems = map mkVHDLExtId dcs
- let ty_id = mkVHDLExtId tycon
- let ty_def = AST.TDE $ AST.EnumTypeDef elems
- let enumShow = mkEnumShow elems ty_id
- MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
- return $ Just (ty_id, Just $ Left ty_def)
- otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
- where
- -- Generate a bunch of labels for fields of a record
- recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
-
--- | Create a VHDL vector type
-mkVectorTy ::
- HType -- ^ The Haskell type of the Vector
- -> TypeSession TypeMapRec
- -- ^ An error message or The typemark created.
-
-mkVectorTy (VecType len elHType) = do
- typesMap <- MonadState.get tsTypes
- elTyTmMaybe <- vhdlTyMaybe elHType
- case elTyTmMaybe of
- (Just elTyTm) -> do
- let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
- let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
- case existing_uvec_ty of
- Just (Just t) -> do
- let ty_def = AST.SubtypeIn t (Just range)
- return (Just (ty_id, Just $ Right ty_def))
- Nothing -> do
- let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
- let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
- MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
- MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
- let vecShowFuns = mkVectorShow elTyTm vec_id
- mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
- let ty_def = AST.SubtypeIn vec_id (Just range)
- return (Just (ty_id, Just $ Right ty_def))
- -- Vector of empty elements becomes empty itself.
- Nothing -> return Nothing
-mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
-
-mkNaturalTy ::
- Int -- ^ The minimum bound (> 0)
- -> Int -- ^ The maximum bound (> minimum bound)
- -> TypeSession TypeMapRec
- -- ^ An error message or The typemark created.
-mkNaturalTy min_bound max_bound = do
- let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
- let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
- let ty_def = AST.SubtypeIn unsignedTM (Just range)
- return (Just (ty_id, Just $ Right ty_def))
-
-mkUnsignedTy ::
- Int -- ^ Haskell type of the unsigned integer
- -> TypeSession TypeMapRec
-mkUnsignedTy size = do
- let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
- let ty_def = AST.SubtypeIn unsignedTM (Just range)
- return (Just (ty_id, Just $ Right ty_def))
-
-mkSignedTy ::
- Int -- ^ Haskell type of the signed integer
- -> TypeSession TypeMapRec
-mkSignedTy size = do
- let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
- let ty_def = AST.SubtypeIn signedTM (Just range)
- return (Just (ty_id, Just $ Right ty_def))
-
--- Finds the field labels for VHDL type generated for the given Core type,
--- which must result in a record type.
-getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
-getFieldLabels ty = do
- -- Ensure that the type is generated (but throw away it's VHDLId)
- let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
- vhdlTy error_msg ty
- -- Get the types map, lookup and unpack the VHDL TypeDef
- types <- MonadState.get tsTypes
- -- Assume the type for which we want labels is really translatable
- htype <- mkHType error_msg ty
- case Map.lookup htype types of
- Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype)
- Just Nothing -> return [] -- The type is empty
- Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
- Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)
-
-mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
-mytydecl (_, Nothing) = Nothing
-mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
-mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
-
-mkTupleShow ::
- [AST.TypeMark] -- ^ type of each tuple element
- -> AST.TypeMark -- ^ type of the tuple
- -> AST.SubProgBody
-mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
- where
- tupPar = AST.unsafeVHDLBasicId "tup"
- showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
- showExpr = AST.ReturnSm (Just $
- AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
- where
- showMiddle = if null elemTMs then
- AST.PrimLit "''"
- else
- foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
- map ((genExprFCall showId).
- AST.PrimName .
- AST.NSelected .
- (AST.NSimple tupPar AST.:.:).
- tupVHDLSuffix)
- (take tupSize recordlabels)
- recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
- tupSize = length elemTMs
-
-mkEnumShow ::
- [AST.VHDLId]
- -> AST.TypeMark
- -> AST.SubProgBody
-mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
- where
- enumPar = AST.unsafeVHDLBasicId "enum"
- showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
- showExpr = AST.ReturnSm (Just $
- AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
-
-mkVectorShow ::
- AST.TypeMark -- ^ elemtype
- -> AST.TypeMark -- ^ vectype
- -> [(String,AST.SubProgBody)]
-mkVectorShow elemTM vectorTM =
- [ (headId, AST.SubProgBody headSpec [] [headExpr])
- , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
- , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
- ]
- where
- vecPar = AST.unsafeVHDLBasicId "vec"
- resId = AST.unsafeVHDLBasicId "res"
- headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
- -- return vec(0);
- headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
- (AST.NSimple vecPar) [AST.PrimLit "0"])))
- vecSlice init last = AST.PrimName (AST.NSlice
- (AST.SliceName
- (AST.NSimple vecPar)
- (AST.ToRange init last)))
- tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
- -- variable res : fsvec_x (0 to vec'length-2);
- tailVar =
- AST.VarDec resId
- (AST.SubtypeIn vectorTM
- (Just $ AST.ConstraintIndex $ AST.IndexConstraint
- [AST.ToRange (AST.PrimLit "0")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
- (AST.PrimLit "2")) ]))
- Nothing
- -- res AST.:= vec(1 to vec'length-1)
- tailExpr = AST.NSimple resId AST.:= (vecSlice
- (AST.PrimLit "1")
- (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
- AST.:-: AST.PrimLit "1"))
- tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
- showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
- doShowId = AST.unsafeVHDLExtId "doshow"
- doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
- where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
- stringTM
- -- case vec'len is
- -- when 0 => return "";
- -- when 1 => return head(vec);
- -- when others => return show(head(vec)) & ',' &
- -- doshow (tail(vec));
- -- end case;
- doShowRet =
- AST.CaseSm (AST.PrimName (AST.NAttribute $
- AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
- [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
- [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
- AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
- [AST.ReturnSm (Just $
- genExprFCall showId
- (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
- AST.CaseSmAlt [AST.Others]
- [AST.ReturnSm (Just $
- genExprFCall showId
- (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
- AST.PrimLit "','" AST.:&:
- genExprFCall doShowId
- (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
- -- return '<' & doshow(vec) & '>';
- showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
- genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
- AST.PrimLit "'>'" )
-
-mkBuiltInShow :: [AST.SubProgBody]
-mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
- , AST.SubProgBody showBoolSpec [] [showBoolExpr]
- , AST.SubProgBody showSingedSpec [] [showSignedExpr]
- , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
- -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
- ]
- where
- bitPar = AST.unsafeVHDLBasicId "s"
- boolPar = AST.unsafeVHDLBasicId "b"
- signedPar = AST.unsafeVHDLBasicId "sint"
- unsignedPar = AST.unsafeVHDLBasicId "uint"
- -- naturalPar = AST.unsafeVHDLBasicId "nat"
- showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
- -- if s = '1' then return "'1'" else return "'0'"
- showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
- [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
- []
- (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
- showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
- -- if b then return "True" else return "False"
- showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
- [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
- []
- (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
- showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
- showSignedExpr = AST.ReturnSm (Just $
- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
- where
- signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
- showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
- showUnsignedExpr = AST.ReturnSm (Just $
- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
- where
- unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
- -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
- -- showNaturalExpr = AST.ReturnSm (Just $
- -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
- -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
-
-
-genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
-genExprFCall fName args =
- AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
-
-genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
-genExprPCall2 entid arg1 arg2 =
- AST.ProcCall (AST.NSimple entid) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
-
-mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
-mkSigDec bndr = do
- let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
- type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
- case type_mark_maybe of
- Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
- Nothing -> return Nothing
-
--- | Does the given thing have a non-empty type?
-hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
- t -> TranslatorSession Bool
-hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)
+++ /dev/null
---
--- Some types used by the VHDL module.
---
-module CLasH.VHDL.VHDLTypes where
-
--- VHDL imports
-import qualified Language.VHDL.AST as AST
-
--- A description of a port of an entity
-type Port = (AST.VHDLId, AST.TypeMark)
-
--- A description of a VHDL entity. Contains both the entity itself as well as
--- info on how to map a haskell value (argument / result) on to the entity's
--- ports.
-data Entity = Entity {
- ent_id :: AST.VHDLId, -- ^ The id of the entity
- ent_args :: [Port], -- ^ A port for each non-empty function argument
- ent_res :: Maybe Port, -- ^ The output port
- ent_dec :: AST.EntityDec -- ^ The complete entity declaration
-} deriving (Show);
-
-type Architecture = AST.ArchBody
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
-{-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
-module Data.Param.Index
- ( Index
- , fromNaturalT
- , fromUnsigned
- , rangeT
- ) where
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax (Lift(..))
-import Data.Bits
-import Types
-import Types.Data.Num.Decimal.Literals.TH
-
-import Data.Param.Integer
-
-instance NaturalT nT => Lift (Index nT) where
- lift (Index i) = sigE [| (Index i) |] (decIndexT (fromIntegerT (undefined :: nT)))
-
-decIndexT :: Integer -> Q Type
-decIndexT n = appT (conT (''Index)) (decLiteralT n)
-
-fromNaturalT :: ( NaturalT n
- , NaturalT upper
- , (n :<=: upper) ~ True ) => n -> Index upper
-fromNaturalT x = Index (fromIntegerT x)
-
-fromUnsigned ::
- ( NaturalT nT
- , Integral (Unsigned nT)
- ) => Unsigned nT -> Index ((Pow2 nT) :-: D1)
-fromUnsigned unsigned = Index (toInteger unsigned)
-
-rangeT :: Index nT -> nT
-rangeT _ = undefined
-
-instance NaturalT nT => Eq (Index nT) where
- (Index x) == (Index y) = x == y
- (Index x) /= (Index y) = x /= y
-
-instance NaturalT nT => Show (Index nT) where
- showsPrec prec n =
- showsPrec prec $ toInteger n
-
-instance NaturalT nT => Ord (Index nT) where
- a `compare` b = toInteger a `compare` toInteger b
-
-instance NaturalT nT => Bounded (Index nT) where
- minBound = 0
- maxBound = Index (fromIntegerT (undefined :: nT))
-
-instance NaturalT nT => Enum (Index nT) where
- succ x
- | x == maxBound = error $ "Enum.succ{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
- | otherwise = x + 1
- pred x
- | x == minBound = error $ "Enum.succ{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
- | otherwise = x - 1
-
- fromEnum (Index x)
- | x > toInteger (maxBound :: Int) =
- error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index greater than maxBound :: Int"
- | x < toInteger (minBound :: Int) =
- error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index smaller than minBound :: Int"
- | otherwise =
- fromInteger x
- toEnum x
- | x > fromIntegral (maxBound :: Index nT) =
- error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index greater than maxBound :: Index " ++ show (fromIntegerT (undefined :: nT))
- | x < fromIntegral (minBound :: Index nT) =
- error $ "Enum.fromEnum{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Index smaller than minBound :: Index " ++ show (fromIntegerT (undefined :: nT))
- | otherwise =
- fromInteger $ toInteger x
-
-instance NaturalT nT => Num (Index nT) where
- (Index a) + (Index b) =
- fromInteger $ a + b
- (Index a) * (Index b) =
- fromInteger $ a * b
- (Index a) - (Index b) =
- fromInteger $ a - b
- fromInteger n
- | n > fromIntegerT (undefined :: nT) =
- error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index larger than " ++ show (fromIntegerT (undefined :: nT)) ++ ", n: " ++ show n
- fromInteger n
- | n < 0 =
- error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index smaller than 0, n: " ++ show n
- fromInteger n =
- Index n
- abs s = s
- signum s
- | s == 0 =
- 0
- | otherwise =
- 1
-
-instance NaturalT nT => Real (Index nT) where
- toRational n = toRational $ toInteger n
-
-instance NaturalT nT => Integral (Index nT) where
- a `quotRem` b =
- let (quot, rem) = toInteger a `quotRem` toInteger b
- in (fromInteger quot, fromInteger rem)
- toInteger s@(Index x) = x
+++ /dev/null
-module Data.Param.Integer
- ( Signed(..)
- , Unsigned(..)
- , Index (..)
- ) where
-
-import Types
-
-newtype (NaturalT nT) => Signed nT = Signed Integer
-
-newtype (NaturalT nT) => Unsigned nT = Unsigned Integer
-
-newtype (NaturalT upper) => Index upper = Index Integer
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
-module Data.Param.Signed
- ( Signed
- , resize
- ) where
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax (Lift(..))
-import Data.Bits
-import Types
-import Types.Data.Num.Decimal.Literals.TH
-
-import Data.Param.Integer
-
-instance NaturalT nT => Lift (Signed nT) where
- lift (Signed i) = sigE [| (Signed i) |] (decSignedT (fromIntegerT (undefined :: nT)))
-
-decSignedT :: Integer -> Q Type
-decSignedT n = appT (conT (''Signed)) (decLiteralT n)
-
-resize :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'
-resize a = fromInteger (toInteger a)
-
-sizeT :: Signed nT
- -> nT
-sizeT _ = undefined
-
-mask :: forall nT . NaturalT nT
- => nT
- -> Integer
-mask _ = bit (fromIntegerT (undefined :: nT)) - 1
-
-signBit :: forall nT . NaturalT nT
- => nT
- -> Int
-signBit _ = fromIntegerT (undefined :: nT) - 1
-
-isNegative :: forall nT . NaturalT nT
- => Signed nT
- -> Bool
-isNegative (Signed x) =
- testBit x $ signBit (undefined :: nT)
-
-instance NaturalT nT => Eq (Signed nT) where
- (Signed x) == (Signed y) = x == y
- (Signed x) /= (Signed y) = x /= y
-
-instance NaturalT nT => Show (Signed nT) where
- showsPrec prec n =
- showsPrec prec $ toInteger n
-
-instance NaturalT nT => Read (Signed nT) where
- readsPrec prec str =
- [ (fromInteger n, str)
- | (n, str) <- readsPrec prec str ]
-
-instance NaturalT nT => Ord (Signed nT) where
- a `compare` b = toInteger a `compare` toInteger b
-
-instance NaturalT nT => Bounded (Signed nT) where
- minBound = Signed $ negate $ 1 `shiftL` (fromIntegerT (undefined :: nT) - 1)
- maxBound = Signed $ (1 `shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1
-
-instance NaturalT nT => Enum (Signed nT) where
- succ x
- | x == maxBound = error $ "Enum.succ{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
- | otherwise = x + 1
- pred x
- | x == minBound = error $ "Enum.succ{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
- | otherwise = x - 1
-
- fromEnum (Signed x)
- | x > toInteger (maxBound :: Int) =
- error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed greater than maxBound :: Int"
- | x < toInteger (minBound :: Int) =
- error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed smaller than minBound :: Int"
- | otherwise =
- fromInteger x
- toEnum x
- | x' > toInteger (maxBound :: Signed nT) =
- error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed greater than maxBound :: Signed " ++ show (fromIntegerT (undefined :: nT))
- | x' < toInteger (minBound :: Signed nT) =
- error $ "Enum.fromEnum{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Signed smaller than minBound :: Signed " ++ show (fromIntegerT (undefined :: nT))
- | otherwise =
- fromInteger x'
- where x' = toInteger x
-
-instance NaturalT nT => Num (Signed nT) where
- (Signed a) + (Signed b) =
- fromInteger $ a + b
- (Signed a) * (Signed b) =
- fromInteger $ a * b
- negate (Signed n) =
- fromInteger $ (n `xor` mask (undefined :: nT)) + 1
- a - b =
- a + (negate b)
-
- fromInteger n
- | n > 0 =
- Signed $ n .&. mask (undefined :: nT)
- fromInteger n
- | n < 0 =
- negate $ fromInteger $ negate n
- fromInteger _ =
- Signed 0
-
- abs s
- | isNegative s =
- negate s
- | otherwise =
- s
- signum s
- | isNegative s =
- -1
- | s == 0 =
- 0
- | otherwise =
- 1
-
-instance NaturalT nT => Real (Signed nT) where
- toRational n = toRational $ toInteger n
-
-instance NaturalT nT => Integral (Signed nT) where
- a `quot` b =
- fromInteger $ toInteger a `quot` toInteger b
- a `rem` b =
- fromInteger $ toInteger a `rem` toInteger b
- a `div` b =
- fromInteger $ toInteger a `div` toInteger b
- a `mod` b =
- fromInteger $ toInteger a `mod` toInteger b
- a `quotRem` b =
- let (quot, rem) = toInteger a `quotRem` toInteger b
- in (fromInteger quot, fromInteger rem)
- a `divMod` b =
- let (div, mod) = toInteger a `divMod` toInteger b
- in (fromInteger div, fromInteger mod)
- toInteger s@(Signed x) =
- if isNegative s
- then let Signed x' = negate s in negate x'
- else x
-
-instance NaturalT nT => Bits (Signed nT) where
- (Signed a) .&. (Signed b) = Signed $ a .&. b
- (Signed a) .|. (Signed b) = Signed $ a .|. b
- (Signed a) `xor` Signed b = Signed $ a `xor` b
- complement (Signed x) = Signed $ x `xor` mask (undefined :: nT)
- (Signed x) `shiftL` b
- | b < 0 = error $ "Bits.shiftL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
- | otherwise =
- Signed $ mask (undefined :: nT) .&. (x `shiftL` b)
- s@(Signed x) `shiftR` b
- | b < 0 = error $ "Bits.shiftR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount"
- | isNegative s =
- Signed $ mask (undefined :: nT) .&.
- ((x `shiftR` b) .|. (mask (undefined :: nT) `shiftL` (fromIntegerT (undefined :: nT) - b)))
- | otherwise =
- Signed $ (mask (undefined :: nT)) .&. (x `shiftR` b)
- (Signed a) `rotateL` b
- | b < 0 =
- error $ "Bits.rotateL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
- | otherwise =
- Signed $ mask (undefined :: nT) .&.
- ((a `shiftL` b) .|. (a `shiftR` (fromIntegerT (undefined :: nT) - b)))
- (Signed a) `rotateR` b
- | b < 0 =
- error $ "Bits.rotateR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount"
- | otherwise =
- Signed $ mask (undefined :: nT) .&.
- ((a `shiftR` b) .|. (a `shiftL` (fromIntegerT (undefined :: nT) - b)))
- bitSize _ = fromIntegerT (undefined :: nT)
- isSigned _ = True
+++ /dev/null
-{-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-}
-module Data.Param.Unsigned
- ( Unsigned
- , resize
- , fromIndex
- ) where
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax (Lift(..))
-import Data.Bits
-import Types
-import Types.Data.Num.Decimal.Literals.TH
-
-import Data.Param.Integer
-
-instance NaturalT nT => Lift (Unsigned nT) where
- lift (Unsigned i) = sigE [| (Unsigned i) |] (decUnsignedT (fromIntegerT (undefined :: nT)))
-
-decUnsignedT :: Integer -> Q Type
-decUnsignedT n = appT (conT (''Unsigned)) (decLiteralT n)
-
-fromIndex ::
- ( NaturalT nT
- , NaturalT nT'
- , ((Pow2 nT') :>: nT) ~ True
- , Integral (Index nT)
- ) => Index nT -> Unsigned nT'
-fromIndex index = Unsigned (toInteger index)
-
-resize :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'
-resize a = fromInteger (toInteger a)
-
-sizeT :: Unsigned nT
- -> nT
-sizeT _ = undefined
-
-mask :: forall nT . NaturalT nT
- => nT
- -> Integer
-mask _ = bit (fromIntegerT (undefined :: nT)) - 1
-
-instance NaturalT nT => Eq (Unsigned nT) where
- (Unsigned x) == (Unsigned y) = x == y
- (Unsigned x) /= (Unsigned y) = x /= y
-
-instance NaturalT nT => Show (Unsigned nT) where
- showsPrec prec n =
- showsPrec prec $ toInteger n
-
-instance NaturalT nT => Read (Unsigned nT) where
- readsPrec prec str =
- [ (fromInteger n, str)
- | (n, str) <- readsPrec prec str ]
-
-instance NaturalT nT => Ord (Unsigned nT) where
- a `compare` b = toInteger a `compare` toInteger b
-
-instance NaturalT nT => Bounded (Unsigned nT) where
- minBound = 0
- maxBound = Unsigned $ (1 `shiftL` (fromIntegerT (undefined :: nT))) - 1
-
-instance NaturalT nT => Enum (Unsigned nT) where
- succ x
- | x == maxBound = error $ "Enum.succ{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound"
- | otherwise = x + 1
- pred x
- | x == minBound = error $ "Enum.succ{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `pred' of minBound"
- | otherwise = x - 1
-
- fromEnum (Unsigned x)
- | x > toInteger (maxBound :: Int) =
- error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned greater than maxBound :: Int"
- | x < toInteger (minBound :: Int) =
- error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned smaller than minBound :: Int"
- | otherwise =
- fromInteger x
- toEnum x
- | x > fromIntegral (maxBound :: Unsigned nT) =
- error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned greater than maxBound :: Unsigned " ++ show (fromIntegerT (undefined :: nT))
- | x < fromIntegral (minBound :: Unsigned nT) =
- error $ "Enum.fromEnum{Unsigned " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `fromEnum' on Unsigned smaller than minBound :: Unsigned " ++ show (fromIntegerT (undefined :: nT))
- | otherwise =
- fromInteger $ toInteger x
-
-instance NaturalT nT => Num (Unsigned nT) where
- (Unsigned a) + (Unsigned b) =
- fromInteger $ a + b
- (Unsigned a) * (Unsigned b) =
- fromInteger $ a * b
- negate s@(Unsigned n) =
- fromInteger $ (n `xor` mask (sizeT s)) + 1
- a - b =
- a + (negate b)
-
- fromInteger n
- | n > 0 =
- Unsigned $ n .&. mask (undefined :: nT)
- fromInteger n
- | n < 0 =
- negate $ fromInteger $ negate n
- fromInteger _ =
- Unsigned 0
-
- abs s = s
- signum s
- | s == 0 =
- 0
- | otherwise =
- 1
-
-instance NaturalT nT => Real (Unsigned nT) where
- toRational n = toRational $ toInteger n
-
-instance NaturalT nT => Integral (Unsigned nT) where
- a `quot` b =
- fromInteger $ toInteger a `quot` toInteger b
- a `rem` b =
- fromInteger $ toInteger a `rem` toInteger b
- a `div` b =
- fromInteger $ toInteger a `div` toInteger b
- a `mod` b =
- fromInteger $ toInteger a `mod` toInteger b
- a `quotRem` b =
- let (quot, rem) = toInteger a `quotRem` toInteger b
- in (fromInteger quot, fromInteger rem)
- a `divMod` b =
- let (div, mod) = toInteger a `divMod` toInteger b
- in (fromInteger div, fromInteger mod)
- toInteger s@(Unsigned x) = x
-
-instance NaturalT nT => Bits (Unsigned nT) where
- (Unsigned a) .&. (Unsigned b) = Unsigned $ a .&. b
- (Unsigned a) .|. (Unsigned b) = Unsigned $ a .|. b
- (Unsigned a) `xor` Unsigned b = Unsigned $ a `xor` b
- complement (Unsigned x) = Unsigned $ x `xor` mask (undefined :: nT)
- s@(Unsigned x) `shiftL` b
- | b < 0 = error $ "Bits.shiftL{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"
- | otherwise =
- Unsigned $ mask (undefined :: nT) .&. (x `shiftL` b)
- s@(Unsigned x) `shiftR` b
- | b < 0 = error $ "Bits.shiftR{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"
- | otherwise =
- Unsigned $ (x `shiftR` b)
- s@(Unsigned x) `rotateL` b
- | b < 0 =
- error $ "Bits.rotateL{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"
- | otherwise =
- Unsigned $ mask (undefined :: nT) .&.
- ((x `shiftL` b) .|. (x `shiftR` (bitSize s - b)))
- s@(Unsigned x) `rotateR` b
- | b < 0 =
- error $ "Bits.rotateR{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"
- | otherwise =
- Unsigned $ mask (undefined :: nT) .&.
- ((x `shiftR` b) .|. (x `shiftL` (bitSize s - b)))
- bitSize _ = fromIntegerT (undefined :: nT)
- isSigned _ = False
+++ /dev/null
-{-# LANGUAGE StandaloneDeriving, ExistentialQuantification, ScopedTypeVariables, TemplateHaskell, TypeOperators, TypeFamilies #-}
-module Data.Param.Vector
- ( Vector
- , empty
- , (+>)
- , singleton
- , vectorTH
- , unsafeVector
- , readVector
- , length
- , lengthT
- , fromVector
- , null
- , (!)
- , replace
- , head
- , last
- , init
- , tail
- , take
- , drop
- , select
- , (<+)
- , (++)
- , map
- , zipWith
- , foldl
- , foldr
- , zip
- , unzip
- , shiftl
- , shiftr
- , rotl
- , rotr
- , concat
- , reverse
- , iterate
- , iteraten
- , generate
- , generaten
- , copy
- , copyn
- , split
- ) where
-
-import Types
-import Types.Data.Num
-import Types.Data.Num.Decimal.Literals.TH
-import Data.Param.Index
-
-import Data.Typeable
-import qualified Prelude as P
-import Prelude hiding (
- null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
- zipWith, zip, unzip, concat, reverse, iterate )
-import qualified Data.Foldable as DF (Foldable, foldr)
-import qualified Data.Traversable as DT (Traversable(traverse))
-import Language.Haskell.TH hiding (Pred)
-import Language.Haskell.TH.Syntax (Lift(..))
-
-newtype (NaturalT s) => Vector s a = Vector {unVec :: [a]}
- deriving Eq
-
--- deriving instance (NaturalT s, Typeable s, Data s, Typeable a, Data a) => Data (TFVec s a)
-
--- ==========================
--- = Constructing functions =
--- ==========================
-
-empty :: Vector D0 a
-empty = Vector []
-
-(+>) :: a -> Vector s a -> Vector (Succ s) a
-x +> (Vector xs) = Vector (x:xs)
-
-infix 5 +>
-
-singleton :: a -> Vector D1 a
-singleton x = x +> empty
-
--- FIXME: Not the most elegant solution... but it works for now in clash
-vectorTH :: (Lift a) => [a] -> ExpQ
--- vectorTH xs = sigE [| (TFVec xs) |] (decTFVecT (toInteger (P.length xs)) xs)
-vectorTH [] = [| empty |]
-vectorTH [x] = [| singleton x |]
-vectorTH (x:xs) = [| x +> $(vectorTH xs) |]
-
-unsafeVector :: NaturalT s => s -> [a] -> Vector s a
-unsafeVector l xs
- | fromIntegerT l /= P.length xs =
- error (show 'unsafeVector P.++ ": dynamic/static lenght mismatch")
- | otherwise = Vector xs
-
-readVector :: (Read a, NaturalT s) => String -> Vector s a
-readVector = read
-
--- =======================
--- = Observing functions =
--- =======================
-length :: forall s a . NaturalT s => Vector s a -> Int
-length _ = fromIntegerT (undefined :: s)
-
-lengthT :: NaturalT s => Vector s a -> s
-lengthT = undefined
-
-fromVector :: NaturalT s => Vector s a -> [a]
-fromVector (Vector xs) = xs
-
-null :: Vector D0 a -> Bool
-null _ = True
-
-(!) :: ( PositiveT s
- , NaturalT u
- , (s :>: u) ~ True) => Vector s a -> Index u -> a
-(Vector xs) ! i = xs !! (fromInteger (toInteger i))
-
--- ==========================
--- = Transforming functions =
--- ==========================
-replace :: (PositiveT s, NaturalT u, (s :>: u) ~ True) =>
- Vector s a -> Index u -> a -> Vector s a
-replace (Vector xs) i y = Vector $ replace' xs (toInteger i) y
- where replace' [] _ _ = []
- replace' (_:xs) 0 y = (y:xs)
- replace' (x:xs) n y = x : (replace' xs (n-1) y)
-
-head :: PositiveT s => Vector s a -> a
-head = P.head . unVec
-
-tail :: PositiveT s => Vector s a -> Vector (Pred s) a
-tail = liftV P.tail
-
-last :: PositiveT s => Vector s a -> a
-last = P.last . unVec
-
-init :: PositiveT s => Vector s a -> Vector (Pred s) a
-init = liftV P.init
-
-take :: NaturalT i => i -> Vector s a -> Vector (Min s i) a
-take i = liftV $ P.take (fromIntegerT i)
-
-drop :: NaturalT i => i -> Vector s a -> Vector (s :-: (Min s i)) a
-drop i = liftV $ P.drop (fromIntegerT i)
-
-select :: (NaturalT f, NaturalT s, NaturalT n, (f :<: i) ~ True,
- (((s :*: n) :+: f) :<=: i) ~ True) =>
- f -> s -> n -> Vector i a -> Vector n a
-select f s n = liftV (select' f' s' n')
- where (f', s', n') = (fromIntegerT f, fromIntegerT s, fromIntegerT n)
- select' f s n = ((selectFirst0 s n).(P.drop f))
- selectFirst0 :: Int -> Int -> [a] -> [a]
- selectFirst0 s n l@(x:_)
- | n > 0 = x : selectFirst0 s (n-1) (P.drop s l)
- | otherwise = []
- selectFirst0 _ 0 [] = []
-
-(<+) :: Vector s a -> a -> Vector (Succ s) a
-(<+) (Vector xs) x = Vector (xs P.++ [x])
-
-(++) :: Vector s a -> Vector s2 a -> Vector (s :+: s2) a
-(++) = liftV2 (P.++)
-
-infixl 5 <+
-infixr 5 ++
-
-map :: (a -> b) -> Vector s a -> Vector s b
-map f = liftV (P.map f)
-
-zipWith :: (a -> b -> c) -> Vector s a -> Vector s b -> Vector s c
-zipWith f = liftV2 (P.zipWith f)
-
-foldl :: (a -> b -> a) -> a -> Vector s b -> a
-foldl f e = (P.foldl f e) . unVec
-
-foldr :: (b -> a -> a) -> a -> Vector s b -> a
-foldr f e = (P.foldr f e) . unVec
-
-zip :: Vector s a -> Vector s b -> Vector s (a, b)
-zip = liftV2 P.zip
-
-unzip :: Vector s (a, b) -> (Vector s a, Vector s b)
-unzip (Vector xs) = let (a,b) = P.unzip xs in (Vector a, Vector b)
-
-shiftl :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
- Vector s a -> a -> Vector s a
-shiftl xs x = x +> init xs
-
-shiftr :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) =>
- Vector s a -> a -> Vector s a
-shiftr xs x = tail xs <+ x
-
-rotl :: forall s a . NaturalT s => Vector s a -> Vector s a
-rotl = liftV rotl'
- where vlen = fromIntegerT (undefined :: s)
- rotl' [] = []
- rotl' xs = let (i,[l]) = splitAt (vlen - 1) xs
- in l : i
-
-rotr :: NaturalT s => Vector s a -> Vector s a
-rotr = liftV rotr'
- where
- rotr' [] = []
- rotr' (x:xs) = xs P.++ [x]
-
-concat :: Vector s1 (Vector s2 a) -> Vector (s1 :*: s2) a
-concat = liftV (P.foldr ((P.++).unVec) [])
-
-reverse :: Vector s a -> Vector s a
-reverse = liftV P.reverse
-
-iterate :: NaturalT s => (a -> a) -> a -> Vector s a
-iterate = iteraten (undefined :: s)
-
-iteraten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
-iteraten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.iterate f x)
-
-generate :: NaturalT s => (a -> a) -> a -> Vector s a
-generate = generaten (undefined :: s)
-
-generaten :: NaturalT s => s -> (a -> a) -> a -> Vector s a
-generaten s f x = let s' = fromIntegerT s in Vector (P.take s' $ P.tail $ P.iterate f x)
-
-copy :: NaturalT s => a -> Vector s a
-copy x = copyn (undefined :: s) x
-
-copyn :: NaturalT s => s -> a -> Vector s a
-copyn s x = iteraten s id x
-
-split :: ( NaturalT s
- -- , IsEven s ~ True
- ) => Vector s a -> (Vector (Div2 s) a, Vector (Div2 s) a)
-split (Vector xs) = (Vector (P.take vlen xs), Vector (P.drop vlen xs))
- where
- vlen = round ((fromIntegral (P.length xs)) / 2)
-
--- =============
--- = Instances =
--- =============
-instance Show a => Show (Vector s a) where
- showsPrec _ = showV.unVec
- where showV [] = showString "<>"
- showV (x:xs) = showChar '<' . shows x . showl xs
- where showl [] = showChar '>'
- showl (x:xs) = showChar ',' . shows x .
- showl xs
-
-instance (Read a, NaturalT nT) => Read (Vector nT a) where
- readsPrec _ str
- | all fitsLength possibilities = P.map toReadS possibilities
- | otherwise = error (fName P.++ ": string/dynamic length mismatch")
- where
- fName = "Data.Param.TFVec.read"
- expectedL = fromIntegerT (undefined :: nT)
- possibilities = readVectorList str
- fitsLength (_, l, _) = l == expectedL
- toReadS (xs, _, rest) = (Vector xs, rest)
-
-instance NaturalT s => DF.Foldable (Vector s) where
- foldr = foldr
-
-instance NaturalT s => Functor (Vector s) where
- fmap = map
-
-instance NaturalT s => DT.Traversable (Vector s) where
- traverse f = (fmap Vector).(DT.traverse f).unVec
-
-instance (Lift a, NaturalT nT) => Lift (Vector nT a) where
- lift (Vector xs) = [| unsafeVectorCoerse
- $(decLiteralV (fromIntegerT (undefined :: nT)))
- (Vector xs) |]
-
--- ======================
--- = Internal Functions =
--- ======================
-liftV :: ([a] -> [b]) -> Vector nT a -> Vector nT' b
-liftV f = Vector . f . unVec
-
-liftV2 :: ([a] -> [b] -> [c]) -> Vector s a -> Vector s2 b -> Vector s3 c
-liftV2 f a b = Vector (f (unVec a) (unVec b))
-
-splitAtM :: Int -> [a] -> Maybe ([a],[a])
-splitAtM n xs = splitAtM' n [] xs
- where splitAtM' 0 xs ys = Just (xs, ys)
- splitAtM' n xs (y:ys) | n > 0 = do
- (ls, rs) <- splitAtM' (n-1) xs ys
- return (y:ls,rs)
- splitAtM' _ _ _ = Nothing
-
-unsafeVectorCoerse :: nT' -> Vector nT a -> Vector nT' a
-unsafeVectorCoerse _ (Vector v) = (Vector v)
-
-readVectorList :: Read a => String -> [([a], Int, String)]
-readVectorList = readParen' False (\r -> [pr | ("<",s) <- lexVector r,
- pr <- readl s])
- where
- readl s = [([],0,t) | (">",t) <- lexVector s] P.++
- [(x:xs,1+n,u) | (x,t) <- reads s,
- (xs, n, u) <- readl' t]
- readl' s = [([],0,t) | (">",t) <- lexVector s] P.++
- [(x:xs,1+n,v) | (",",t) <- lex s,
- (x,u) <- reads t,
- (xs,n,v) <- readl' u]
- readParen' b g = if b then mandatory else optional
- where optional r = g r P.++ mandatory r
- mandatory r = [(x,n,u) | ("(",s) <- lexVector r,
- (x,n,t) <- optional s,
- (")",u) <- lexVector t]
-
--- Custom lexer for FSVecs, we cannot use lex directly because it considers
--- sequences of < and > as unique lexemes, and that breaks nested FSVecs, e.g.
--- <<1,2><3,4>>
-lexVector :: ReadS String
-lexVector ('>':rest) = [(">",rest)]
-lexVector ('<':rest) = [("<",rest)]
-lexVector str = lex str
-
+++ /dev/null
-Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
- * Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
- * Neither the name of the copyright holder nor the
- names of its contributors may be used to endorse or promote products
- derived from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY
-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE
-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
-BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
-IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
+++ /dev/null
-name: clash
-version: 0.1
-build-type: Simple
-synopsis: CAES Language for Synchronous Hardware (CLaSH)
-description: CLaSH is a tool-chain/language to translate subsets of
- Haskell to synthesizable VHDL. It does this by translating
- the intermediate System Fc (GHC Core) representation to a
- VHDL AST, which is then written to file.
-category: Language, Hardware
-license: BSD3
-license-file: LICENSE
-homepage: http://clash.ewi.utwente.nl/
-package-url: http://github.com/christiaanb/clash/tree/master/cλash
-copyright: Copyright (c) 2009-2010 Christiaan Baaij &
- Matthijs Kooijman
-author: Christiaan Baaij & Matthijs Kooijman
-stability: alpha
-maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl
-Cabal-Version: >= 1.2
-
-Library
- build-depends: ghc >= 6.12, pretty, vhdl > 0.1, haskell98, syb,
- data-accessor, containers, base >= 4 && < 5, transformers,
- filepath, template-haskell, data-accessor-template,
- data-accessor-transformers, prettyclass, directory,
- tfp, th-lift, time
-
- exposed-modules: CLasH.HardwareTypes
- CLasH.Translator
- CLasH.Translator.Annotations
-
- other-modules: Data.Param.Integer
- Data.Param.Signed
- Data.Param.Unsigned
- Data.Param.Index
- Data.Param.Vector
- CLasH.Translator.TranslatorTypes
- CLasH.Normalize
- CLasH.Normalize.NormalizeTypes
- CLasH.Normalize.NormalizeTools
- CLasH.VHDL
- CLasH.VHDL.Constants
- CLasH.VHDL.Generate
- CLasH.VHDL.Testbench
- CLasH.VHDL.VHDLTools
- CLasH.VHDL.VHDLTypes
- CLasH.Utils
- CLasH.Utils.GhcTools
- CLasH.Utils.HsTools
- CLasH.Utils.Pretty
- CLasH.Utils.Core.BinderTools
- CLasH.Utils.Core.CoreShow
- CLasH.Utils.Core.CoreTools
-
-
projects / matthijs / master-project / cλash.git / commitdiff