From: christiaanb Date: Wed, 2 Jun 2010 08:03:58 +0000 (+0200) Subject: Rename cλash dir to clash so it behaves well within the ghc build tree X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=04f836932ad17dd557af0ba388a12d2b74c1e7d7 Rename cλash dir to clash so it behaves well within the ghc build tree --- diff --git a/clash/CLasH/HardwareTypes.hs b/clash/CLasH/HardwareTypes.hs new file mode 100644 index 0000000..2912e50 --- /dev/null +++ b/clash/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/CLasH/Normalize.hs b/clash/CLasH/Normalize.hs new file mode 100644 index 0000000..c27e93e --- /dev/null +++ b/clash/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/CLasH/Normalize/NormalizeTools.hs b/clash/CLasH/Normalize/NormalizeTools.hs new file mode 100644 index 0000000..cdb7ee0 --- /dev/null +++ b/clash/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/CLasH/Normalize/NormalizeTypes.hs b/clash/CLasH/Normalize/NormalizeTypes.hs new file mode 100644 index 0000000..4e98709 --- /dev/null +++ b/clash/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/CLasH/Translator.hs b/clash/CLasH/Translator.hs new file mode 100644 index 0000000..6177dab --- /dev/null +++ b/clash/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/CLasH/Translator/Annotations.hs b/clash/CLasH/Translator/Annotations.hs new file mode 100644 index 0000000..2c87550 --- /dev/null +++ b/clash/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 \ No newline at end of file diff --git a/clash/CLasH/Translator/TranslatorTypes.hs b/clash/CLasH/Translator/TranslatorTypes.hs new file mode 100644 index 0000000..eabb004 --- /dev/null +++ b/clash/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/CLasH/Utils.hs b/clash/CLasH/Utils.hs new file mode 100644 index 0000000..d85b25b --- /dev/null +++ b/clash/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/CLasH/Utils/Core/BinderTools.hs b/clash/CLasH/Utils/Core/BinderTools.hs new file mode 100644 index 0000000..cd01675 --- /dev/null +++ b/clash/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/CLasH/Utils/Core/CoreShow.hs b/clash/CLasH/Utils/Core/CoreShow.hs new file mode 100644 index 0000000..ca2a7fb --- /dev/null +++ b/clash/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/CLasH/Utils/Core/CoreTools.hs b/clash/CLasH/Utils/Core/CoreTools.hs new file mode 100644 index 0000000..2bb688b --- /dev/null +++ b/clash/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/CLasH/Utils/GhcTools.hs b/clash/CLasH/Utils/GhcTools.hs new file mode 100644 index 0000000..f1fe6ba --- /dev/null +++ b/clash/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/CLasH/Utils/HsTools.hs b/clash/CLasH/Utils/HsTools.hs new file mode 100644 index 0000000..22b1382 --- /dev/null +++ b/clash/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/CLasH/Utils/Pretty.hs b/clash/CLasH/Utils/Pretty.hs new file mode 100644 index 0000000..df78ad9 --- /dev/null +++ b/clash/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/CLasH/VHDL.hs b/clash/CLasH/VHDL.hs new file mode 100644 index 0000000..56342fc --- /dev/null +++ b/clash/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/CLasH/VHDL/Constants.hs b/clash/CLasH/VHDL/Constants.hs new file mode 100644 index 0000000..c70ca71 --- /dev/null +++ b/clash/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/CLasH/VHDL/Generate.hs b/clash/CLasH/VHDL/Generate.hs new file mode 100644 index 0000000..3d31529 --- /dev/null +++ b/clash/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/CLasH/VHDL/Testbench.hs b/clash/CLasH/VHDL/Testbench.hs new file mode 100644 index 0000000..fa2e9dc --- /dev/null +++ b/clash/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/CLasH/VHDL/VHDLTools.hs b/clash/CLasH/VHDL/VHDLTools.hs new file mode 100644 index 0000000..165b1ef --- /dev/null +++ b/clash/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/CLasH/VHDL/VHDLTypes.hs b/clash/CLasH/VHDL/VHDLTypes.hs new file mode 100644 index 0000000..38ccc97 --- /dev/null +++ b/clash/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/clash/Data/Param/Index.hs b/clash/Data/Param/Index.hs new file mode 100644 index 0000000..f31b1f8 --- /dev/null +++ b/clash/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/clash/Data/Param/Integer.hs b/clash/Data/Param/Integer.hs new file mode 100644 index 0000000..b4b1ec8 --- /dev/null +++ b/clash/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 \ No newline at end of file diff --git a/clash/Data/Param/Signed.hs b/clash/Data/Param/Signed.hs new file mode 100644 index 0000000..26ac677 --- /dev/null +++ b/clash/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/clash/Data/Param/Unsigned.hs b/clash/Data/Param/Unsigned.hs new file mode 100644 index 0000000..aae032d --- /dev/null +++ b/clash/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/clash/Data/Param/Vector.hs b/clash/Data/Param/Vector.hs new file mode 100644 index 0000000..32218be --- /dev/null +++ b/clash/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/clash/LICENSE b/clash/LICENSE new file mode 100644 index 0000000..23ebcfd --- /dev/null +++ b/clash/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. \ No newline at end of file diff --git a/clash/clash.cabal b/clash/clash.cabal new file mode 100644 index 0000000..2eb3058 --- /dev/null +++ b/clash/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 + + diff --git a/clash/ghc-stage b/clash/ghc-stage new file mode 100644 index 0000000..9a7456b --- /dev/null +++ b/clash/ghc-stage @@ -0,0 +1,2 @@ +2 + diff --git "a/c\316\273ash/CLasH/HardwareTypes.hs" "b/c\316\273ash/CLasH/HardwareTypes.hs" deleted file mode 100644 index 2912e50..0000000 --- "a/c\316\273ash/CLasH/HardwareTypes.hs" +++ /dev/null @@ -1,93 +0,0 @@ -{-# 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/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" deleted file mode 100644 index c27e93e..0000000 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ /dev/null @@ -1,1043 +0,0 @@ --- --- 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/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" deleted file mode 100644 index cdb7ee0..0000000 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ /dev/null @@ -1,245 +0,0 @@ --- --- 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/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" deleted file mode 100644 index 4e98709..0000000 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" +++ /dev/null @@ -1,34 +0,0 @@ -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/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" deleted file mode 100644 index 6177dab..0000000 --- "a/c\316\273ash/CLasH/Translator.hs" +++ /dev/null @@ -1,142 +0,0 @@ -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/c\316\273ash/CLasH/Translator/Annotations.hs" "b/c\316\273ash/CLasH/Translator/Annotations.hs" deleted file mode 100644 index 2c87550..0000000 --- "a/c\316\273ash/CLasH/Translator/Annotations.hs" +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module CLasH.Translator.Annotations where - -import qualified Language.Haskell.TH as TH -import Data.Data - -data CLasHAnn = TopEntity | InitState TH.Name | TestInput | TestCycles - deriving (Show, Data, Typeable) - -isTopEntity :: CLasHAnn -> Bool -isTopEntity TopEntity = True -isTopEntity _ = False - -isInitState :: CLasHAnn -> Bool -isInitState (InitState _) = True -isInitState _ = False - -isTestInput :: CLasHAnn -> Bool -isTestInput TestInput = True -isTestInput _ = False - -isTestCycles :: CLasHAnn -> Bool -isTestCycles TestCycles = True -isTestCycles _ = False \ No newline at end of file diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" deleted file mode 100644 index eabb004..0000000 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ /dev/null @@ -1,131 +0,0 @@ -{-# 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/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" deleted file mode 100644 index d85b25b..0000000 --- "a/c\316\273ash/CLasH/Utils.hs" +++ /dev/null @@ -1,69 +0,0 @@ -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/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" deleted file mode 100644 index cd01675..0000000 --- "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" +++ /dev/null @@ -1,95 +0,0 @@ --- --- 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/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" deleted file mode 100644 index ca2a7fb..0000000 --- "a/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" +++ /dev/null @@ -1,80 +0,0 @@ -{-# 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/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" deleted file mode 100644 index 2bb688b..0000000 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ /dev/null @@ -1,463 +0,0 @@ -{-# 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/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" deleted file mode 100644 index f1fe6ba..0000000 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ /dev/null @@ -1,249 +0,0 @@ -{-# 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/c\316\273ash/CLasH/Utils/HsTools.hs" "b/c\316\273ash/CLasH/Utils/HsTools.hs" deleted file mode 100644 index 22b1382..0000000 --- "a/c\316\273ash/CLasH/Utils/HsTools.hs" +++ /dev/null @@ -1,212 +0,0 @@ -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/c\316\273ash/CLasH/Utils/Pretty.hs" "b/c\316\273ash/CLasH/Utils/Pretty.hs" deleted file mode 100644 index df78ad9..0000000 --- "a/c\316\273ash/CLasH/Utils/Pretty.hs" +++ /dev/null @@ -1,81 +0,0 @@ -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/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" deleted file mode 100644 index 56342fc..0000000 --- "a/c\316\273ash/CLasH/VHDL.hs" +++ /dev/null @@ -1,99 +0,0 @@ --- --- 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/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" deleted file mode 100644 index c70ca71..0000000 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ /dev/null @@ -1,399 +0,0 @@ -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/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" deleted file mode 100644 index 3d31529..0000000 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ /dev/null @@ -1,1634 +0,0 @@ -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/c\316\273ash/CLasH/VHDL/Testbench.hs" "b/c\316\273ash/CLasH/VHDL/Testbench.hs" deleted file mode 100644 index fa2e9dc..0000000 --- "a/c\316\273ash/CLasH/VHDL/Testbench.hs" +++ /dev/null @@ -1,173 +0,0 @@ --- --- 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/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" deleted file mode 100644 index 165b1ef..0000000 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ /dev/null @@ -1,704 +0,0 @@ -{-# 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/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" deleted file mode 100644 index 38ccc97..0000000 --- "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" +++ /dev/null @@ -1,24 +0,0 @@ --- --- 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/c\316\273ash/Data/Param/Index.hs" "b/c\316\273ash/Data/Param/Index.hs" deleted file mode 100644 index f31b1f8..0000000 --- "a/c\316\273ash/Data/Param/Index.hs" +++ /dev/null @@ -1,104 +0,0 @@ -{-# 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/c\316\273ash/Data/Param/Integer.hs" "b/c\316\273ash/Data/Param/Integer.hs" deleted file mode 100644 index b4b1ec8..0000000 --- "a/c\316\273ash/Data/Param/Integer.hs" +++ /dev/null @@ -1,13 +0,0 @@ -module Data.Param.Integer - ( Signed(..) - , Unsigned(..) - , Index (..) - ) where - -import Types - -newtype (NaturalT nT) => Signed nT = Signed Integer - -newtype (NaturalT nT) => Unsigned nT = Unsigned Integer - -newtype (NaturalT upper) => Index upper = Index Integer \ No newline at end of file diff --git "a/c\316\273ash/Data/Param/Signed.hs" "b/c\316\273ash/Data/Param/Signed.hs" deleted file mode 100644 index 26ac677..0000000 --- "a/c\316\273ash/Data/Param/Signed.hs" +++ /dev/null @@ -1,172 +0,0 @@ -{-# 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/c\316\273ash/Data/Param/Unsigned.hs" "b/c\316\273ash/Data/Param/Unsigned.hs" deleted file mode 100644 index aae032d..0000000 --- "a/c\316\273ash/Data/Param/Unsigned.hs" +++ /dev/null @@ -1,157 +0,0 @@ -{-# 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/c\316\273ash/Data/Param/Vector.hs" "b/c\316\273ash/Data/Param/Vector.hs" deleted file mode 100644 index 32218be..0000000 --- "a/c\316\273ash/Data/Param/Vector.hs" +++ /dev/null @@ -1,316 +0,0 @@ -{-# 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/c\316\273ash/LICENSE" "b/c\316\273ash/LICENSE" deleted file mode 100644 index 23ebcfd..0000000 --- "a/c\316\273ash/LICENSE" +++ /dev/null @@ -1,25 +0,0 @@ -Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - * Neither the name of the copyright holder nor the - names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY -EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR -BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN -IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git "a/c\316\273ash/clash.cabal" "b/c\316\273ash/clash.cabal" deleted file mode 100644 index 2eb3058..0000000 --- "a/c\316\273ash/clash.cabal" +++ /dev/null @@ -1,55 +0,0 @@ -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 - - diff --git "a/c\316\273ash/ghc-stage" "b/c\316\273ash/ghc-stage" deleted file mode 100644 index 9a7456b..0000000 --- "a/c\316\273ash/ghc-stage" +++ /dev/null @@ -1,2 +0,0 @@ -2 -