--- /dev/null
+{-# LANGUAGE PackageImports #-}
+--
+-- 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 (normalizeModule) where
+
+-- Standard modules
+import Debug.Trace
+import qualified Maybe
+import qualified "transformers" Control.Monad.Trans as Trans
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Data.Map as Map
+import qualified Data.Monoid as Monoid
+import Data.Accessor
+
+-- GHC API
+import CoreSyn
+import qualified UniqSupply
+import qualified CoreUtils
+import qualified Type
+import qualified TcType
+import qualified Id
+import qualified Var
+import qualified VarSet
+import qualified NameSet
+import qualified CoreFVs
+import qualified CoreUtils
+import qualified MkCore
+import qualified HscTypes
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import CLasH.Normalize.NormalizeTypes
+import CLasH.Normalize.NormalizeTools
+import CLasH.VHDL.VHDLTypes
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.Pretty
+
+--------------------------------
+-- Start of transformations
+--------------------------------
+
+--------------------------------
+-- η abstraction
+--------------------------------
+eta, etatop :: Transform
+eta expr | is_fun expr && not (is_lam expr) = do
+ let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
+ id <- mkInternalVar "param" arg_ty
+ change (Lam id (App expr (Var id)))
+-- Leave all other expressions unchanged
+eta e = return e
+etatop = notappargs ("eta", eta)
+
+--------------------------------
+-- β-reduction
+--------------------------------
+beta, betatop :: Transform
+-- Substitute arg for x in expr
+beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Propagate the application into the let
+beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
+-- Propagate the application into each of the alternatives
+beta (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
+beta expr = return expr
+-- Perform this transform everywhere
+betatop = everywhere ("beta", beta)
+
+--------------------------------
+-- Cast propagation
+--------------------------------
+-- Try to move casts as much downward as possible.
+castprop, castproptop :: Transform
+castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
+castprop 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 expr = return expr
+-- Perform this transform everywhere
+castproptop = everywhere ("castprop", castprop)
+
+--------------------------------
+-- let recursification
+--------------------------------
+letrec, letrectop :: Transform
+letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
+-- Leave all other expressions unchanged
+letrec expr = return expr
+-- Perform this transform everywhere
+letrectop = everywhere ("letrec", letrec)
+
+--------------------------------
+-- let simplification
+--------------------------------
+letsimpl, letsimpltop :: Transform
+-- Put the "in ..." value of a let in its own binding, but not when the
+-- expression is applicable (to prevent loops with inlinefun).
+letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
+ local_var <- Trans.lift $ is_local_var res
+ if not local_var
+ then do
+ -- If the result is not a local var already (to prevent loops with
+ -- ourselves), extract it.
+ id <- mkInternalVar "foo" (CoreUtils.exprType res)
+ let bind = (id, res)
+ change $ Let (Rec (bind:binds)) (Var id)
+ else
+ -- If the result is already a local var, don't extract it.
+ return expr
+
+-- Leave all other expressions unchanged
+letsimpl expr = return expr
+-- Perform this transform everywhere
+letsimpltop = everywhere ("letsimpl", letsimpl)
+
+--------------------------------
+-- let flattening
+--------------------------------
+letflat, letflattop :: Transform
+letflat (Let (Rec binds) expr) = do
+ -- Turn each binding into a list of bindings (possibly containing just one
+ -- element, of course)
+ bindss <- Monad.mapM flatbind binds
+ -- Concat all the bindings
+ let binds' = concat bindss
+ -- 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, expr) = return [(b, expr)]
+-- Leave all other expressions unchanged
+letflat expr = return expr
+-- Perform this transform everywhere
+letflattop = everywhere ("letflat", letflat)
+
+--------------------------------
+-- Simple let binding removal
+--------------------------------
+-- Remove a = b bindings from let expressions everywhere
+letremovetop :: Transform
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
+
+--------------------------------
+-- Function inlining
+--------------------------------
+-- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
+-- expressions everywhere. This means that any value that still needs to be
+-- applied to something else (polymorphic values need to be applied to a
+-- Type) will be inlined, and will eventually be applied to all their
+-- arguments.
+--
+-- 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 function 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 primitive.
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
+
+--------------------------------
+-- Scrutinee simplification
+--------------------------------
+scrutsimpl,scrutsimpltop :: Transform
+-- Don't touch scrutinees that are already simple
+scrutsimpl expr@(Case (Var _) _ _ _) = return expr
+-- Replace all other cases with a let that binds the scrutinee and a new
+-- simple scrutinee, but not when the scrutinee is applicable (to prevent
+-- loops with inlinefun, though I don't think a scrutinee can be
+-- applicable...)
+scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
+ id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
+ change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+-- Leave all other expressions unchanged
+scrutsimpl expr = return expr
+-- Perform this transform everywhere
+scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
+
+--------------------------------
+-- Case binder wildening
+--------------------------------
+casewild, casewildtop :: Transform
+casewild expr@(Case scrut b ty alts) = 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 = (Let (Rec bindings) (Case scrut b 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 || length alts == 1 && length bindings == 1 then return expr else change newlet
+ where
+ -- 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
+ bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
+ let bindings = Maybe.catMaybes bindings_maybe
+ -- We replace the binders with wild binders only. We can leave expr
+ -- unchanged, since the new bindings bind the same vars as the original
+ -- did.
+ let newalt = (con, wildbndrs, expr)
+ return (bindings, newalt)
+ where
+ -- Make all binders wild
+ 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
+ -- Creates a case statement to retrieve the ith element from the scrutinee
+ -- and binds that to b.
+ mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
+ mkextracts b i =
+ if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b)
+ -- Don't create extra bindings for binders that are already wild
+ -- (e.g. not in the free variables of expr, so unused), or for
+ -- binders that bind function types (to prevent loops with
+ -- inlinefun).
+ then return Nothing
+ else do
+ -- Create on new binder that will actually capture a value in this
+ -- case statement, and return it
+ let bty = (Id.idType b)
+ id <- mkInternalVar "sel" bty
+ let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
+ return $ Just (b, Case scrut b bty [(con, binders, Var id)])
+-- Leave all other expressions unchanged
+casewild expr = return expr
+-- Perform this transform everywhere
+casewildtop = everywhere ("casewild", casewild)
+
+--------------------------------
+-- Case value simplification
+--------------------------------
+casevalsimpl, casevalsimpltop :: Transform
+casevalsimpl expr@(Case scrut b ty alts) = do
+ -- Try to simplify each alternative, resulting in an optional binding and a
+ -- new alternative.
+ (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
+ let bindings = Maybe.catMaybes bindings_maybe
+ -- Create a new let around the case, that binds of the cases values.
+ let newlet = Let (Rec bindings) (Case scrut b ty alts')
+ -- If there were no values that needed and allowed simplification, don't
+ -- change the case.
+ if null bindings then return expr else change newlet
+ where
+ doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
+ -- Don't simplify values that are already simple
+ doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
+ -- Simplify each alt by creating a new id, binding the case value to it and
+ -- replacing the case value with that id. Only do this when the case value
+ -- does not use any of the binders bound by this alternative, for that would
+ -- cause those binders to become unbound when moving the value outside of
+ -- the case statement. Also, don't create a binding for applicable
+ -- expressions, to prevent loops with inlinefun.
+ doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do
+ id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
+ -- We don't flag a change here, since casevalsimpl will do that above
+ -- based on Just we return here.
+ return $ (Just (id, expr), (con, bndrs, Var id))
+ -- Find if any of the binders are used by expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+ -- Don't simplify anything else
+ doalt alt = return (Nothing, alt)
+-- Leave all other expressions unchanged
+casevalsimpl expr = return expr
+-- Perform this transform everywhere
+casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
+
+--------------------------------
+-- Case removal
+--------------------------------
+-- Remove case statements that have only a single alternative and only wild
+-- binders.
+caseremove, caseremovetop :: Transform
+-- Replace a useless case by the value of its single alternative
+caseremove (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` bndrs))) expr
+-- Leave all other expressions unchanged
+caseremove expr = return expr
+-- Perform this transform everywhere
+caseremovetop = everywhere ("caseremove", caseremove)
+
+--------------------------------
+-- Argument extraction
+--------------------------------
+-- Make sure that all arguments of a representable type are simple variables.
+appsimpl, appsimpltop :: 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 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 <- mkInternalVar "arg" (CoreUtils.exprType arg)
+ change $ Let (Rec [(id, arg)]) (App f (Var id))
+ else -- Leave non-representable arguments unchanged
+ return expr
+-- Leave all other expressions unchanged
+appsimpl expr = return expr
+-- Perform this transform everywhere
+appsimpltop = everywhere ("appsimpl", appsimpl)
+
+--------------------------------
+-- Function-typed argument propagation
+--------------------------------
+-- Remove all applications to function-typed arguments, by duplication the
+-- function called with the function-typed parameter replaced by the free
+-- variables of the argument passed in.
+argprop, argproptop :: 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 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 <- mkFunction f newbody
+ -- 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 && (not $ var `elem` 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
+ 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.
+ -- TODO: preserve original naming?
+ id <- 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 expr = return expr
+-- Perform this transform everywhere
+argproptop = everywhere ("argprop", argprop)
+
+--------------------------------
+-- 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 inlinefun,
+-- since that only inlines local let bindings, not top level bindings.
+funextract, funextracttop :: Transform
+funextract 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 <- 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 expr = return expr
+-- Perform this transform everywhere
+funextracttop = everywhere ("funextract", funextract)
+
+--------------------------------
+-- End of transformations
+--------------------------------
+
+
+
+
+-- What transforms to run?
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
+
+-- Turns the given bind into VHDL
+normalizeModule ::
+ HscTypes.HscEnv
+ -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use
+ -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
+ -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
+ -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
+ -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
+
+normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do
+ -- Put all the bindings in this module in the tsBindings map
+ putA tsBindings (Map.fromList bindings)
+ -- (Recursively) normalize each of the requested bindings
+ mapM normalizeBind generate_for
+ -- Get all initial bindings and the ones we produced
+ bindings_map <- getA tsBindings
+ let bindings = Map.assocs bindings_map
+ normalized_bindings <- getA tsNormalized
+ typestate <- getA tsType
+ -- But return only the normalized bindings
+ return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)
+
+normalizeBind :: CoreBndr -> TransformSession ()
+normalizeBind bndr =
+ -- Don't normalize global variables, these should be either builtin
+ -- functions or data constructors.
+ Monad.when (Var.isLocalId bndr) $ do
+ -- Skip binders that have a polymorphic type, since it's impossible to
+ -- create polymorphic hardware.
+ if is_poly (Var bndr)
+ then
+ -- This should really only happen at the top level... TODO: Give
+ -- a different error if this happens down in the recursion.
+ error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
+ else do
+ normalized_funcs <- getA tsNormalized
+ -- See if this function was normalized already
+ if VarSet.elemVarSet bndr normalized_funcs
+ then
+ -- Yup, don't do it again
+ return ()
+ else do
+ -- Nope, note that it has been and do it.
+ modA tsNormalized (flip VarSet.extendVarSet bndr)
+ expr_maybe <- getGlobalBind bndr
+ case expr_maybe of
+ Just expr -> do
+ -- Introduce an empty Let at the top level, so there will always be
+ -- a let in the expression (none of the transformations will remove
+ -- the last let).
+ let expr' = Let (Rec []) expr
+ -- Normalize this expression
+ trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr'
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ -- And store the normalized version in the session
+ modA tsBindings (Map.insert bndr expr')
+ -- Find all vars used with a function type. All of these should be global
+ -- binders (i.e., functions used), since any local binders with a function
+ -- type should have been inlined already.
+ bndrs <- getGlobalBinders
+ let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
+ let used_funcs = VarSet.varSetElems used_funcs_set
+ -- Process each of the used functions recursively
+ mapM normalizeBind used_funcs
+ return ()
+ -- We don't have a value for this binder. This really shouldn't
+ -- happen for local id's...
+ Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
+++ /dev/null
-{-# LANGUAGE PackageImports #-}
---
--- 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 Normalize (normalizeModule) where
-
--- Standard modules
-import Debug.Trace
-import qualified Maybe
-import qualified "transformers" Control.Monad.Trans as Trans
-import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Map as Map
-import qualified Data.Monoid as Monoid
-import Data.Accessor
-
--- GHC API
-import CoreSyn
-import qualified UniqSupply
-import qualified CoreUtils
-import qualified Type
-import qualified TcType
-import qualified Id
-import qualified Var
-import qualified VarSet
-import qualified NameSet
-import qualified CoreFVs
-import qualified CoreUtils
-import qualified MkCore
-import qualified HscTypes
-import Outputable ( showSDoc, ppr, nest )
-
--- Local imports
-import NormalizeTypes
-import NormalizeTools
-import VHDLTypes
-import CoreTools
-import Pretty
-
---------------------------------
--- Start of transformations
---------------------------------
-
---------------------------------
--- η abstraction
---------------------------------
-eta, etatop :: Transform
-eta expr | is_fun expr && not (is_lam expr) = do
- let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
- id <- mkInternalVar "param" arg_ty
- change (Lam id (App expr (Var id)))
--- Leave all other expressions unchanged
-eta e = return e
-etatop = notappargs ("eta", eta)
-
---------------------------------
--- β-reduction
---------------------------------
-beta, betatop :: Transform
--- Substitute arg for x in expr
-beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
--- Propagate the application into the let
-beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
--- Propagate the application into each of the alternatives
-beta (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
-beta expr = return expr
--- Perform this transform everywhere
-betatop = everywhere ("beta", beta)
-
---------------------------------
--- Cast propagation
---------------------------------
--- Try to move casts as much downward as possible.
-castprop, castproptop :: Transform
-castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
-castprop 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 expr = return expr
--- Perform this transform everywhere
-castproptop = everywhere ("castprop", castprop)
-
---------------------------------
--- let recursification
---------------------------------
-letrec, letrectop :: Transform
-letrec (Let (NonRec b expr) res) = change $ Let (Rec [(b, expr)]) res
--- Leave all other expressions unchanged
-letrec expr = return expr
--- Perform this transform everywhere
-letrectop = everywhere ("letrec", letrec)
-
---------------------------------
--- let simplification
---------------------------------
-letsimpl, letsimpltop :: Transform
--- Put the "in ..." value of a let in its own binding, but not when the
--- expression is applicable (to prevent loops with inlinefun).
-letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
- local_var <- Trans.lift $ is_local_var res
- if not local_var
- then do
- -- If the result is not a local var already (to prevent loops with
- -- ourselves), extract it.
- id <- mkInternalVar "foo" (CoreUtils.exprType res)
- let bind = (id, res)
- change $ Let (Rec (bind:binds)) (Var id)
- else
- -- If the result is already a local var, don't extract it.
- return expr
-
--- Leave all other expressions unchanged
-letsimpl expr = return expr
--- Perform this transform everywhere
-letsimpltop = everywhere ("letsimpl", letsimpl)
-
---------------------------------
--- let flattening
---------------------------------
-letflat, letflattop :: Transform
-letflat (Let (Rec binds) expr) = do
- -- Turn each binding into a list of bindings (possibly containing just one
- -- element, of course)
- bindss <- Monad.mapM flatbind binds
- -- Concat all the bindings
- let binds' = concat bindss
- -- 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, expr) = return [(b, expr)]
--- Leave all other expressions unchanged
-letflat expr = return expr
--- Perform this transform everywhere
-letflattop = everywhere ("letflat", letflat)
-
---------------------------------
--- Simple let binding removal
---------------------------------
--- Remove a = b bindings from let expressions everywhere
-letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
-
---------------------------------
--- Function inlining
---------------------------------
--- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
--- expressions everywhere. This means that any value that still needs to be
--- applied to something else (polymorphic values need to be applied to a
--- Type) will be inlined, and will eventually be applied to all their
--- arguments.
---
--- 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 function 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 primitive.
-inlinenonreptop :: Transform
-inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
-
---------------------------------
--- Scrutinee simplification
---------------------------------
-scrutsimpl,scrutsimpltop :: Transform
--- Don't touch scrutinees that are already simple
-scrutsimpl expr@(Case (Var _) _ _ _) = return expr
--- Replace all other cases with a let that binds the scrutinee and a new
--- simple scrutinee, but not when the scrutinee is applicable (to prevent
--- loops with inlinefun, though I don't think a scrutinee can be
--- applicable...)
-scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
- id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
- change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
--- Leave all other expressions unchanged
-scrutsimpl expr = return expr
--- Perform this transform everywhere
-scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
-
---------------------------------
--- Case binder wildening
---------------------------------
-casewild, casewildtop :: Transform
-casewild expr@(Case scrut b ty alts) = 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 = (Let (Rec bindings) (Case scrut b 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 || length alts == 1 && length bindings == 1 then return expr else change newlet
- where
- -- 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
- bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
- let bindings = Maybe.catMaybes bindings_maybe
- -- We replace the binders with wild binders only. We can leave expr
- -- unchanged, since the new bindings bind the same vars as the original
- -- did.
- let newalt = (con, wildbndrs, expr)
- return (bindings, newalt)
- where
- -- Make all binders wild
- 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
- -- Creates a case statement to retrieve the ith element from the scrutinee
- -- and binds that to b.
- mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
- mkextracts b i =
- if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b)
- -- Don't create extra bindings for binders that are already wild
- -- (e.g. not in the free variables of expr, so unused), or for
- -- binders that bind function types (to prevent loops with
- -- inlinefun).
- then return Nothing
- else do
- -- Create on new binder that will actually capture a value in this
- -- case statement, and return it
- let bty = (Id.idType b)
- id <- mkInternalVar "sel" bty
- let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
- return $ Just (b, Case scrut b bty [(con, binders, Var id)])
--- Leave all other expressions unchanged
-casewild expr = return expr
--- Perform this transform everywhere
-casewildtop = everywhere ("casewild", casewild)
-
---------------------------------
--- Case value simplification
---------------------------------
-casevalsimpl, casevalsimpltop :: Transform
-casevalsimpl expr@(Case scrut b ty alts) = do
- -- Try to simplify each alternative, resulting in an optional binding and a
- -- new alternative.
- (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
- let bindings = Maybe.catMaybes bindings_maybe
- -- Create a new let around the case, that binds of the cases values.
- let newlet = Let (Rec bindings) (Case scrut b ty alts')
- -- If there were no values that needed and allowed simplification, don't
- -- change the case.
- if null bindings then return expr else change newlet
- where
- doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
- -- Don't simplify values that are already simple
- doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
- -- Simplify each alt by creating a new id, binding the case value to it and
- -- replacing the case value with that id. Only do this when the case value
- -- does not use any of the binders bound by this alternative, for that would
- -- cause those binders to become unbound when moving the value outside of
- -- the case statement. Also, don't create a binding for applicable
- -- expressions, to prevent loops with inlinefun.
- doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do
- id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
- -- We don't flag a change here, since casevalsimpl will do that above
- -- based on Just we return here.
- return $ (Just (id, expr), (con, bndrs, Var id))
- -- Find if any of the binders are used by expr
- where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
- -- Don't simplify anything else
- doalt alt = return (Nothing, alt)
--- Leave all other expressions unchanged
-casevalsimpl expr = return expr
--- Perform this transform everywhere
-casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
-
---------------------------------
--- Case removal
---------------------------------
--- Remove case statements that have only a single alternative and only wild
--- binders.
-caseremove, caseremovetop :: Transform
--- Replace a useless case by the value of its single alternative
-caseremove (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` bndrs))) expr
--- Leave all other expressions unchanged
-caseremove expr = return expr
--- Perform this transform everywhere
-caseremovetop = everywhere ("caseremove", caseremove)
-
---------------------------------
--- Argument extraction
---------------------------------
--- Make sure that all arguments of a representable type are simple variables.
-appsimpl, appsimpltop :: 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 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 <- mkInternalVar "arg" (CoreUtils.exprType arg)
- change $ Let (Rec [(id, arg)]) (App f (Var id))
- else -- Leave non-representable arguments unchanged
- return expr
--- Leave all other expressions unchanged
-appsimpl expr = return expr
--- Perform this transform everywhere
-appsimpltop = everywhere ("appsimpl", appsimpl)
-
---------------------------------
--- Function-typed argument propagation
---------------------------------
--- Remove all applications to function-typed arguments, by duplication the
--- function called with the function-typed parameter replaced by the free
--- variables of the argument passed in.
-argprop, argproptop :: 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 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 <- mkFunction f newbody
- -- 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 && (not $ var `elem` 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
- 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.
- -- TODO: preserve original naming?
- id <- 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 expr = return expr
--- Perform this transform everywhere
-argproptop = everywhere ("argprop", argprop)
-
---------------------------------
--- 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 inlinefun,
--- since that only inlines local let bindings, not top level bindings.
-funextract, funextracttop :: Transform
-funextract 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 <- 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 expr = return expr
--- Perform this transform everywhere
-funextracttop = everywhere ("funextract", funextract)
-
---------------------------------
--- End of transformations
---------------------------------
-
-
-
-
--- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
-
--- Turns the given bind into VHDL
-normalizeModule ::
- HscTypes.HscEnv
- -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use
- -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
- -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
- -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
- -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
-
-normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do
- -- Put all the bindings in this module in the tsBindings map
- putA tsBindings (Map.fromList bindings)
- -- (Recursively) normalize each of the requested bindings
- mapM normalizeBind generate_for
- -- Get all initial bindings and the ones we produced
- bindings_map <- getA tsBindings
- let bindings = Map.assocs bindings_map
- normalized_bindings <- getA tsNormalized
- typestate <- getA tsType
- -- But return only the normalized bindings
- return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)
-
-normalizeBind :: CoreBndr -> TransformSession ()
-normalizeBind bndr =
- -- Don't normalize global variables, these should be either builtin
- -- functions or data constructors.
- Monad.when (Var.isLocalId bndr) $ do
- -- Skip binders that have a polymorphic type, since it's impossible to
- -- create polymorphic hardware.
- if is_poly (Var bndr)
- then
- -- This should really only happen at the top level... TODO: Give
- -- a different error if this happens down in the recursion.
- error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
- else do
- normalized_funcs <- getA tsNormalized
- -- See if this function was normalized already
- if VarSet.elemVarSet bndr normalized_funcs
- then
- -- Yup, don't do it again
- return ()
- else do
- -- Nope, note that it has been and do it.
- modA tsNormalized (flip VarSet.extendVarSet bndr)
- expr_maybe <- getGlobalBind bndr
- case expr_maybe of
- Just expr -> do
- -- Introduce an empty Let at the top level, so there will always be
- -- a let in the expression (none of the transformations will remove
- -- the last let).
- let expr' = Let (Rec []) expr
- -- Normalize this expression
- trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr'
- trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
- -- And store the normalized version in the session
- modA tsBindings (Map.insert bndr expr')
- -- Find all vars used with a function type. All of these should be global
- -- binders (i.e., functions used), since any local binders with a function
- -- type should have been inlined already.
- bndrs <- getGlobalBinders
- let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
- let used_funcs = VarSet.varSetElems used_funcs_set
- -- Process each of the used functions recursively
- mapM normalizeBind used_funcs
- return ()
- -- We don't have a value for this binder. This really shouldn't
- -- happen for local id's...
- Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
--
-- This module provides functions for program transformations.
--
-module NormalizeTools where
+module CLasH.Normalize.NormalizeTools where
-- Standard modules
import Debug.Trace
import qualified List
import Outputable ( showSDoc, ppr, nest )
-- Local imports
-import NormalizeTypes
-import Pretty
-import VHDLTypes
-import qualified VHDLTools
+import CLasH.Normalize.NormalizeTypes
+import CLasH.Utils.Pretty
+import CLasH.VHDL.VHDLTypes
+import qualified CLasH.VHDL.VHDLTools as VHDLTools
-- 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,
{-# LANGUAGE TemplateHaskell #-}
-module NormalizeTypes where
+module CLasH.Normalize.NormalizeTypes where
-- Standard modules
import Outputable ( Outputable, showSDoc, ppr )
-- Local imports
-import CoreShow
-import Pretty
-import VHDLTypes -- For TypeState
+import CLasH.Utils.Core.CoreShow
+import CLasH.Utils.Pretty
+import CLasH.VHDL.VHDLTypes -- For TypeState
data TransformState = TransformState {
tsUniqSupply_ :: UniqSupply.UniqSupply
--- /dev/null
+module CLasH.Translator where
+
+import qualified Directory
+import qualified System.FilePath as FilePath
+import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
+import GHC hiding (loadModule, sigName)
+import CoreSyn
+import qualified CoreUtils
+import qualified Var
+import qualified Type
+import qualified TyCon
+import qualified DataCon
+import qualified HscMain
+import qualified SrcLoc
+import qualified FastString
+import qualified Maybe
+import qualified Module
+import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State as State
+import Name
+import qualified Data.Map as Map
+import Data.Accessor
+import Data.Generics
+import NameEnv ( lookupNameEnv )
+import qualified HscTypes
+import HscTypes ( cm_binds, cm_types )
+import MonadUtils ( liftIO )
+import Outputable ( showSDoc, ppr, showSDocDebug )
+import GHC.Paths ( libdir )
+import DynFlags ( defaultDynFlags )
+import qualified UniqSupply
+import List ( find )
+import qualified List
+import qualified Monad
+
+-- The following modules come from the ForSyDe project. They are really
+-- internal modules, so ForSyDe.cabal has to be modified prior to installing
+-- ForSyDe to get access to these modules.
+import qualified Language.VHDL.AST as AST
+import qualified Language.VHDL.FileIO
+import qualified Language.VHDL.Ppr as Ppr
+-- This is needed for rendering the pretty printed VHDL
+import Text.PrettyPrint.HughesPJ (render)
+
+import CLasH.Translator.TranslatorTypes
+import CLasH.Utils.Pretty
+import CLasH.Normalize
+import CLasH.VHDL.VHDLTypes
+import qualified CLasH.VHDL as VHDL
+
+makeVHDL :: String -> String -> Bool -> IO ()
+makeVHDL filename name stateful = do
+ -- Load the module
+ (core, env) <- loadModule filename
+ -- Translate to VHDL
+ vhdl <- moduleToVHDL env core [(name, stateful)]
+ -- Write VHDL to file
+ let dir = "./vhdl/" ++ name ++ "/"
+ prepareDir dir
+ mapM (writeVHDL dir) vhdl
+ return ()
+
+listBindings :: String -> IO [()]
+listBindings filename = do
+ (core, env) <- loadModule filename
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ mapM (listBinding) binds
+
+listBinding :: (CoreBndr, CoreExpr) -> IO ()
+listBinding (b, e) = do
+ putStr "\nBinder: "
+ putStr $ show b
+ putStr "\nExpression: \n"
+ putStr $ prettyShow e
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr e
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr $ CoreUtils.exprType e
+ putStr "\n\n"
+
+-- | Show the core structure of the given binds in the given file.
+listBind :: String -> String -> IO ()
+listBind filename name = do
+ (core, env) <- loadModule filename
+ let [(b, expr)] = findBinds core [name]
+ putStr "\n"
+ putStr $ prettyShow expr
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr expr
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
+ putStr "\n\n"
+
+-- | Translate the binds with the given names from the given core module to
+-- VHDL. The Bool in the tuple makes the function stateful (True) or
+-- stateless (False).
+moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env core list = do
+ let (names, statefuls) = unzip list
+ let binds = map fst $ findBinds core names
+ -- 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'
+ -- Turn bind into VHDL
+ let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+ let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
+ let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ return vhdl
+ where
+
+-- | 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
+ exists <- Directory.doesDirectoryExist dir
+ Monad.unless exists $ Directory.createDirectory 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
+ Language.VHDL.FileIO.writeDesignFile vhdl fname
+
+-- | Loads the given file and turns it into a core module.
+loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
+loadModule filename =
+ defaultErrorHandler defaultDynFlags $ do
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ --target <- guessTarget "adder.hs" Nothing
+ --liftIO (print (showSDoc (ppr (target))))
+ --liftIO $ printTarget target
+ --setTargets [target]
+ --load LoadAllTargets
+ --core <- GHC.compileToCoreSimplified "Adders.hs"
+ core <- GHC.compileToCoreModule filename
+ env <- GHC.getSession
+ return (core, env)
+
+-- | Extracts the named binds from the given module.
+findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
+findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
+
+-- | Extract a named bind from the given list of binds
+findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
+findBind binds lookfor =
+ -- This ignores Recs and compares the name of the bind with lookfor,
+ -- disregarding any namespaces in OccName and extra attributes in Name and
+ -- Var.
+ find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
+
+-- | Flattens the given bind into the given signature and adds it to the
+-- session. Then (recursively) finds any functions it uses and does the same
+-- with them.
+-- flattenBind ::
+-- HsFunction -- The signature to flatten into
+-- -> (CoreBndr, CoreExpr) -- The bind to flatten
+-- -> TranslatorState ()
+--
+-- flattenBind hsfunc bind@(var, expr) = do
+-- -- Flatten the function
+-- let flatfunc = flattenFunction hsfunc bind
+-- -- Propagate state variables
+-- let flatfunc' = propagateState hsfunc flatfunc
+-- -- Store the flat function in the session
+-- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
+-- -- Flatten any functions used
+-- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
+-- mapM_ resolvFunc used_hsfuncs
+
+-- | Decide which incoming state variables will become state in the
+-- given function, and which will be propagate to other applied
+-- functions.
+-- propagateState ::
+-- HsFunction
+-- -> FlatFunction
+-- -> FlatFunction
+--
+-- propagateState hsfunc flatfunc =
+-- flatfunc {flat_defs = apps', flat_sigs = sigs'}
+-- where
+-- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+-- states' = zip olds news
+-- -- Find all signals used by all sigdefs
+-- uses = concatMap sigDefUses (flat_defs flatfunc)
+-- -- Find all signals that are used more than once (is there a
+-- -- prettier way to do this?)
+-- multiple_uses = uses List.\\ (List.nub uses)
+-- -- Find the states whose "old state" signal is used only once
+-- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+-- -- See if these single use states can be propagated
+-- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
+-- substate_sigs = concat substate_sigss
+-- -- Mark any propagated state signals as SigSubState
+-- sigs' = map
+-- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+-- (flat_sigs flatfunc)
+
+-- | Propagate the state into a single function application.
+-- propagateState' ::
+-- [(SignalId, SignalId)]
+-- -- ^ TODO
+-- -> SigDef -- ^ The SigDef to process.
+-- -> ([SignalId], SigDef)
+-- -- ^ Any signal ids that should become substates,
+-- -- and the resulting application.
+--
+-- propagateState' states def =
+-- if (is_FApp def) then
+-- (our_old ++ our_new, def {appFunc = hsfunc'})
+-- else
+-- ([], def)
+-- where
+-- hsfunc = appFunc def
+-- args = appArgs def
+-- res = appRes def
+-- our_states = filter our_state states
+-- -- A state signal belongs in this function if the old state is
+-- -- passed in, and the new state returned
+-- our_state (old, new) =
+-- any (old `Foldable.elem`) args
+-- && new `Foldable.elem` res
+-- (our_old, our_new) = unzip our_states
+-- -- Mark the result
+-- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+-- res' = fmap (mark_state (zip our_new [0..])) zipped_res
+-- -- Mark the args
+-- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+-- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+-- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+--
+-- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+-- mark_state states (id, use) =
+-- case lookup id states of
+-- Nothing -> use
+-- Just state_id -> State state_id
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+-- getStateSignals ::
+-- HsFunction -- | The function to look at
+-- -> FlatFunction -- | The function to look at
+-- -> [(SignalId, SignalId)]
+-- -- | TODO The state signals. The first is the state number, the second the
+-- -- signal to assign the current state to, the last is the signal
+-- -- that holds the new state.
+--
+-- getStateSignals hsfunc flatfunc =
+-- [(old_id, new_id)
+-- | (old_num, old_id) <- args
+-- , (new_num, new_id) <- res
+-- , old_num == new_num]
+-- where
+-- sigs = flat_sigs flatfunc
+-- -- Translate args and res to lists of (statenum, sigid)
+-- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+-- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+
+-- | Find the given function, flatten it and add it to the session. Then
+-- (recursively) do the same for any functions used.
+-- resolvFunc ::
+-- HsFunction -- | The function to look for
+-- -> TranslatorState ()
+--
+-- resolvFunc hsfunc = do
+-- flatfuncmap <- getA tsFlatFuncs
+-- -- Don't do anything if there is already a flat function for this hsfunc or
+-- -- when it is a builtin function.
+-- Monad.unless (Map.member hsfunc flatfuncmap) $ do
+-- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+-- -- New function, resolve it
+-- core <- getA tsCoreModule
+-- -- Find the named function
+-- let name = (hsFuncName hsfunc)
+-- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
+-- case bind of
+-- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+-- Just b -> flattenBind hsfunc b
+
+-- | Translate a top level function declaration to a HsFunction. i.e., which
+-- interface will be provided by this function. This function essentially
+-- defines the "calling convention" for hardware models.
+-- mkHsFunction ::
+-- Var.Var -- ^ The function defined
+-- -> Type -- ^ The function type (including arguments!)
+-- -> Bool -- ^ Is this a stateful function?
+-- -> HsFunction -- ^ The resulting HsFunction
+--
+-- mkHsFunction f ty stateful=
+-- HsFunction hsname hsargs hsres
+-- where
+-- hsname = getOccString f
+-- (arg_tys, res_ty) = Type.splitFunTys ty
+-- (hsargs, hsres) =
+-- if stateful
+-- then
+-- let
+-- -- The last argument must be state
+-- state_ty = last arg_tys
+-- state = useAsState (mkHsValueMap state_ty)
+-- -- All but the last argument are inports
+-- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+-- hsargs = inports ++ [state]
+-- hsres = case splitTupleType res_ty of
+-- -- Result type must be a two tuple (state, ports)
+-- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+-- then
+-- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+-- else
+-- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+-- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+-- in
+-- (hsargs, hsres)
+-- else
+-- -- Just use everything as a port
+-- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
+
+-- | Adds signal names to the given FlatFunction
+-- nameFlatFunction ::
+-- FlatFunction
+-- -> FlatFunction
+--
+-- nameFlatFunction flatfunc =
+-- -- Name the signals
+-- let
+-- s = flat_sigs flatfunc
+-- s' = map nameSignal s in
+-- flatfunc { flat_sigs = s' }
+-- where
+-- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+-- nameSignal (id, info) =
+-- let hints = nameHints info in
+-- let parts = ("sig" : hints) ++ [show id] in
+-- let name = concat $ List.intersperse "_" parts in
+-- (id, info {sigName = Just name})
+--
+-- -- | Splits a tuple type into a list of element types, or Nothing if the type
+-- -- is not a tuple type.
+-- splitTupleType ::
+-- Type -- ^ The type to split
+-- -> Maybe [Type] -- ^ The tuples element types
+--
+-- splitTupleType ty =
+-- case Type.splitTyConApp_maybe ty of
+-- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
+-- then
+-- Just args
+-- else
+-- Nothing
+-- Nothing -> Nothing
+
+-- vim: set ts=8 sw=2 sts=2 expandtab:
+++ /dev/null
-module Translator where
-import qualified Directory
-import qualified System.FilePath as FilePath
-import qualified List
-import Debug.Trace
-import qualified Control.Arrow as Arrow
-import GHC hiding (loadModule, sigName)
-import CoreSyn
-import qualified CoreUtils
-import qualified Var
-import qualified Type
-import qualified TyCon
-import qualified DataCon
-import qualified HscMain
-import qualified SrcLoc
-import qualified FastString
-import qualified Maybe
-import qualified Module
-import qualified Data.Foldable as Foldable
-import qualified Control.Monad.Trans.State as State
-import Name
-import qualified Data.Map as Map
-import Data.Accessor
-import Data.Generics
-import NameEnv ( lookupNameEnv )
-import qualified HscTypes
-import HscTypes ( cm_binds, cm_types )
-import MonadUtils ( liftIO )
-import Outputable ( showSDoc, ppr, showSDocDebug )
-import GHC.Paths ( libdir )
-import DynFlags ( defaultDynFlags )
-import qualified UniqSupply
-import List ( find )
-import qualified List
-import qualified Monad
-
--- The following modules come from the ForSyDe project. They are really
--- internal modules, so ForSyDe.cabal has to be modified prior to installing
--- ForSyDe to get access to these modules.
-import qualified Language.VHDL.AST as AST
-import qualified Language.VHDL.FileIO
-import qualified Language.VHDL.Ppr as Ppr
--- This is needed for rendering the pretty printed VHDL
-import Text.PrettyPrint.HughesPJ (render)
-
-import TranslatorTypes
-import HsValueMap
-import Pretty
-import Normalize
--- import Flatten
--- import FlattenTypes
-import VHDLTypes
-import qualified VHDL
-
-makeVHDL :: String -> String -> Bool -> IO ()
-makeVHDL filename name stateful = do
- -- Load the module
- (core, env) <- loadModule filename
- -- Translate to VHDL
- vhdl <- moduleToVHDL env core [(name, stateful)]
- -- Write VHDL to file
- let dir = "./vhdl/" ++ name ++ "/"
- prepareDir dir
- mapM (writeVHDL dir) vhdl
- return ()
-
-listBindings :: String -> IO [()]
-listBindings filename = do
- (core, env) <- loadModule filename
- let binds = CoreSyn.flattenBinds $ cm_binds core
- mapM (listBinding) binds
-
-listBinding :: (CoreBndr, CoreExpr) -> IO ()
-listBinding (b, e) = do
- putStr "\nBinder: "
- putStr $ show b
- putStr "\nExpression: \n"
- putStr $ prettyShow e
- putStr "\n\n"
- putStr $ showSDoc $ ppr e
- putStr "\n\n"
- putStr $ showSDoc $ ppr $ CoreUtils.exprType e
- putStr "\n\n"
-
--- | Show the core structure of the given binds in the given file.
-listBind :: String -> String -> IO ()
-listBind filename name = do
- (core, env) <- loadModule filename
- let [(b, expr)] = findBinds core [name]
- putStr "\n"
- putStr $ prettyShow expr
- putStr "\n\n"
- putStr $ showSDoc $ ppr expr
- putStr "\n\n"
- putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
- putStr "\n\n"
-
--- | Translate the binds with the given names from the given core module to
--- VHDL. The Bool in the tuple makes the function stateful (True) or
--- stateless (False).
-moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env core list = do
- let (names, statefuls) = unzip list
- let binds = map fst $ findBinds core names
- -- 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'
- -- Turn bind into VHDL
- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
- let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
- let vhdl = VHDL.createDesignFiles typestate normalized_bindings
- mapM (putStr . render . Ppr.ppr . snd) vhdl
- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
- return vhdl
- where
-
--- | 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
- exists <- Directory.doesDirectoryExist dir
- Monad.unless exists $ Directory.createDirectory 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
- Language.VHDL.FileIO.writeDesignFile vhdl fname
-
--- | Loads the given file and turns it into a core module.
-loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
-loadModule filename =
- defaultErrorHandler defaultDynFlags $ do
- runGhc (Just libdir) $ do
- dflags <- getSessionDynFlags
- setSessionDynFlags dflags
- --target <- guessTarget "adder.hs" Nothing
- --liftIO (print (showSDoc (ppr (target))))
- --liftIO $ printTarget target
- --setTargets [target]
- --load LoadAllTargets
- --core <- GHC.compileToCoreSimplified "Adders.hs"
- core <- GHC.compileToCoreModule filename
- env <- GHC.getSession
- return (core, env)
-
--- | Extracts the named binds from the given module.
-findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
-findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
-
--- | Extract a named bind from the given list of binds
-findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
-findBind binds lookfor =
- -- This ignores Recs and compares the name of the bind with lookfor,
- -- disregarding any namespaces in OccName and extra attributes in Name and
- -- Var.
- find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
-
--- | Flattens the given bind into the given signature and adds it to the
--- session. Then (recursively) finds any functions it uses and does the same
--- with them.
--- flattenBind ::
--- HsFunction -- The signature to flatten into
--- -> (CoreBndr, CoreExpr) -- The bind to flatten
--- -> TranslatorState ()
---
--- flattenBind hsfunc bind@(var, expr) = do
--- -- Flatten the function
--- let flatfunc = flattenFunction hsfunc bind
--- -- Propagate state variables
--- let flatfunc' = propagateState hsfunc flatfunc
--- -- Store the flat function in the session
--- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
--- -- Flatten any functions used
--- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
--- mapM_ resolvFunc used_hsfuncs
-
--- | Decide which incoming state variables will become state in the
--- given function, and which will be propagate to other applied
--- functions.
--- propagateState ::
--- HsFunction
--- -> FlatFunction
--- -> FlatFunction
---
--- propagateState hsfunc flatfunc =
--- flatfunc {flat_defs = apps', flat_sigs = sigs'}
--- where
--- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
--- states' = zip olds news
--- -- Find all signals used by all sigdefs
--- uses = concatMap sigDefUses (flat_defs flatfunc)
--- -- Find all signals that are used more than once (is there a
--- -- prettier way to do this?)
--- multiple_uses = uses List.\\ (List.nub uses)
--- -- Find the states whose "old state" signal is used only once
--- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
--- -- See if these single use states can be propagated
--- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
--- substate_sigs = concat substate_sigss
--- -- Mark any propagated state signals as SigSubState
--- sigs' = map
--- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
--- (flat_sigs flatfunc)
-
--- | Propagate the state into a single function application.
--- propagateState' ::
--- [(SignalId, SignalId)]
--- -- ^ TODO
--- -> SigDef -- ^ The SigDef to process.
--- -> ([SignalId], SigDef)
--- -- ^ Any signal ids that should become substates,
--- -- and the resulting application.
---
--- propagateState' states def =
--- if (is_FApp def) then
--- (our_old ++ our_new, def {appFunc = hsfunc'})
--- else
--- ([], def)
--- where
--- hsfunc = appFunc def
--- args = appArgs def
--- res = appRes def
--- our_states = filter our_state states
--- -- A state signal belongs in this function if the old state is
--- -- passed in, and the new state returned
--- our_state (old, new) =
--- any (old `Foldable.elem`) args
--- && new `Foldable.elem` res
--- (our_old, our_new) = unzip our_states
--- -- Mark the result
--- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
--- res' = fmap (mark_state (zip our_new [0..])) zipped_res
--- -- Mark the args
--- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
--- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
--- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
---
--- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
--- mark_state states (id, use) =
--- case lookup id states of
--- Nothing -> use
--- Just state_id -> State state_id
-
--- | Returns pairs of signals that should be mapped to state in this function.
--- getStateSignals ::
--- HsFunction -- | The function to look at
--- -> FlatFunction -- | The function to look at
--- -> [(SignalId, SignalId)]
--- -- | TODO The state signals. The first is the state number, the second the
--- -- signal to assign the current state to, the last is the signal
--- -- that holds the new state.
---
--- getStateSignals hsfunc flatfunc =
--- [(old_id, new_id)
--- | (old_num, old_id) <- args
--- , (new_num, new_id) <- res
--- , old_num == new_num]
--- where
--- sigs = flat_sigs flatfunc
--- -- Translate args and res to lists of (statenum, sigid)
--- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
--- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
-
--- | Find the given function, flatten it and add it to the session. Then
--- (recursively) do the same for any functions used.
--- resolvFunc ::
--- HsFunction -- | The function to look for
--- -> TranslatorState ()
---
--- resolvFunc hsfunc = do
--- flatfuncmap <- getA tsFlatFuncs
--- -- Don't do anything if there is already a flat function for this hsfunc or
--- -- when it is a builtin function.
--- Monad.unless (Map.member hsfunc flatfuncmap) $ do
--- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
--- -- New function, resolve it
--- core <- getA tsCoreModule
--- -- Find the named function
--- let name = (hsFuncName hsfunc)
--- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
--- case bind of
--- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
--- Just b -> flattenBind hsfunc b
-
--- | Translate a top level function declaration to a HsFunction. i.e., which
--- interface will be provided by this function. This function essentially
--- defines the "calling convention" for hardware models.
--- mkHsFunction ::
--- Var.Var -- ^ The function defined
--- -> Type -- ^ The function type (including arguments!)
--- -> Bool -- ^ Is this a stateful function?
--- -> HsFunction -- ^ The resulting HsFunction
---
--- mkHsFunction f ty stateful=
--- HsFunction hsname hsargs hsres
--- where
--- hsname = getOccString f
--- (arg_tys, res_ty) = Type.splitFunTys ty
--- (hsargs, hsres) =
--- if stateful
--- then
--- let
--- -- The last argument must be state
--- state_ty = last arg_tys
--- state = useAsState (mkHsValueMap state_ty)
--- -- All but the last argument are inports
--- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
--- hsargs = inports ++ [state]
--- hsres = case splitTupleType res_ty of
--- -- Result type must be a two tuple (state, ports)
--- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
--- then
--- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
--- else
--- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
--- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
--- in
--- (hsargs, hsres)
--- else
--- -- Just use everything as a port
--- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
-
--- | Adds signal names to the given FlatFunction
--- nameFlatFunction ::
--- FlatFunction
--- -> FlatFunction
---
--- nameFlatFunction flatfunc =
--- -- Name the signals
--- let
--- s = flat_sigs flatfunc
--- s' = map nameSignal s in
--- flatfunc { flat_sigs = s' }
--- where
--- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
--- nameSignal (id, info) =
--- let hints = nameHints info in
--- let parts = ("sig" : hints) ++ [show id] in
--- let name = concat $ List.intersperse "_" parts in
--- (id, info {sigName = Just name})
---
--- -- | Splits a tuple type into a list of element types, or Nothing if the type
--- -- is not a tuple type.
--- splitTupleType ::
--- Type -- ^ The type to split
--- -> Maybe [Type] -- ^ The tuples element types
---
--- splitTupleType ty =
--- case Type.splitTyConApp_maybe ty of
--- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
--- then
--- Just args
--- else
--- Nothing
--- Nothing -> Nothing
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
-- separate module to prevent circular dependencies in Pretty for example.
--
{-# LANGUAGE TemplateHaskell #-}
-module TranslatorTypes where
+module CLasH.Translator.TranslatorTypes where
import qualified Control.Monad.Trans.State as State
import qualified Data.Map as Map
import qualified Language.VHDL.AST as AST
-import FlattenTypes
-import VHDLTypes
-import HsValueMap
-
-
--- | A map from a HsFunction identifier to various stuff we collect about a
--- function along the way.
-type FlatFuncMap = Map.Map HsFunction FlatFunction
+import CLasH.VHDL.VHDLTypes
data TranslatorSession = TranslatorSession {
tsCoreModule_ :: HscTypes.CoreModule, -- ^ The current module
- tsNameCount_ :: Int, -- ^ A counter that can be used to generate unique names
- tsFlatFuncs_ :: FlatFuncMap -- ^ A map from HsFunction to FlatFunction
+ tsNameCount_ :: Int -- ^ A counter that can be used to generate unique names
}
-- Derive accessors
{-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
-module CoreShow where
+module CLasH.Utils.Core.CoreShow where
-- This module derives Show instances for CoreSyn types.
-- 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 CoreTools where
+module CLasH.Utils.Core.CoreTools where
--Standard modules
import qualified Maybe
import qualified Literal
-- Local imports
-import GhcTools
-import HsTools
-import Pretty
+import CLasH.Utils.GhcTools
+import CLasH.Utils.HsTools
+import CLasH.Utils.Pretty
-- | Evaluate a core Type representing type level int from the tfp
-- library to a real int.
-module GhcTools where
+module CLasH.Utils.GhcTools where
-- Standard modules
import qualified System.IO.Unsafe
{-# LANGUAGE ViewPatterns #-}
-module HsTools where
+module CLasH.Utils.HsTools where
-- Standard modules
import qualified Unsafe.Coerce
-- Local imports
-import GhcTools
-import CoreShow
+import CLasH.Utils.GhcTools
+import CLasH.Utils.Core.CoreShow
-- | Translate a HsExpr to a Core expression. This does renaming, type
-- checking, simplification of class instances and desugaring. The result is
-module Pretty (prettyShow, pprString, pprStringDebug) where
+module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where
import qualified Data.Map as Map
import qualified Language.VHDL.AST as AST
import qualified Language.VHDL.AST.Ppr
-import HsValueMap
-import FlattenTypes
-import TranslatorTypes
-import VHDLTypes
-import CoreShow
+import CLasH.Translator.TranslatorTypes
+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 HsFunction where
- pPrint (HsFunction name args res) =
- text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
- where
- args' = map pPrint args
- res' = pPrint res
-
-instance Pretty x => Pretty (HsValueMap x) where
- pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps))
- pPrint (Single s) = pPrint s
-
-instance Pretty HsValueUse where
- pPrint Port = char 'P'
- pPrint (State n) = char 'S' <> int n
- pPrint (HighOrder _ _) = text "Higher Order"
-
-instance Pretty FlatFunction where
- pPrint (FlatFunction args res defs sigs) =
- (text "Args: ") $$ nest 10 (pPrint args)
- $+$ (text "Result: ") $$ nest 10 (pPrint res)
- $+$ (text "Defs: ") $$ nest 10 (ppdefs defs)
- $+$ text "Signals: " $$ nest 10 (ppsigs sigs)
- where
- ppsig (id, info) = pPrint id <> pPrint info
- ppdefs defs = vcat (map pPrint sorted)
- where
- -- Roughly sort the entries (inaccurate for Fapps)
- sorted = List.sortBy (\a b -> compare (sigDefDst a) (sigDefDst b)) defs
- sigDefDst (FApp _ _ dst) = head $ Foldable.toList dst
- sigDefDst (CondDef _ _ _ dst) = dst
- sigDefDst (UncondDef _ dst) = dst
- ppsigs sigs = vcat (map pPrint sorted)
- where
- sorted = List.sortBy (\a b -> compare (fst a) (fst b)) sigs
-
-
-instance Pretty SigDef where
- pPrint (FApp func args res) =
- pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
- pPrint (CondDef cond true false res) =
- pPrint cond <> text " ? " <> pPrint true <> text " : " <> pPrint false <> text " -> " <> pPrint res
- pPrint (UncondDef src dst) =
- ppsrc src <> text " -> " <> pPrint dst
- where
- ppsrc (Left id) = pPrint id
- ppsrc (Right expr) = pPrint expr
-
-instance Pretty SignalExpr where
- pPrint (EqLit id lit) =
- parens $ pPrint id <> text " = " <> text lit
- pPrint (Literal lit ty) =
- text "(" <> text (show ty) <> text ") " <> text lit
- pPrint (Eq a b) =
- parens $ pPrint a <> text " = " <> pPrint b
-
-instance Pretty SignalInfo where
- pPrint (SignalInfo name use ty hints) =
- text ":" <> (pPrint use) <> (ppname name)
- where
- ppname Nothing = empty
- ppname (Just name) = text ":" <> text name
-
-instance Pretty SigUse where
- pPrint SigPortIn = text "PI"
- pPrint SigPortOut = text "PO"
- pPrint SigInternal = text "I"
- pPrint (SigStateOld n) = text "SO:" <> int n
- pPrint (SigStateNew n) = text "SN:" <> int n
- pPrint SigSubState = text "s"
-
instance Pretty TranslatorSession where
- pPrint (TranslatorSession mod nameCount flatfuncs) =
+ pPrint (TranslatorSession mod nameCount) =
text "Module: " $$ nest 15 (text modname)
$+$ text "NameCount: " $$ nest 15 (int nameCount)
- $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList flatfuncs)))
where
ppfunc (hsfunc, flatfunc) =
pPrint hsfunc $+$ nest 5 (pPrint flatfunc)
--- /dev/null
+--
+-- Functions to generate VHDL from FlatFunctions
+--
+module CLasH.VHDL where
+
+-- Standard modules
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Maybe
+import qualified Control.Monad as Monad
+import qualified Control.Arrow as Arrow
+import qualified Control.Monad.Trans.State as State
+import qualified Data.Monoid as Monoid
+import Data.Accessor
+import Data.Accessor.MonadState as MonadState
+import Debug.Trace
+
+-- ForSyDe
+import qualified Language.VHDL.AST as AST
+
+-- GHC API
+import CoreSyn
+--import qualified Type
+import qualified Name
+import qualified Var
+import qualified Id
+import qualified IdInfo
+import qualified TyCon
+import qualified DataCon
+--import qualified CoreSubst
+import qualified CoreUtils
+import Outputable ( showSDoc, ppr )
+
+-- Local imports
+import CLasH.VHDL.VHDLTypes
+import CLasH.VHDL.VHDLTools
+import CLasH.Utils.Pretty
+import CLasH.Utils.Core.CoreTools
+import CLasH.VHDL.Constants
+import CLasH.VHDL.Generate
+
+createDesignFiles ::
+ TypeState
+ -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+ -> [(AST.VHDLId, AST.DesignFile)]
+
+createDesignFiles init_typestate binds =
+ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
+ map (Arrow.second $ AST.DesignFile full_context) units
+
+ where
+ init_session = VHDLState init_typestate Map.empty
+ (units, final_session) =
+ State.runState (createLibraryUnits binds) init_session
+ tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
+ ty_decls = final_session ^. vsType ^. vsTypeDecls
+ 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) highId Nothing)
+ tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
+ ieee_context = [
+ AST.Library $ mkVHDLBasicId "IEEE",
+ mkUseAll ["IEEE", "std_logic_1164"],
+ mkUseAll ["IEEE", "numeric_std"]
+ ]
+ full_context =
+ mkUseAll ["work", "types"]
+ : (mkUseAll ["work"]
+ : ieee_context)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+ subProgSpecs = map subProgSpec tyfun_decls
+ subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
+
+-- 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)
+
+createLibraryUnits ::
+ [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+ -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
+
+createLibraryUnits binds = do
+ entities <- Monad.mapM createEntity binds
+ archs <- Monad.mapM createArchitecture binds
+ return $ zipWith
+ (\ent arch ->
+ let AST.EntityDec id _ = ent in
+ (id, [AST.LUEntity ent, AST.LUArch arch])
+ )
+ entities archs
+
+-- | Create an entity for a given function
+createEntity ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
+ -> VHDLSession AST.EntityDec -- | The resulting entity
+
+createEntity (fname, expr) = do
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ args' <- Monad.mapM mkMap args
+ -- There must be a let at top level
+ let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
+ res' <- mkMap res
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
+ let ent_decl' = createEntityAST vhdl_id args' res'
+ let AST.EntityDec entity_id _ = ent_decl'
+ let signature = Entity entity_id args' res'
+ modA vsSignatures (Map.insert fname signature)
+ return ent_decl'
+ where
+ mkMap ::
+ --[(SignalId, SignalInfo)]
+ CoreSyn.CoreBndr
+ -> VHDLSession Port
+ -- We only need the vsTypes element from the state
+ 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 <- MonadState.lift vsType $ vhdl_ty error_msg ty
+ return (id, type_mark)
+ )
+
+ -- | Create the VHDL AST for an entity
+createEntityAST ::
+ AST.VHDLId -- | The name of the function
+ -> [Port] -- | The entity's arguments
+ -> 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
+ ++ [mkIfaceSigDec AST.Out res]
+ ++ [clk_port]
+ -- Add a clk port if we have state
+ clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
+
+-- | Create a port declaration
+mkIfaceSigDec ::
+ AST.Mode -- | The mode for the port (In / Out)
+ -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
+ -> AST.IfaceSigDec -- | The resulting port declaration
+
+mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
+
+{-
+-- | Generate a VHDL entity name for the given hsfunc
+mkEntityId hsfunc =
+ -- TODO: This doesn't work for functions with multiple signatures!
+ -- Use a Basic Id, since using extended id's for entities throws off
+ -- precision and causes problems when generating filenames.
+ mkVHDLBasicId $ hsFuncName hsfunc
+-}
+
+-- | Create an architecture for a given function
+createArchitecture ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
+ -> VHDLSession AST.ArchBody -- ^ The architecture for this function
+
+createArchitecture (fname, expr) = do
+ signaturemap <- getA vsSignatures
+ let signature = Maybe.fromMaybe
+ (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
+ (Map.lookup fname signaturemap)
+ let entity_id = ent_id signature
+ -- Strip off lambda's, these will be arguments
+ let (args, letexpr) = CoreSyn.collectBinders expr
+ -- There must be a let at top level
+ let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
+
+ -- 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
+
+ statementss <- Monad.mapM mkConcSm binds
+ let statements = concat statementss
+ return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+ where
+ procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
+ procs' = map AST.CSPSm procs
+ -- mkSigDec only uses vsTypes from the state
+ mkSigDec' = mkSigDec
+
+{-
+-- | Looks up all pairs of old state, new state signals, together with
+-- the state id they represent.
+makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
+makeStatePairs flatfunc =
+ [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
+ | old_info <- map snd (flat_sigs flatfunc)
+ , new_info <- map snd (flat_sigs flatfunc)
+ -- old_info must be an old state (and, because of the next equality,
+ -- new_info must be a new state).
+ , Maybe.isJust $ oldStateId $ sigUse old_info
+ -- And the state numbers must match
+ , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
+
+ -- Replace the second tuple element with the corresponding SignalInfo
+ --args_states = map (Arrow.second $ signalInfo sigs) args
+mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
+mkStateProcSm (num, old, new) =
+ AST.ProcSm label [clk] [statement]
+ where
+ label = mkVHDLExtId $ "state_" ++ (show num)
+ clk = mkVHDLExtId "clk"
+ rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+ wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
+ assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
+ rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
+ statement = AST.IfSm rising_edge_clk [assign] [] Nothing
+
+-- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
+-- is not named.
+getSignalId :: SignalInfo -> AST.VHDLId
+getSignalId info =
+ mkVHDLExtId $ Maybe.fromMaybe
+ (error $ "Unnamed signal? This should not happen!")
+ (sigName info)
+-}
+
+mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
+mkSigDec bndr =
+ if True then do --isInternalSigUse use || isStateSigUse use then do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
+ type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
+ return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ else
+ return Nothing
+
+-- | Transforms a core binding into a VHDL concurrent statement
+mkConcSm ::
+ (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
+ -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
+
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+mkConcSm (bndr, 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, Var v) = do
+ 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 thee scrutinee is a simple
+-- variable, the alternative is a dataalt with a single non-wild binder that
+-- is also returned.
+mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
+ case alt of
+ (DataAlt dc, bndrs, (Var sel_bndr)) -> do
+ case List.elemIndex sel_bndr bndrs of
+ Just i -> do
+ labels <- MonadState.lift vsType $ 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]
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
+
+-- Multiple case alt are be 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, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
+ scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
+ let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+ true_expr <- MonadState.lift vsType $ varToVHDLExpr true
+ false_expr <- MonadState.lift vsType $ varToVHDLExpr false
+ return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-module Constants where
+module CLasH.VHDL.Constants where
import qualified Language.VHDL.AST as AST
{-# LANGUAGE PackageImports #-}
-module Generate where
+module CLasH.VHDL.Generate where
-- Standard modules
import qualified Control.Monad as Monad
import qualified TyCon
-- Local imports
-import Constants
-import VHDLTypes
-import VHDLTools
-import CoreTools
-import Pretty
+import CLasH.VHDL.Constants
+import CLasH.VHDL.VHDLTypes
+import CLasH.VHDL.VHDLTools
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.Pretty
-----------------------------------------------------------------------------
-- Functions to generate VHDL for builtin functions
+++ /dev/null
---
--- Functions to generate VHDL from FlatFunctions
---
-module VHDL where
-
--- Standard modules
-import qualified Data.List as List
-import qualified Data.Map as Map
-import qualified Maybe
-import qualified Control.Monad as Monad
-import qualified Control.Arrow as Arrow
-import qualified Control.Monad.Trans.State as State
-import qualified Data.Monoid as Monoid
-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
-import Debug.Trace
-
--- ForSyDe
-import qualified Language.VHDL.AST as AST
-
--- GHC API
-import CoreSyn
---import qualified Type
-import qualified Name
-import qualified Var
-import qualified Id
-import qualified IdInfo
-import qualified TyCon
-import qualified DataCon
---import qualified CoreSubst
-import qualified CoreUtils
-import Outputable ( showSDoc, ppr )
-
--- Local imports
-import VHDLTypes
-import VHDLTools
-import Pretty
-import CoreTools
-import Constants
-import Generate
-
-createDesignFiles ::
- TypeState
- -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> [(AST.VHDLId, AST.DesignFile)]
-
-createDesignFiles init_typestate binds =
- (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
- map (Arrow.second $ AST.DesignFile full_context) units
-
- where
- init_session = VHDLState init_typestate Map.empty
- (units, final_session) =
- State.runState (createLibraryUnits binds) init_session
- tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
- ty_decls = final_session ^. vsType ^. vsTypeDecls
- 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) highId Nothing)
- tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
- ieee_context = [
- AST.Library $ mkVHDLBasicId "IEEE",
- mkUseAll ["IEEE", "std_logic_1164"],
- mkUseAll ["IEEE", "numeric_std"]
- ]
- full_context =
- mkUseAll ["work", "types"]
- : (mkUseAll ["work"]
- : ieee_context)
- type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
- type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
- subProgSpecs = map subProgSpec tyfun_decls
- subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
-
--- 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)
-
-createLibraryUnits ::
- [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
-
-createLibraryUnits binds = do
- entities <- Monad.mapM createEntity binds
- archs <- Monad.mapM createArchitecture binds
- return $ zipWith
- (\ent arch ->
- let AST.EntityDec id _ = ent in
- (id, [AST.LUEntity ent, AST.LUArch arch])
- )
- entities archs
-
--- | Create an entity for a given function
-createEntity ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
- -> VHDLSession AST.EntityDec -- | The resulting entity
-
-createEntity (fname, expr) = do
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- args' <- Monad.mapM mkMap args
- -- There must be a let at top level
- let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
- res' <- mkMap res
- let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
- let ent_decl' = createEntityAST vhdl_id args' res'
- let AST.EntityDec entity_id _ = ent_decl'
- let signature = Entity entity_id args' res'
- modA vsSignatures (Map.insert fname signature)
- return ent_decl'
- where
- mkMap ::
- --[(SignalId, SignalInfo)]
- CoreSyn.CoreBndr
- -> VHDLSession Port
- -- We only need the vsTypes element from the state
- 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 <- MonadState.lift vsType $ vhdl_ty error_msg ty
- return (id, type_mark)
- )
-
- -- | Create the VHDL AST for an entity
-createEntityAST ::
- AST.VHDLId -- | The name of the function
- -> [Port] -- | The entity's arguments
- -> 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
- ++ [mkIfaceSigDec AST.Out res]
- ++ [clk_port]
- -- Add a clk port if we have state
- clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
-
--- | Create a port declaration
-mkIfaceSigDec ::
- AST.Mode -- | The mode for the port (In / Out)
- -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
- -> AST.IfaceSigDec -- | The resulting port declaration
-
-mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
-
-{-
--- | Generate a VHDL entity name for the given hsfunc
-mkEntityId hsfunc =
- -- TODO: This doesn't work for functions with multiple signatures!
- -- Use a Basic Id, since using extended id's for entities throws off
- -- precision and causes problems when generating filenames.
- mkVHDLBasicId $ hsFuncName hsfunc
--}
-
--- | Create an architecture for a given function
-createArchitecture ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLSession AST.ArchBody -- ^ The architecture for this function
-
-createArchitecture (fname, expr) = do
- signaturemap <- getA vsSignatures
- let signature = Maybe.fromMaybe
- (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
- (Map.lookup fname signaturemap)
- let entity_id = ent_id signature
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- -- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
-
- -- 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
-
- statementss <- Monad.mapM mkConcSm binds
- let statements = concat statementss
- return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
- where
- procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
- procs' = map AST.CSPSm procs
- -- mkSigDec only uses vsTypes from the state
- mkSigDec' = mkSigDec
-
-{-
--- | Looks up all pairs of old state, new state signals, together with
--- the state id they represent.
-makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
-makeStatePairs flatfunc =
- [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
- | old_info <- map snd (flat_sigs flatfunc)
- , new_info <- map snd (flat_sigs flatfunc)
- -- old_info must be an old state (and, because of the next equality,
- -- new_info must be a new state).
- , Maybe.isJust $ oldStateId $ sigUse old_info
- -- And the state numbers must match
- , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
-
- -- Replace the second tuple element with the corresponding SignalInfo
- --args_states = map (Arrow.second $ signalInfo sigs) args
-mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
-mkStateProcSm (num, old, new) =
- AST.ProcSm label [clk] [statement]
- where
- label = mkVHDLExtId $ "state_" ++ (show num)
- clk = mkVHDLExtId "clk"
- rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
- wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
- assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
- rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
- statement = AST.IfSm rising_edge_clk [assign] [] Nothing
-
--- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
--- is not named.
-getSignalId :: SignalInfo -> AST.VHDLId
-getSignalId info =
- mkVHDLExtId $ Maybe.fromMaybe
- (error $ "Unnamed signal? This should not happen!")
- (sigName info)
--}
-
-mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
-mkSigDec bndr =
- if True then do --isInternalSigUse use || isStateSigUse use then do
- let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
- type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
- return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
- else
- return Nothing
-
--- | Transforms a core binding into a VHDL concurrent statement
-mkConcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
- -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
-
-
--- Ignore Cast expressions, they should not longer have any meaning as long as
--- the type works out.
-mkConcSm (bndr, 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, Var v) = do
- 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 thee scrutinee is a simple
--- variable, the alternative is a dataalt with a single non-wild binder that
--- is also returned.
-mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
- case alt of
- (DataAlt dc, bndrs, (Var sel_bndr)) -> do
- case List.elemIndex sel_bndr bndrs of
- Just i -> do
- labels <- MonadState.lift vsType $ 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]
- Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
- _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-
--- Multiple case alt are be 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, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
- scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
- let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
- true_expr <- MonadState.lift vsType $ varToVHDLExpr true
- false_expr <- MonadState.lift vsType $ varToVHDLExpr false
- return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
-
-mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
-mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
-mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
-module VHDLTools where
+module CLasH.VHDL.VHDLTools where
-- Standard modules
import qualified Maybe
import qualified CoreSubst
-- Local imports
-import VHDLTypes
-import CoreTools
-import Pretty
-import Constants
+import CLasH.VHDL.VHDLTypes
+import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.Pretty
+import CLasH.VHDL.Constants
-----------------------------------------------------------------------------
-- Functions to generate concurrent statements
-- Some types used by the VHDL module.
--
{-# LANGUAGE TemplateHaskell #-}
-module VHDLTypes where
+module CLasH.VHDL.VHDLTypes where
-- Standard imports
import qualified Control.Monad.Trans.State as State
-name: clash
-version: 0.1
-build-type: Simple
-synopsis: CAES Languege for Hardware Descriptions (CλasH)
-description: CλasH is a toolchain/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: Development
-license: BSD3
-license-file: LICENSE
-package-url: http://github.com/darchon/clash/tree/master
-copyright: Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
-author: Christiaan Baaij & Matthijs Kooijman
-stability: alpha
-maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl
-build-depends: ghc >= 6.11, vhdl, data-accessor-template, data-accessor,
- containers, transformers, base >= 4, haskell98,
- prettyclass, ghc-paths, pretty, syb, filepath,
- th-lift-ng, tfp > 0.3.2, tfvec > 0.1.2
+name: clash
+version: 0.1
+build-type: Simple
+synopsis: CAES Languege for Hardware Descriptions (CλasH)
+description: CλasH is a toolchain/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: Development
+license: BSD3
+license-file: LICENSE
+package-url: http://github.com/darchon/clash/tree/master
+copyright: Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman
+author: Christiaan Baaij & Matthijs Kooijman
+stability: alpha
+maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl
+Cabal-Version: >= 1.2
-executable: clash
-main-is: Main.hs
+Library
+ build-depends: ghc >= 6.11, vhdl, data-accessor-template, data-accessor,
+ containers, transformers, base >= 4, haskell98,
+ prettyclass, ghc-paths, pretty, syb, filepath, th-lift-ng,
+ tfp > 0.3.2, tfvec > 0.1.2
+ exposed-modules: CLasH.Translator
+ other-modules: CLasH.Translator.TranslatorTypes
+ CLasH.Normalize
+ CLasH.Normalize.NormalizeTypes
+ CLasH.Normalize.NormalizeTools
+ CLasH.VHDL
+ CLasH.VHDL.Constants
+ CLasH.VHDL.Generate
+ CLasH.VHDL.VHDLTools
+ CLasH.VHDL.VHDLTypes
+ CLasH.Utils.GhcTools
+ CLasH.Utils.HsTools
+ CLasH.Utils.Pretty
+ CLasH.Utils.Core.CoreShow
+ CLasH.Utils.Core.CoreTools
+
\ No newline at end of file
projects / matthijs / master-project / cλash.git / commitdiff