From b8c1e8554ba8aee73bc9d9a54bb3cb32f7930957 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Wed, 15 Jul 2009 17:41:13 +0200 Subject: [PATCH] Moved to new GHC API (6.11). Also use vhdl package for the VHDL AST --- Constants.hs | 2 +- CoreShow.hs | 1 + Generate.hs | 83 ++++++++++++++++++++++---------------------- Normalize.hs | 6 ++-- NormalizeTools.hs | 4 +-- Pretty.hs | 10 +++--- Translator.hs | 11 +++--- TranslatorTypes.hs | 2 +- VHDL.hs | 2 +- VHDLTools.hs | 2 +- VHDLTypes.hs | 2 +- "c\316\273ash.cabal" | 17 +++++---- 12 files changed, 73 insertions(+), 69 deletions(-) diff --git a/Constants.hs b/Constants.hs index ad87e0a..e9c4a4a 100644 --- a/Constants.hs +++ b/Constants.hs @@ -1,6 +1,6 @@ module Constants where -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.AST as AST -------------- -- Identifiers diff --git a/CoreShow.hs b/CoreShow.hs index 75bacef..09abed6 100644 --- a/CoreShow.hs +++ b/CoreShow.hs @@ -24,6 +24,7 @@ deriving instance (Show b) => Show (CoreSyn.Expr b) deriving instance (Show b) => Show (CoreSyn.Bind b) deriving instance Show TypeRep.Type deriving instance (Show n, OutputableBndr n) => Show (HsTypes.HsType n) +deriving instance (Show n, OutputableBndr n) => Show (HsTypes.ConDeclField n) deriving instance (Show x) => Show (SrcLoc.Located x) deriving instance (Show x, OutputableBndr x) => Show (HsExpr.StmtLR x x) deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsExpr x) diff --git a/Generate.hs b/Generate.hs index f4cab36..8dc7a0a 100644 --- a/Generate.hs +++ b/Generate.hs @@ -14,7 +14,7 @@ import Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.AST as AST -- GHC API import CoreSyn @@ -511,34 +511,8 @@ genApplication :: -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements genApplication dst f args = do - case Var.globalIdVarDetails f of - IdInfo.DataConWorkId dc -> case dst of - -- It's a datacon. Create a record from its arguments. - Left bndr -> do - -- We have the bndr, so we can get at the type - labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr) - args' <- eitherCoreOrExprArgs args - return $ zipWith mkassign labels $ args' - where - mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm - mkassign label arg = - let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in - mkUncondAssign (Right sel_name) arg - Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" - IdInfo.VanillaGlobal -> do - -- It's a global value imported from elsewhere. These can be builtin - -- functions. Look up the function name in the name table and execute - -- the associated builder if there is any and the argument count matches - -- (this should always be the case if it typechecks, but just to be - -- sure...). - case (Map.lookup (varToString f) globalNameTable) of - Just (arg_count, builder) -> - if length args == arg_count then - builder dst f args - else - error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f - IdInfo.NotGlobalId -> do + case Var.isGlobalId f of + False -> do signatures <- getA vsSignatures -- This is a local id, so it should be a function whose definition we -- have and which can be turned into a component instantiation. @@ -560,18 +534,45 @@ genApplication dst f args = do -- unconditional assignment here. f' <- MonadState.lift vsType $ varToVHDLExpr f return $ [mkUncondAssign dst f'] - - IdInfo.ClassOpId cls -> do - -- FIXME: Not looking for what instance this class op is called for - -- Is quite stupid of course. - case (Map.lookup (varToString f) globalNameTable) of - Just (arg_count, builder) -> - if length args == arg_count then - builder dst f args - else - error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f - details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details + True -> + case Var.idDetails f of + IdInfo.DataConWorkId dc -> case dst of + -- It's a datacon. Create a record from its arguments. + Left bndr -> do + -- We have the bndr, so we can get at the type + labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr) + args' <- eitherCoreOrExprArgs args + return $ zipWith mkassign labels $ args' + where + mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm + mkassign label arg = + let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in + mkUncondAssign (Right sel_name) arg + Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" + IdInfo.VanillaId -> do + -- It's a global value imported from elsewhere. These can be builtin + -- functions. Look up the function name in the name table and execute + -- the associated builder if there is any and the argument count matches + -- (this should always be the case if it typechecks, but just to be + -- sure...). + case (Map.lookup (varToString f) globalNameTable) of + Just (arg_count, builder) -> + if length args == arg_count then + builder dst f args + else + error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f + IdInfo.ClassOpId cls -> do + -- FIXME: Not looking for what instance this class op is called for + -- Is quite stupid of course. + case (Map.lookup (varToString f) globalNameTable) of + Just (arg_count, builder) -> + if length args == arg_count then + builder dst f args + else + error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f + details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details ----------------------------------------------------------------------------- -- Functions to generate functions dealing with vectors. diff --git a/Normalize.hs b/Normalize.hs index 3f9389a..12356e2 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -205,7 +205,7 @@ casewild expr@(Case scrut b ty alts) = do 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 = Id.mkWildId + wild = MkCore.mkWildBinder -- Wilden the binders of one alt, producing a list of bindings as a -- sideeffect. doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt) @@ -219,7 +219,7 @@ casewild expr@(Case scrut b ty alts) = do return (bindings, newalt) where -- Make all binders wild - wildbndrs = map (\bndr -> Id.mkWildId (Id.idType bndr)) bndrs + 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 @@ -488,7 +488,7 @@ normalizeBind :: CoreBndr -> TransformSession () normalizeBind bndr = -- Don't normalize global variables, these should be either builtin -- functions or data constructors. - Monad.when (Var.isLocalIdVar bndr) $ do + 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) diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 1290fd8..920d28b 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -48,7 +48,7 @@ mkInternalVar str ty = do uniq <- mkUnique let occname = OccName.mkVarOcc (str ++ show uniq) let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo + return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo -- Create a new type variable with the given name and kind. A Unique is -- appended to the given name, to ensure uniqueness (not strictly neccesary, @@ -79,7 +79,7 @@ cloneVar v = do uniq <- mkUnique -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it -- contains, but vannillaIdInfo is always correct, since it means "no info"). - return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo + return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo -- Creates a new function with the same name as the given binder (but with a -- new unique) and with the given function body. Returns the new binder for diff --git a/Pretty.hs b/Pretty.hs index 9277494..d88846a 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -11,9 +11,9 @@ import qualified HscTypes import Text.PrettyPrint.HughesPJClass import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr) -import qualified ForSyDe.Backend.Ppr -import qualified ForSyDe.Backend.VHDL.Ppr -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.Ppr as Ppr +import qualified Language.VHDL.AST as AST +import qualified Language.VHDL.AST.Ppr import HsValueMap import FlattenTypes @@ -136,10 +136,10 @@ instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where pPrint = text . show instance Pretty AST.VHDLId where - pPrint id = ForSyDe.Backend.Ppr.ppr id + pPrint id = Ppr.ppr id instance Pretty AST.VHDLName where - pPrint name = ForSyDe.Backend.Ppr.ppr name + pPrint name = Ppr.ppr name prettyBind :: (Show b, Show e) => (b, e) -> Doc prettyBind (b, expr) = diff --git a/Translator.hs b/Translator.hs index feb712b..260b1cd 100644 --- a/Translator.hs +++ b/Translator.hs @@ -37,10 +37,9 @@ 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 ForSyDe.Backend.VHDL.AST as AST -import qualified ForSyDe.Backend.VHDL.Ppr -import qualified ForSyDe.Backend.VHDL.FileIO -import qualified ForSyDe.Backend.Ppr +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) @@ -113,7 +112,7 @@ moduleToVHDL env core list = do 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 . ForSyDe.Backend.Ppr.ppr . snd) vhdl + mapM (putStr . render . Ppr.ppr . snd) vhdl --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl where @@ -140,7 +139,7 @@ writeVHDL dir (name, vhdl) = do -- Find the filename let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl" -- Write the file - ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname + Language.VHDL.FileIO.writeDesignFile vhdl fname -- | Loads the given file and turns it into a core module. loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv) diff --git a/TranslatorTypes.hs b/TranslatorTypes.hs index 37e8619..1286a41 100644 --- a/TranslatorTypes.hs +++ b/TranslatorTypes.hs @@ -12,7 +12,7 @@ import Data.Accessor import qualified HscTypes -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.AST as AST import FlattenTypes import VHDLTypes diff --git a/VHDL.hs b/VHDL.hs index 0385909..1a8f394 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -16,7 +16,7 @@ import Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.AST as AST -- GHC API import CoreSyn diff --git a/VHDLTools.hs b/VHDLTools.hs index 2d36049..6e6a0c4 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -13,7 +13,7 @@ import Data.Accessor import Debug.Trace -- ForSyDe -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.AST as AST -- GHC API import CoreSyn diff --git a/VHDLTypes.hs b/VHDLTypes.hs index 5562c6a..8712043 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -16,7 +16,7 @@ import qualified CoreSyn import qualified HscTypes -- ForSyDe imports -import qualified ForSyDe.Backend.VHDL.AST as AST +import qualified Language.VHDL.AST as AST -- Local imports diff --git "a/c\316\273ash.cabal" "b/c\316\273ash.cabal" index 4796956..3eb5dca 100644 --- "a/c\316\273ash.cabal" +++ "b/c\316\273ash.cabal" @@ -2,7 +2,11 @@ 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. +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 @@ -11,11 +15,10 @@ 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: base > 4, syb, ghc, ghc-paths, transformers, haskell98, - ForSyDe > 3.0, regex-posix ,data-accessor-template, pretty, - data-accessor, containers, prettyclass, tfp > 0.3.2, - tfvec > 0.1.2, QuickCheck, template-haskell, filepath +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 executable: clash -main-is: Main.hs -ghc-options: +main-is: Main.hs -- 2.30.2