diff --git a/CLasH/HardwareTypes.hs b/CLasH/HardwareTypes.hs new file mode 100644 --- /dev/null +++ b/CLasH/HardwareTypes.hs @@ -0,0 +1,93 @@ +{-# 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 diff --git a/CLasH/Normalize.hs b/CLasH/Normalize.hs new file mode 100644 --- /dev/null +++ b/CLasH/Normalize.hs @@ -0,0 +1,1043 @@ +-- +-- 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 diff --git a/CLasH/Normalize/NormalizeTools.hs b/CLasH/Normalize/NormalizeTools.hs new file mode 100644 --- /dev/null +++ b/CLasH/Normalize/NormalizeTools.hs @@ -0,0 +1,245 @@ +-- +-- 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 diff --git a/CLasH/Normalize/NormalizeTypes.hs b/CLasH/Normalize/NormalizeTypes.hs new file mode 100644 --- /dev/null +++ b/CLasH/Normalize/NormalizeTypes.hs @@ -0,0 +1,34 @@ +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 diff --git a/CLasH/Translator.hs b/CLasH/Translator.hs new file mode 100644 --- /dev/null +++ b/CLasH/Translator.hs @@ -0,0 +1,142 @@ +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: diff --git a/CLasH/Translator/Annotations.hs b/CLasH/Translator/Annotations.hs new file mode 100644 --- /dev/null +++ b/CLasH/Translator/Annotations.hs @@ -0,0 +1,24 @@ +{-# 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 diff --git a/CLasH/Translator/TranslatorTypes.hs b/CLasH/Translator/TranslatorTypes.hs new file mode 100644 --- /dev/null +++ b/CLasH/Translator/TranslatorTypes.hs @@ -0,0 +1,131 @@ +{-# 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: diff --git a/CLasH/Utils.hs b/CLasH/Utils.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils.hs @@ -0,0 +1,69 @@ +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 diff --git a/CLasH/Utils/Core/BinderTools.hs b/CLasH/Utils/Core/BinderTools.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils/Core/BinderTools.hs @@ -0,0 +1,95 @@ +-- +-- 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 diff --git a/CLasH/Utils/Core/CoreShow.hs b/CLasH/Utils/Core/CoreShow.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils/Core/CoreShow.hs @@ -0,0 +1,80 @@ +{-# 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) ++ "__" diff --git a/CLasH/Utils/Core/CoreTools.hs b/CLasH/Utils/Core/CoreTools.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils/Core/CoreTools.hs @@ -0,0 +1,463 @@ +{-# 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) diff --git a/CLasH/Utils/GhcTools.hs b/CLasH/Utils/GhcTools.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils/GhcTools.hs @@ -0,0 +1,249 @@ +{-# 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" diff --git a/CLasH/Utils/HsTools.hs b/CLasH/Utils/HsTools.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils/HsTools.hs @@ -0,0 +1,212 @@ +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 "") 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 diff --git a/CLasH/Utils/Pretty.hs b/CLasH/Utils/Pretty.hs new file mode 100644 --- /dev/null +++ b/CLasH/Utils/Pretty.hs @@ -0,0 +1,81 @@ +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 diff --git a/CLasH/VHDL.hs b/CLasH/VHDL.hs new file mode 100644 --- /dev/null +++ b/CLasH/VHDL.hs @@ -0,0 +1,99 @@ +-- +-- 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]) diff --git a/CLasH/VHDL/Constants.hs b/CLasH/VHDL/Constants.hs new file mode 100644 --- /dev/null +++ b/CLasH/VHDL/Constants.hs @@ -0,0 +1,399 @@ +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 diff --git a/CLasH/VHDL/Generate.hs b/CLasH/VHDL/Generate.hs new file mode 100644 --- /dev/null +++ b/CLasH/VHDL/Generate.hs @@ -0,0 +1,1634 @@ +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")) + ] diff --git a/CLasH/VHDL/Testbench.hs b/CLasH/VHDL/Testbench.hs new file mode 100644 --- /dev/null +++ b/CLasH/VHDL/Testbench.hs @@ -0,0 +1,173 @@ +-- +-- 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) diff --git a/CLasH/VHDL/VHDLTools.hs b/CLasH/VHDL/VHDLTools.hs new file mode 100644 --- /dev/null +++ b/CLasH/VHDL/VHDLTools.hs @@ -0,0 +1,704 @@ +{-# 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) diff --git a/CLasH/VHDL/VHDLTypes.hs b/CLasH/VHDL/VHDLTypes.hs new file mode 100644 --- /dev/null +++ b/CLasH/VHDL/VHDLTypes.hs @@ -0,0 +1,24 @@ +-- +-- 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: diff --git a/Data/Param/Index.hs b/Data/Param/Index.hs new file mode 100644 --- /dev/null +++ b/Data/Param/Index.hs @@ -0,0 +1,104 @@ +{-# 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 diff --git a/Data/Param/Integer.hs b/Data/Param/Integer.hs new file mode 100644 --- /dev/null +++ b/Data/Param/Integer.hs @@ -0,0 +1,13 @@ +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 diff --git a/Data/Param/Signed.hs b/Data/Param/Signed.hs new file mode 100644 --- /dev/null +++ b/Data/Param/Signed.hs @@ -0,0 +1,172 @@ +{-# 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 diff --git a/Data/Param/Unsigned.hs b/Data/Param/Unsigned.hs new file mode 100644 --- /dev/null +++ b/Data/Param/Unsigned.hs @@ -0,0 +1,157 @@ +{-# 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 diff --git a/Data/Param/Vector.hs b/Data/Param/Vector.hs new file mode 100644 --- /dev/null +++ b/Data/Param/Vector.hs @@ -0,0 +1,316 @@ +{-# 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/clash.cabal b/clash.cabal new file mode 100644 --- /dev/null +++ b/clash.cabal @@ -0,0 +1,55 @@ +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 + +