From: Christiaan Baaij Date: Wed, 15 Jul 2009 18:11:44 +0000 (+0200) Subject: Adepted the modules to their new structure X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=b2967df7f237e5b4db15d069895ca01c31712d9e;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Adepted the modules to their new structure --- diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" new file mode 100644 index 0000000..7224610 --- /dev/null +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -0,0 +1,533 @@ +{-# 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!" diff --git "a/c\316\273ash/CLasH/Normalize/Normalize.hs" "b/c\316\273ash/CLasH/Normalize/Normalize.hs" deleted file mode 100644 index 12356e2..0000000 --- "a/c\316\273ash/CLasH/Normalize/Normalize.hs" +++ /dev/null @@ -1,533 +0,0 @@ -{-# 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!" diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 920d28b..e1b8727 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -2,7 +2,7 @@ -- -- This module provides functions for program transformations. -- -module NormalizeTools where +module CLasH.Normalize.NormalizeTools where -- Standard modules import Debug.Trace import qualified List @@ -34,10 +34,10 @@ import qualified HscTypes 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, diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" index 56cba91..90589f8 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -module NormalizeTypes where +module CLasH.Normalize.NormalizeTypes where -- Standard modules @@ -18,9 +18,9 @@ import qualified VarSet 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 diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" new file mode 100644 index 0000000..7203296 --- /dev/null +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -0,0 +1,370 @@ +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: diff --git "a/c\316\273ash/CLasH/Translator/Translator.hs" "b/c\316\273ash/CLasH/Translator/Translator.hs" deleted file mode 100644 index 260b1cd..0000000 --- "a/c\316\273ash/CLasH/Translator/Translator.hs" +++ /dev/null @@ -1,372 +0,0 @@ -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: diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index 1286a41..0ab3b87 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -3,7 +3,7 @@ -- 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 @@ -14,19 +14,11 @@ import qualified HscTypes 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 diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" index 09abed6..192ecc8 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreShow.hs" @@ -1,5 +1,5 @@ {-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-} -module CoreShow where +module CLasH.Utils.Core.CoreShow where -- This module derives Show instances for CoreSyn types. diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 0c0e1fa..45721a8 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -2,7 +2,7 @@ -- 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 @@ -32,9 +32,9 @@ import qualified CoreFVs 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. diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 9c5038c..5f6e671 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -1,4 +1,4 @@ -module GhcTools where +module CLasH.Utils.GhcTools where -- Standard modules import qualified System.IO.Unsafe diff --git "a/c\316\273ash/CLasH/Utils/HsTools.hs" "b/c\316\273ash/CLasH/Utils/HsTools.hs" index 1bad941..ca20441 100644 --- "a/c\316\273ash/CLasH/Utils/HsTools.hs" +++ "b/c\316\273ash/CLasH/Utils/HsTools.hs" @@ -1,5 +1,5 @@ {-# LANGUAGE ViewPatterns #-} -module HsTools where +module CLasH.Utils.HsTools where -- Standard modules import qualified Unsafe.Coerce @@ -53,8 +53,8 @@ import qualified TyCon -- 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 diff --git "a/c\316\273ash/CLasH/Utils/Pretty.hs" "b/c\316\273ash/CLasH/Utils/Pretty.hs" index d88846a..4366b10 100644 --- "a/c\316\273ash/CLasH/Utils/Pretty.hs" +++ "b/c\316\273ash/CLasH/Utils/Pretty.hs" @@ -1,4 +1,4 @@ -module Pretty (prettyShow, pprString, pprStringDebug) where +module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where import qualified Data.Map as Map @@ -15,92 +15,19 @@ import qualified Language.VHDL.Ppr as Ppr 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) diff --git "a/c\316\273ash/CLasH/VHDL.hs" "b/c\316\273ash/CLasH/VHDL.hs" new file mode 100644 index 0000000..031acc8 --- /dev/null +++ "b/c\316\273ash/CLasH/VHDL.hs" @@ -0,0 +1,298 @@ +-- +-- 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 diff --git "a/c\316\273ash/CLasH/VHDL/Constants.hs" "b/c\316\273ash/CLasH/VHDL/Constants.hs" index e9c4a4a..317cb64 100644 --- "a/c\316\273ash/CLasH/VHDL/Constants.hs" +++ "b/c\316\273ash/CLasH/VHDL/Constants.hs" @@ -1,4 +1,4 @@ -module Constants where +module CLasH.VHDL.Constants where import qualified Language.VHDL.AST as AST diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 8dc7a0a..2c5f2d7 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -1,6 +1,6 @@ {-# LANGUAGE PackageImports #-} -module Generate where +module CLasH.VHDL.Generate where -- Standard modules import qualified Control.Monad as Monad @@ -26,11 +26,11 @@ import qualified Name 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 diff --git "a/c\316\273ash/CLasH/VHDL/VHDL.hs" "b/c\316\273ash/CLasH/VHDL/VHDL.hs" deleted file mode 100644 index 1a8f394..0000000 --- "a/c\316\273ash/CLasH/VHDL/VHDL.hs" +++ /dev/null @@ -1,298 +0,0 @@ --- --- 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 diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index 6e6a0c4..8fd9938 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -1,4 +1,4 @@ -module VHDLTools where +module CLasH.VHDL.VHDLTools where -- Standard modules import qualified Maybe @@ -28,10 +28,10 @@ import qualified DataCon 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 diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" index 8712043..52adab7 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTypes.hs" @@ -2,7 +2,7 @@ -- 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 diff --git "a/c\316\273ash/c\316\273ash.cabal" "b/c\316\273ash/c\316\273ash.cabal" index 3eb5dca..23af8fb 100644 --- "a/c\316\273ash/c\316\273ash.cabal" +++ "b/c\316\273ash/c\316\273ash.cabal" @@ -1,24 +1,39 @@ -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