packages feed

clash (empty) → 0.1

raw patch · 28 files changed

+6838/−0 lines, 28 filesdep +basedep +containersdep +data-accessorsetup-changed

Dependencies added: base, containers, data-accessor, data-accessor-template, data-accessor-transformers, directory, filepath, ghc, haskell98, pretty, prettyclass, syb, template-haskell, tfp, th-lift, time, transformers, vhdl

Files

+ CLasH/HardwareTypes.hs view
@@ -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
+ CLasH/Normalize.hs view
@@ -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
+ CLasH/Normalize/NormalizeTools.hs view
@@ -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
+ CLasH/Normalize/NormalizeTypes.hs view
@@ -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
+ CLasH/Translator.hs view
@@ -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:
+ CLasH/Translator/Annotations.hs view
@@ -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
+ CLasH/Translator/TranslatorTypes.hs view
@@ -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:
+ CLasH/Utils.hs view
@@ -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
+ CLasH/Utils/Core/BinderTools.hs view
@@ -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
+ CLasH/Utils/Core/CoreShow.hs view
@@ -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) ++ "__"
+ CLasH/Utils/Core/CoreTools.hs view
@@ -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)
+ CLasH/Utils/GhcTools.hs view
@@ -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"
+ CLasH/Utils/HsTools.hs view
@@ -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 "<interactive>") 1 0+    let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)+    return thing++-- | This function imports the module with the given name, for the renamer /+-- typechecker to use. It also imports any "orphans" and "family instances"+-- from modules included by this module, but not the actual modules+-- themselves. I'm not 100% sure how this works, but it seems that any+-- functions defined in included modules are available just by loading the+-- original module, and by doing this orphan stuff, any (type family or class)+-- instances are available as well.+--+-- Most of the code is based on tcRnImports and rnImportDecl, but those+-- functions do a lot more (which I hope we won't need...).+importModule :: Module.ModuleName -> TcRnTypes.RnM ()+importModule mod = do+  let reason = Outputable.text "Hardcoded import" -- Used for trace output+  let pkg = Nothing+  -- Load the interface.+  iface <- LoadIface.loadSrcInterface reason mod False pkg+  -- Load orphan an familiy instance dependencies as well. I think these+  -- dependencies are needed for the type checker to know all instances. Any+  -- other instances (on other packages) are only useful to the+  -- linker, so we can probably safely ignore them here. Dependencies within+  -- the same package are also listed in deps, but I'm not so sure what to do+  -- with them.+  let deps = HscTypes.mi_deps iface+  let orphs = HscTypes.dep_orphs deps+  let finsts = HscTypes.dep_finsts deps+  LoadIface.loadOrphanModules orphs False+  LoadIface.loadOrphanModules finsts True
+ CLasH/Utils/Pretty.hs view
@@ -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
+ CLasH/VHDL.hs view
@@ -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])
+ CLasH/VHDL/Constants.hs view
@@ -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
+ CLasH/VHDL/Generate.hs view
@@ -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"))+  ]
+ CLasH/VHDL/Testbench.hs view
@@ -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)
+ CLasH/VHDL/VHDLTools.hs view
@@ -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)
+ CLasH/VHDL/VHDLTypes.hs view
@@ -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:
+ Data/Param/Index.hs view
@@ -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
+ Data/Param/Integer.hs view
@@ -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
+ Data/Param/Signed.hs view
@@ -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
+ Data/Param/Unsigned.hs view
@@ -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
+ Data/Param/Vector.hs view
@@ -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+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ clash.cabal view
@@ -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+                    +